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
40 double precision time01
42 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
43 c & " nfgtasks",nfgtasks
44 if (nfgtasks.gt.1) then
46 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
47 if (fg_rank.eq.0) then
48 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
49 c print *,"Processor",myrank," BROADCAST iorder"
50 C FG master sets up the WEIGHTS_ array which will be broadcast to the
51 C FG slaves as WEIGHTS array.
74 weights_(28)=wdfa_dist
77 weights_(31)=wdfa_beta
78 C FG Master broadcasts the WEIGHTS_ array
79 call MPI_Bcast(weights_(1),n_ene,
80 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
82 C FG slaves receive the WEIGHTS array
83 call MPI_Bcast(weights(1),n_ene,
84 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
107 wdfa_dist=weights(28)
110 wdfa_beta=weights(31)
112 time_Bcast=time_Bcast+MPI_Wtime()-time00
113 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
114 c call chainbuild_cart
116 if (nfgtasks.gt.1) then
117 call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
119 c write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
120 if (mod(itime_mat,imatupdate).eq.0) then
124 call make_SCp_inter_list
125 c write (iout,*) "Finished make_SCp_inter_list"
127 call make_SCSC_inter_list
128 c write (iout,*) "Finished make_SCSC_inter_list"
130 call make_pp_inter_list
131 c write (iout,*) "Finished make_pp_inter_list"
133 c call make_pp_vdw_inter_list
134 c write (iout,*) "Finished make_pp_vdw_inter_list"
137 time_list=time_list+MPI_Wtime()-time01
140 c print *,'Processor',myrank,' calling etotal ipot=',ipot
141 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
143 c if (modecalc.eq.12.or.modecalc.eq.14) then
144 c call int_from_cart1(.false.)
158 C Compute the side-chain and electrostatic interaction energy
164 goto (101,102,103,104,105,106) ipot
165 C Lennard-Jones potential.
167 cd print '(a)','Exit ELJ'
169 C Lennard-Jones-Kihara potential (shifted).
172 C Berne-Pechukas potential (dilated LJ, angular dependence).
175 C Gay-Berne potential (shifted LJ, angular dependence).
177 C print *,"bylem w egb"
179 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
182 C Soft-sphere potential
183 106 call e_softsphere(evdw)
185 C Calculate electrostatic (H-bonding) energy of the main chain.
189 time_evdw=time_evdw+MPI_Wtime()-time01
192 C BARTEK for dfa test!
193 c print *,"Processors",MyRank," wdfa",wdfa_dist
194 if (wdfa_dist.gt.0) then
196 c print *,"Processors",MyRank," edfadis",edfadis
200 c print*, 'edfad is finished!', edfadis
201 if (wdfa_tor.gt.0) then
206 c print*, 'edfat is finished!', edfator
207 if (wdfa_nei.gt.0) then
212 c print*, 'edfan is finished!', edfanei
213 if (wdfa_beta.gt.0) then
220 cmc Sep-06: egb takes care of dynamic ss bonds too
222 c if (dyn_ss) call dyn_set_nss
224 c print *,"Processor",myrank," computed USCSC"
230 time_vec=time_vec+MPI_Wtime()-time01
235 C Introduction of shielding effect first for each peptide group
236 C the shielding factor is set this factor is describing how each
237 C peptide group is shielded by side-chains
238 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
239 C write (iout,*) "shield_mode",shield_mode
240 if (shield_mode.eq.1) then
242 else if (shield_mode.eq.2) then
245 c print *,"Processor",myrank," left VEC_AND_DERIV"
248 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
249 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
250 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
251 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
253 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
254 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
255 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
256 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
258 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
267 write (iout,*) "Soft-spheer ELEC potential"
268 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
272 time_eelec=time_eelec+MPI_Wtime()-time01
275 c time_enecalc=time_enecalc+MPI_Wtime()-time00
277 c print *,"Processor",myrank," computed UELEC"
279 C Calculate excluded-volume interaction energy between peptide groups
287 call escp(evdw2,evdw2_14)
293 c write (iout,*) "Soft-sphere SCP potential"
294 call escp_soft_sphere(evdw2,evdw2_14)
297 time_escp=time_escp+MPI_Wtime()-time01
300 c Calculate the bond-stretching energy
304 C Calculate the disulfide-bridge and other energy and the contributions
305 C from other distance constraints.
306 cd write (iout,*) 'Calling EHPB'
308 cd print *,'EHPB exitted succesfully.'
310 C Calculate the virtual-bond-angle energy.
312 if (wang.gt.0d0) then
313 if (tor_mode.eq.0) then
316 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
324 if (with_theta_constr) call etheta_constr(ethetacnstr)
325 c print *,"Processor",myrank," computed UB"
327 C Calculate the SC local energy.
329 C print *,"TU DOCHODZE?"
331 c print *,"Processor",myrank," computed USC"
333 C Calculate the virtual-bond torsional energy.
335 cd print *,'nterm=',nterm
336 C print *,"tor",tor_mode
337 if (wtor.gt.0.0d0) then
338 if (tor_mode.eq.0) then
341 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
349 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
350 c print *,"Processor",myrank," computed Utor"
351 if (constr_homology.ge.1) then
352 call e_modeller(ehomology_constr)
353 c print *,'iset=',iset,'me=',me,ehomology_constr,
354 c & 'Processor',fg_rank,' CG group',kolor,
355 c & ' absolute rank',MyRank
357 ehomology_constr=0.0d0
360 C 6/23/01 Calculate double-torsional energy
362 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
367 c print *,"Processor",myrank," computed Utord"
369 C 21/5/07 Calculate local sicdechain correlation energy
371 if (wsccor.gt.0.0d0) then
372 call eback_sc_corr(esccor)
377 C print *,"PRZED MULIt"
378 c print *,"Processor",myrank," computed Usccorr"
380 C 12/1/95 Multi-body terms
384 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
385 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
386 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
387 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
388 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
396 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
397 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
400 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
401 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
416 c print *,"Processor",myrank," computed Ucorr"
417 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
418 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
419 call e_saxs(Esaxs_constr)
420 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
421 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
422 call e_saxsC(Esaxs_constr)
423 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
428 C If performing constraint dynamics, call the constraint energy
429 C after the equilibration time
430 c if(usampl.and.totT.gt.eq_time) then
431 c write (iout,*) "usampl",usampl
435 call Econstr_back_qlike
443 C 01/27/2015 added by adasko
444 C the energy component below is energy transfer into lipid environment
445 C based on partition function
446 C print *,"przed lipidami"
447 if (wliptran.gt.0) then
448 call Eliptransfer(eliptran)
452 C print *,"za lipidami"
453 if (AFMlog.gt.0) then
454 call AFMforce(Eafmforce)
455 else if (selfguide.gt.0) then
456 call AFMvel(Eafmforce)
460 if (TUBElog.eq.1) then
461 C print *,"just before call"
463 elseif (TUBElog.eq.2) then
464 call calctube2(Etube)
470 time_enecalc=time_enecalc+MPI_Wtime()-time00
472 c print *,"Processor",myrank," computed Uconstr"
481 energia(2)=evdw2-evdw2_14
498 energia(8)=eello_turn3
499 energia(9)=eello_turn4
506 energia(19)=edihcnstr
508 energia(20)=Uconst+Uconst_back
511 energia(23)=Eafmforce
512 energia(24)=ethetacnstr
514 energia(26)=Esaxs_constr
515 energia(27)=ehomology_constr
520 c write (iout,*) "esaxs_constr",energia(26)
521 c Here are the energies showed per procesor if the are more processors
522 c per molecule then we sum it up in sum_energy subroutine
523 c print *," Processor",myrank," calls SUM_ENERGY"
524 call sum_energy(energia,.true.)
525 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
526 if (dyn_ss) call dyn_set_nss
527 c print *," Processor",myrank," left SUM_ENERGY"
529 time_sumene=time_sumene+MPI_Wtime()-time00
533 c-------------------------------------------------------------------------------
534 subroutine sum_energy(energia,reduce)
540 cMS$ATTRIBUTES C :: proc_proc
546 double precision time00
548 include 'COMMON.SETUP'
549 include 'COMMON.IOUNITS'
550 double precision energia(0:n_ene),enebuff(0:n_ene+1)
551 include 'COMMON.FFIELD'
552 include 'COMMON.DERIV'
553 include 'COMMON.INTERACT'
554 include 'COMMON.SBRIDGE'
555 include 'COMMON.CHAIN'
557 include 'COMMON.CONTROL'
558 include 'COMMON.TIME1'
561 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
562 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
563 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
564 & eliptran,Eafmforce,Etube,
565 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
566 double precision Uconst,etot
568 if (nfgtasks.gt.1 .and. reduce) then
570 write (iout,*) "energies before REDUCE"
571 call enerprint(energia)
575 enebuff(i)=energia(i)
578 call MPI_Barrier(FG_COMM,IERR)
579 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
581 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
582 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
584 write (iout,*) "energies after REDUCE"
585 call enerprint(energia)
588 time_Reduce=time_Reduce+MPI_Wtime()-time00
590 if (fg_rank.eq.0) then
594 evdw2=energia(2)+energia(18)
610 eello_turn3=energia(8)
611 eello_turn4=energia(9)
618 edihcnstr=energia(19)
623 Eafmforce=energia(23)
624 ethetacnstr=energia(24)
626 esaxs_constr=energia(26)
627 ehomology_constr=energia(27)
633 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
634 & +wang*ebe+wtor*etors+wscloc*escloc
635 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
636 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
637 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
638 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
639 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
640 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
643 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
644 & +wang*ebe+wtor*etors+wscloc*escloc
645 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
646 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
647 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
648 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
650 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
651 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
658 if (isnan(etot).ne.0) energia(0)=1.0d+99
660 if (isnan(etot)) energia(0)=1.0d+99
665 idumm=proc_proc(etot,i)
667 call proc_proc(etot,i)
669 if(i.eq.1)energia(0)=1.0d+99
676 c-------------------------------------------------------------------------------
677 subroutine sum_gradient
683 cMS$ATTRIBUTES C :: proc_proc
689 double precision time00,time01
691 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
692 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
693 & ,gloc_scbuf(3,-1:maxres)
694 include 'COMMON.SETUP'
695 include 'COMMON.IOUNITS'
696 include 'COMMON.FFIELD'
697 include 'COMMON.DERIV'
698 include 'COMMON.INTERACT'
699 include 'COMMON.SBRIDGE'
700 include 'COMMON.CHAIN'
702 include 'COMMON.CONTROL'
703 include 'COMMON.TIME1'
704 include 'COMMON.MAXGRAD'
705 include 'COMMON.SCCOR'
706 c include 'COMMON.MD'
707 include 'COMMON.QRESTR'
709 double precision scalar
710 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
711 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
712 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
713 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
714 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
720 write (iout,*) "sum_gradient gvdwc, gvdwx"
722 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
723 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
728 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
730 write (iout,'(i3,3e15.5,5x,3e15.5)')
731 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
736 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
737 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
738 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
741 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
742 C in virtual-bond-vector coordinates
745 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
747 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
748 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
750 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
752 c write (iout,'(i5,3f10.5,2x,f10.5)')
753 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
755 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
757 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
758 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
764 write (iout,*) "gsaxsc"
766 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
773 gradbufc(j,i)=wsc*gvdwc(j,i)+
774 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
775 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
776 & wel_loc*gel_loc_long(j,i)+
777 & wcorr*gradcorr_long(j,i)+
778 & wcorr5*gradcorr5_long(j,i)+
779 & wcorr6*gradcorr6_long(j,i)+
780 & wturn6*gcorr6_turn_long(j,i)+
782 & +wliptran*gliptranc(j,i)
784 & +welec*gshieldc(j,i)
785 & +wcorr*gshieldc_ec(j,i)
786 & +wturn3*gshieldc_t3(j,i)
787 & +wturn4*gshieldc_t4(j,i)
788 & +wel_loc*gshieldc_ll(j,i)
789 & +wtube*gg_tube(j,i)
796 gradbufc(j,i)=wsc*gvdwc(j,i)+
797 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
798 & welec*gelc_long(j,i)+
800 & wel_loc*gel_loc_long(j,i)+
801 & wcorr*gradcorr_long(j,i)+
802 & wcorr5*gradcorr5_long(j,i)+
803 & wcorr6*gradcorr6_long(j,i)+
804 & wturn6*gcorr6_turn_long(j,i)+
806 & +wliptran*gliptranc(j,i)
808 & +welec*gshieldc(j,i)
809 & +wcorr*gshieldc_ec(j,i)
810 & +wturn4*gshieldc_t4(j,i)
811 & +wel_loc*gshieldc_ll(j,i)
812 & +wtube*gg_tube(j,i)
819 gradbufc(j,i)=gradbufc(j,i)+
820 & wdfa_dist*gdfad(j,i)+
821 & wdfa_tor*gdfat(j,i)+
822 & wdfa_nei*gdfan(j,i)+
823 & wdfa_beta*gdfab(j,i)
827 write (iout,*) "gradc from gradbufc"
829 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
834 if (nfgtasks.gt.1) then
837 write (iout,*) "gradbufc before allreduce"
839 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
845 gradbufc_sum(j,i)=gradbufc(j,i)
848 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
849 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
850 c time_reduce=time_reduce+MPI_Wtime()-time00
852 c write (iout,*) "gradbufc_sum after allreduce"
854 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
859 c time_allreduce=time_allreduce+MPI_Wtime()-time00
868 c write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
869 c write (iout,*) (i," jgrad_start",jgrad_start(i),
870 c & " jgrad_end ",jgrad_end(i),
871 c & i=igrad_start,igrad_end)
874 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
875 c do not parallelize this part.
877 c do i=igrad_start,igrad_end
878 c do j=jgrad_start(i),jgrad_end(i)
880 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
885 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
890 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
894 write (iout,*) "gradbufc after summing"
896 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
903 write (iout,*) "gradbufc"
905 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
912 gradbufc_sum(j,i)=gradbufc(j,i)
917 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
922 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
927 c gradbufc(k,i)=0.0d0
931 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
936 write (iout,*) "gradbufc after summing"
938 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
946 gradbufc(k,nres)=0.0d0
952 C print *,gradbufc(1,13)
953 C print *,welec*gelc(1,13)
954 C print *,wel_loc*gel_loc(1,13)
955 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
956 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
957 C print *,wel_loc*gel_loc_long(1,13)
958 C print *,gradafm(1,13),"AFM"
959 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
960 & wel_loc*gel_loc(j,i)+
961 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
962 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
963 & wel_loc*gel_loc_long(j,i)+
964 & wcorr*gradcorr_long(j,i)+
965 & wcorr5*gradcorr5_long(j,i)+
966 & wcorr6*gradcorr6_long(j,i)+
967 & wturn6*gcorr6_turn_long(j,i))+
969 & wcorr*gradcorr(j,i)+
970 & wturn3*gcorr3_turn(j,i)+
971 & wturn4*gcorr4_turn(j,i)+
972 & wcorr5*gradcorr5(j,i)+
973 & wcorr6*gradcorr6(j,i)+
974 & wturn6*gcorr6_turn(j,i)+
975 & wsccor*gsccorc(j,i)
976 & +wscloc*gscloc(j,i)
977 & +wliptran*gliptranc(j,i)
979 & +welec*gshieldc(j,i)
980 & +welec*gshieldc_loc(j,i)
981 & +wcorr*gshieldc_ec(j,i)
982 & +wcorr*gshieldc_loc_ec(j,i)
983 & +wturn3*gshieldc_t3(j,i)
984 & +wturn3*gshieldc_loc_t3(j,i)
985 & +wturn4*gshieldc_t4(j,i)
986 & +wturn4*gshieldc_loc_t4(j,i)
987 & +wel_loc*gshieldc_ll(j,i)
988 & +wel_loc*gshieldc_loc_ll(j,i)
989 & +wtube*gg_tube(j,i)
992 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
993 & wel_loc*gel_loc(j,i)+
994 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
995 & welec*gelc_long(j,i)+
996 & wel_loc*gel_loc_long(j,i)+
997 & wcorr*gcorr_long(j,i)+
998 & wcorr5*gradcorr5_long(j,i)+
999 & wcorr6*gradcorr6_long(j,i)+
1000 & wturn6*gcorr6_turn_long(j,i))+
1002 & wcorr*gradcorr(j,i)+
1003 & wturn3*gcorr3_turn(j,i)+
1004 & wturn4*gcorr4_turn(j,i)+
1005 & wcorr5*gradcorr5(j,i)+
1006 & wcorr6*gradcorr6(j,i)+
1007 & wturn6*gcorr6_turn(j,i)+
1008 & wsccor*gsccorc(j,i)
1009 & +wscloc*gscloc(j,i)
1010 & +wliptran*gliptranc(j,i)
1012 & +welec*gshieldc(j,i)
1013 & +welec*gshieldc_loc(j,i)
1014 & +wcorr*gshieldc_ec(j,i)
1015 & +wcorr*gshieldc_loc_ec(j,i)
1016 & +wturn3*gshieldc_t3(j,i)
1017 & +wturn3*gshieldc_loc_t3(j,i)
1018 & +wturn4*gshieldc_t4(j,i)
1019 & +wturn4*gshieldc_loc_t4(j,i)
1020 & +wel_loc*gshieldc_ll(j,i)
1021 & +wel_loc*gshieldc_loc_ll(j,i)
1022 & +wtube*gg_tube(j,i)
1026 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
1027 & wbond*gradbx(j,i)+
1028 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
1029 & wsccor*gsccorx(j,i)
1030 & +wscloc*gsclocx(j,i)
1031 & +wliptran*gliptranx(j,i)
1032 & +welec*gshieldx(j,i)
1033 & +wcorr*gshieldx_ec(j,i)
1034 & +wturn3*gshieldx_t3(j,i)
1035 & +wturn4*gshieldx_t4(j,i)
1036 & +wel_loc*gshieldx_ll(j,i)
1037 & +wtube*gg_tube_sc(j,i)
1038 & +wsaxs*gsaxsx(j,i)
1044 if (constr_homology.gt.0) then
1047 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1048 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1053 write (iout,*) "gradc gradx gloc after adding"
1054 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1055 & i,(gradc(j,0,icg),j=1,3),(gradx(j,0,icg),j=1,3)
1057 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1058 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1062 write (iout,*) "gloc before adding corr"
1064 write (iout,*) i,gloc(i,icg)
1068 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1069 & +wcorr5*g_corr5_loc(i)
1070 & +wcorr6*g_corr6_loc(i)
1071 & +wturn4*gel_loc_turn4(i)
1072 & +wturn3*gel_loc_turn3(i)
1073 & +wturn6*gel_loc_turn6(i)
1074 & +wel_loc*gel_loc_loc(i)
1077 write (iout,*) "gloc after adding corr"
1079 write (iout,*) i,gloc(i,icg)
1083 if (nfgtasks.gt.1) then
1086 gradbufc(j,i)=gradc(j,i,icg)
1087 gradbufx(j,i)=gradx(j,i,icg)
1091 glocbuf(i)=gloc(i,icg)
1095 write (iout,*) "gloc_sc before reduce"
1098 write (iout,*) i,j,gloc_sc(j,i,icg)
1105 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1109 call MPI_Barrier(FG_COMM,IERR)
1110 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1112 call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*(nres+1),
1113 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1114 call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*(nres+1),
1115 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1116 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1117 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1118 time_reduce=time_reduce+MPI_Wtime()-time00
1119 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1120 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1121 time_reduce=time_reduce+MPI_Wtime()-time00
1123 write (iout,*) "gradc after reduce"
1126 write (iout,*) i,j,gradc(j,i,icg)
1131 write (iout,*) "gloc_sc after reduce"
1134 write (iout,*) i,j,gloc_sc(j,i,icg)
1139 write (iout,*) "gloc after reduce"
1141 write (iout,*) i,gloc(i,icg)
1146 if (gnorm_check) then
1148 c Compute the maximum elements of the gradient
1158 gcorr3_turn_max=0.0d0
1159 gcorr4_turn_max=0.0d0
1162 gcorr6_turn_max=0.0d0
1172 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1173 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1174 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1175 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1176 & gvdwc_scp_max=gvdwc_scp_norm
1177 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1178 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1179 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1180 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1181 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1182 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1183 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1184 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1185 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1186 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1187 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1188 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1189 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1190 & gcorr3_turn(1,i)))
1191 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1192 & gcorr3_turn_max=gcorr3_turn_norm
1193 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1194 & gcorr4_turn(1,i)))
1195 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1196 & gcorr4_turn_max=gcorr4_turn_norm
1197 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1198 if (gradcorr5_norm.gt.gradcorr5_max)
1199 & gradcorr5_max=gradcorr5_norm
1200 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1201 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1202 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1203 & gcorr6_turn(1,i)))
1204 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1205 & gcorr6_turn_max=gcorr6_turn_norm
1206 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1207 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1208 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1209 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1210 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1211 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1212 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1213 if (gradx_scp_norm.gt.gradx_scp_max)
1214 & gradx_scp_max=gradx_scp_norm
1215 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1216 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1217 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1218 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1219 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1220 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1221 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1222 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1225 #if (defined AIX || defined CRAY)
1226 open(istat,file=statname,position="append")
1228 open(istat,file=statname,access="append")
1230 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1231 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1232 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1233 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1234 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1235 & gsccorrx_max,gsclocx_max
1237 if (gvdwc_max.gt.1.0d4) then
1238 write (iout,*) "gvdwc gvdwx gradb gradbx"
1240 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1241 & gradb(j,i),gradbx(j,i),j=1,3)
1243 call pdbout(0.0d0,'cipiszcze',iout)
1249 write (iout,*) "gradc gradx gloc"
1251 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1252 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1256 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1260 c-------------------------------------------------------------------------------
1261 subroutine rescale_weights(t_bath)
1267 include 'DIMENSIONS'
1268 include 'COMMON.IOUNITS'
1269 include 'COMMON.FFIELD'
1270 include 'COMMON.SBRIDGE'
1271 include 'COMMON.CONTROL'
1272 double precision t_bath
1273 double precision facT,facT2,facT3,facT4,facT5
1274 double precision kfac /2.4d0/
1275 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1277 c facT=2*temp0/(t_bath+temp0)
1278 if (rescale_mode.eq.0) then
1284 else if (rescale_mode.eq.1) then
1285 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1286 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1287 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1288 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1289 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1290 else if (rescale_mode.eq.2) then
1296 facT=licznik/dlog(dexp(x)+dexp(-x))
1297 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1298 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1299 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1300 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1302 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1303 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1305 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1309 if (shield_mode.gt.0) then
1310 wscp=weights(2)*fact
1312 wvdwpp=weights(16)*fact
1314 welec=weights(3)*fact
1315 wcorr=weights(4)*fact3
1316 wcorr5=weights(5)*fact4
1317 wcorr6=weights(6)*fact5
1318 wel_loc=weights(7)*fact2
1319 wturn3=weights(8)*fact2
1320 wturn4=weights(9)*fact3
1321 wturn6=weights(10)*fact5
1322 wtor=weights(13)*fact
1323 wtor_d=weights(14)*fact2
1324 wsccor=weights(21)*fact
1325 if (scale_umb) wumb=t_bath/temp0
1326 c write (iout,*) "scale_umb",scale_umb
1327 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1331 C------------------------------------------------------------------------
1332 subroutine enerprint(energia)
1334 include 'DIMENSIONS'
1335 include 'COMMON.IOUNITS'
1336 include 'COMMON.FFIELD'
1337 include 'COMMON.SBRIDGE'
1338 include 'COMMON.QRESTR'
1339 double precision energia(0:n_ene)
1340 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1341 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1342 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1344 & eliptran,Eafmforce,Etube,
1345 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1350 evdw2=energia(2)+energia(18)
1362 eello_turn3=energia(8)
1363 eello_turn4=energia(9)
1364 eello_turn6=energia(10)
1370 edihcnstr=energia(19)
1374 eliptran=energia(22)
1375 Eafmforce=energia(23)
1376 ethetacnstr=energia(24)
1379 ehomology_constr=energia(27)
1381 edfadis = energia(28)
1382 edfator = energia(29)
1383 edfanei = energia(30)
1384 edfabet = energia(31)
1386 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1387 & estr,wbond,ebe,wang,
1388 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1391 & ecorr5,wcorr5,ecorr6,wcorr6,
1393 & eel_loc,wel_loc,eello_turn3,wturn3,
1394 & eello_turn4,wturn4,
1396 & eello_turn6,wturn6,
1398 & esccor,wsccor,edihcnstr,
1399 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1400 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1401 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1402 & edfabet,wdfa_beta,
1404 10 format (/'Virtual-chain energies:'//
1405 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1406 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1407 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1408 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1409 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1410 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1411 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1412 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1413 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1414 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1415 & ' (SS bridges & dist. cnstr.)'/
1417 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1418 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1419 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1421 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1422 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1423 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1425 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1427 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1428 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1429 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1430 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1431 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1432 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1433 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1434 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1435 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1436 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1437 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1438 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1439 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1440 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1441 & 'ETOT= ',1pE16.6,' (total)')
1444 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1445 & estr,wbond,ebe,wang,
1446 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1449 & ecorr5,wcorr5,ecorr6,wcorr6,
1451 & eel_loc,wel_loc,eello_turn3,wturn3,
1452 & eello_turn4,wturn4,
1454 & eello_turn6,wturn6,
1456 & esccor,wsccor,edihcnstr,
1457 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1458 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1459 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1460 & edfabet,wdfa_beta,
1462 10 format (/'Virtual-chain energies:'//
1463 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1464 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1465 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1466 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1467 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1468 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1469 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1470 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1471 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1472 & ' (SS bridges & dist. restr.)'/
1474 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1475 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1476 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1478 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1479 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1480 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1482 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1484 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1485 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1486 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1487 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1488 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1489 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1490 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1491 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1492 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1493 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1494 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1495 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1496 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1497 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1498 & 'ETOT= ',1pE16.6,' (total)')
1502 C-----------------------------------------------------------------------
1503 subroutine elj(evdw)
1505 C This subroutine calculates the interaction energy of nonbonded side chains
1506 C assuming the LJ potential of interaction.
1509 double precision accur
1510 include 'DIMENSIONS'
1511 parameter (accur=1.0d-10)
1512 include 'COMMON.GEO'
1513 include 'COMMON.VAR'
1514 include 'COMMON.LOCAL'
1515 include 'COMMON.CHAIN'
1516 include 'COMMON.DERIV'
1517 include 'COMMON.INTERACT'
1518 include 'COMMON.TORSION'
1519 include 'COMMON.SBRIDGE'
1520 include 'COMMON.NAMES'
1521 include 'COMMON.IOUNITS'
1522 include 'COMMON.SPLITELE'
1524 include 'COMMON.CONTACTS'
1525 include 'COMMON.CONTMAT'
1527 double precision gg(3)
1528 double precision evdw,evdwij
1529 integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1530 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1531 & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1532 double precision fcont,fprimcont
1533 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1535 double precision sscale,sscagrad,sscagradlip,sscalelip
1536 double precision gg_lipi(3),gg_lipj(3)
1537 double precision boxshift
1539 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1543 c do i=iatsc_s,iatsc_e
1544 do ikont=g_listscsc_start,g_listscsc_end
1545 i=newcontlisti(ikont)
1546 j=newcontlistj(ikont)
1547 itypi=iabs(itype(i))
1548 if (itypi.eq.ntyp1) cycle
1549 itypi1=iabs(itype(i+1))
1553 call to_box(xi,yi,zi)
1554 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1558 C Calculate SC interaction energy.
1560 c do iint=1,nint_gr(i)
1561 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1562 cd & 'iend=',iend(i,iint)
1563 c do j=istart(i,iint),iend(i,iint)
1564 itypj=iabs(itype(j))
1565 if (itypj.eq.ntyp1) cycle
1569 call to_box(xj,yj,zj)
1570 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1571 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1572 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1573 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1574 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1575 xj=boxshift(xj-xi,boxxsize)
1576 yj=boxshift(yj-yi,boxysize)
1577 zj=boxshift(zj-zi,boxzsize)
1578 C Change 12/1/95 to calculate four-body interactions
1579 rij=xj*xj+yj*yj+zj*zj
1582 sss1=sscale(sqrij,r_cut_int)
1583 if (sss1.eq.0.0d0) cycle
1584 sssgrad1=sscagrad(sqrij,r_cut_int)
1586 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1587 eps0ij=eps(itypi,itypj)
1590 C have you changed here?
1594 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1595 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1596 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1597 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1598 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1599 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1600 evdw=evdw+sss1*evdwij
1602 C Calculate the components of the gradient in DC and X
1604 fac=-rrij*(e1+evdwij)*sss1
1605 & +evdwij*sssgrad1/sqrij/expon
1609 gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1610 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1611 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1612 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1613 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1615 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1616 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1617 gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1618 gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1622 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1627 C 12/1/95, revised on 5/20/97
1629 C Calculate the contact function. The ith column of the array JCONT will
1630 C contain the numbers of atoms that make contacts with the atom I (of numbers
1631 C greater than I). The arrays FACONT and GACONT will contain the values of
1632 C the contact function and its derivative.
1634 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1635 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1636 C Uncomment next line, if the correlation interactions are contact function only
1637 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1639 sigij=sigma(itypi,itypj)
1640 r0ij=rs0(itypi,itypj)
1642 C Check whether the SC's are not too far to make a contact.
1645 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1646 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1648 if (fcont.gt.0.0D0) then
1649 C If the SC-SC distance if close to sigma, apply spline.
1650 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1651 cAdam & fcont1,fprimcont1)
1652 cAdam fcont1=1.0d0-fcont1
1653 cAdam if (fcont1.gt.0.0d0) then
1654 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1655 cAdam fcont=fcont*fcont1
1657 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1658 cga eps0ij=1.0d0/dsqrt(eps0ij)
1660 cga gg(k)=gg(k)*eps0ij
1662 cga eps0ij=-evdwij*eps0ij
1663 C Uncomment for AL's type of SC correlation interactions.
1664 cadam eps0ij=-evdwij
1665 num_conti=num_conti+1
1666 jcont(num_conti,i)=j
1667 facont(num_conti,i)=fcont*eps0ij
1668 fprimcont=eps0ij*fprimcont/rij
1670 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1671 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1672 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1673 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1674 gacont(1,num_conti,i)=-fprimcont*xj
1675 gacont(2,num_conti,i)=-fprimcont*yj
1676 gacont(3,num_conti,i)=-fprimcont*zj
1677 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1678 cd write (iout,'(2i3,3f10.5)')
1679 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1687 num_cont(i)=num_conti
1692 gvdwc(j,i)=expon*gvdwc(j,i)
1693 gvdwx(j,i)=expon*gvdwx(j,i)
1696 C******************************************************************************
1700 C To save time, the factor of EXPON has been extracted from ALL components
1701 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1704 C******************************************************************************
1707 C-----------------------------------------------------------------------------
1708 subroutine eljk(evdw)
1710 C This subroutine calculates the interaction energy of nonbonded side chains
1711 C assuming the LJK potential of interaction.
1714 include 'DIMENSIONS'
1715 include 'COMMON.GEO'
1716 include 'COMMON.VAR'
1717 include 'COMMON.LOCAL'
1718 include 'COMMON.CHAIN'
1719 include 'COMMON.DERIV'
1720 include 'COMMON.INTERACT'
1721 include 'COMMON.IOUNITS'
1722 include 'COMMON.NAMES'
1723 include 'COMMON.SPLITELE'
1724 double precision gg(3)
1725 double precision evdw,evdwij
1726 integer i,j,k,itypi,itypj,itypi1,iint,ikont
1727 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1728 & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1730 double precision boxshift
1731 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1733 double precision gg_lipi(3),gg_lipj(3)
1734 double precision sscale,sscagrad,sscagradlip,sscalelip
1735 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1739 c do i=iatsc_s,iatsc_e
1740 do ikont=g_listscsc_start,g_listscsc_end
1741 i=newcontlisti(ikont)
1742 j=newcontlistj(ikont)
1743 itypi=iabs(itype(i))
1744 if (itypi.eq.ntyp1) cycle
1745 itypi1=iabs(itype(i+1))
1749 call to_box(xi,yi,zi)
1750 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1752 C Calculate SC interaction energy.
1754 c do iint=1,nint_gr(i)
1755 c do j=istart(i,iint),iend(i,iint)
1756 itypj=iabs(itype(j))
1757 if (itypj.eq.ntyp1) cycle
1761 call to_box(xj,yj,zj)
1762 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1763 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1764 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1765 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1766 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1767 xj=boxshift(xj-xi,boxxsize)
1768 yj=boxshift(yj-yi,boxysize)
1769 zj=boxshift(zj-zi,boxzsize)
1770 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1771 fac_augm=rrij**expon
1772 e_augm=augm(itypi,itypj)*fac_augm
1773 r_inv_ij=dsqrt(rrij)
1775 sss1=sscale(rij,r_cut_int)
1776 if (sss1.eq.0.0d0) cycle
1777 sssgrad1=sscagrad(rij,r_cut_int)
1778 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1779 fac=r_shift_inv**expon
1781 C have you changed here?
1785 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1786 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1787 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1788 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1789 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1790 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1791 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1792 evdw=evdw+evdwij*sss1
1794 C Calculate the components of the gradient in DC and X
1796 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1797 & +evdwij*sssgrad1*r_inv_ij/expon
1801 gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1802 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1803 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1804 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1805 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1807 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1808 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1809 gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1810 gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1814 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1822 gvdwc(j,i)=expon*gvdwc(j,i)
1823 gvdwx(j,i)=expon*gvdwx(j,i)
1828 C-----------------------------------------------------------------------------
1829 subroutine ebp(evdw)
1831 C This subroutine calculates the interaction energy of nonbonded side chains
1832 C assuming the Berne-Pechukas potential of interaction.
1835 include 'DIMENSIONS'
1836 include 'COMMON.GEO'
1837 include 'COMMON.VAR'
1838 include 'COMMON.LOCAL'
1839 include 'COMMON.CHAIN'
1840 include 'COMMON.DERIV'
1841 include 'COMMON.NAMES'
1842 include 'COMMON.INTERACT'
1843 include 'COMMON.IOUNITS'
1844 include 'COMMON.CALC'
1845 include 'COMMON.SPLITELE'
1847 common /srutu/ icall
1848 double precision evdw
1849 integer itypi,itypj,itypi1,iint,ind,ikont
1850 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1852 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1854 double precision sscale,sscagrad,sscagradlip,sscalelip
1855 double precision boxshift
1856 c double precision rrsave(maxdim)
1859 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1862 c if (icall.eq.0) then
1868 c do i=iatsc_s,iatsc_e
1869 do ikont=g_listscsc_start,g_listscsc_end
1870 i=newcontlisti(ikont)
1871 j=newcontlistj(ikont)
1872 itypi=iabs(itype(i))
1873 if (itypi.eq.ntyp1) cycle
1874 itypi1=iabs(itype(i+1))
1878 call to_box(xi,yi,zi)
1879 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1880 dxi=dc_norm(1,nres+i)
1881 dyi=dc_norm(2,nres+i)
1882 dzi=dc_norm(3,nres+i)
1883 c dsci_inv=dsc_inv(itypi)
1884 dsci_inv=vbld_inv(i+nres)
1886 C Calculate SC interaction energy.
1888 c do iint=1,nint_gr(i)
1889 c do j=istart(i,iint),iend(i,iint)
1891 itypj=iabs(itype(j))
1892 if (itypj.eq.ntyp1) cycle
1893 c dscj_inv=dsc_inv(itypj)
1894 dscj_inv=vbld_inv(j+nres)
1895 chi1=chi(itypi,itypj)
1896 chi2=chi(itypj,itypi)
1903 alf12=0.5D0*(alf1+alf2)
1904 C For diagnostics only!!!
1917 call to_box(xj,yj,zj)
1918 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1919 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1920 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1921 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1922 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1923 xj=boxshift(xj-xi,boxxsize)
1924 yj=boxshift(yj-yi,boxysize)
1925 zj=boxshift(zj-zi,boxzsize)
1926 dxj=dc_norm(1,nres+j)
1927 dyj=dc_norm(2,nres+j)
1928 dzj=dc_norm(3,nres+j)
1929 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1930 cd if (icall.eq.0) then
1936 sss1=sscale(1.0d0/rij,r_cut_int)
1937 if (sss1.eq.0.0d0) cycle
1938 sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1939 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1941 C Calculate whole angle-dependent part of epsilon and contributions
1942 C to its derivatives
1943 C have you changed here?
1944 fac=(rrij*sigsq)**expon2
1948 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1949 eps2der=evdwij*eps3rt
1950 eps3der=evdwij*eps2rt
1951 evdwij=evdwij*eps2rt*eps3rt
1952 evdw=evdw+sss1*evdwij
1954 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1956 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1957 cd & restyp(itypi),i,restyp(itypj),j,
1958 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1959 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1960 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1963 C Calculate gradient components.
1964 e1=e1*eps1*eps2rt**2*eps3rt**2
1965 fac=-expon*(e1+evdwij)
1968 & +evdwij*sssgrad1/sss1*rij
1969 C Calculate radial part of the gradient
1973 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1974 & *(eps3rt*eps3rt)*sss1/2.0d0*(faclip*faclip*
1975 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1976 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1977 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1978 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1979 C Calculate the angular part of the gradient and sum add the contributions
1980 C to the appropriate components of the Cartesian gradient.
1988 C-----------------------------------------------------------------------------
1989 subroutine egb(evdw)
1991 C This subroutine calculates the interaction energy of nonbonded side chains
1992 C assuming the Gay-Berne potential of interaction.
1995 include 'DIMENSIONS'
1996 include 'COMMON.GEO'
1997 include 'COMMON.VAR'
1998 include 'COMMON.LOCAL'
1999 include 'COMMON.CHAIN'
2000 include 'COMMON.DERIV'
2001 include 'COMMON.NAMES'
2002 include 'COMMON.INTERACT'
2003 include 'COMMON.IOUNITS'
2004 include 'COMMON.CALC'
2005 include 'COMMON.CONTROL'
2006 include 'COMMON.SPLITELE'
2007 include 'COMMON.SBRIDGE'
2009 double precision evdw
2010 integer itypi,itypj,itypi1,iint,ind,ikont
2011 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
2012 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2013 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
2014 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2015 double precision boxshift
2016 double precision x0,y0,r012,rij12,facx0,
2017 & facx02,afacx0,bfacx0,abfacx0,Afac,BBfac,Afacsig,Bfacsig
2020 c alpha_GB1=1.0d0+1.0d0/alpha_GB
2022 ccccc energy_dec=.false.
2023 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2027 c if (icall.eq.0) lprn=.false.
2029 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
2030 C we have the original box)
2034 c do i=iatsc_s,iatsc_e
2035 do ikont=g_listscsc_start,g_listscsc_end
2036 i=newcontlisti(ikont)
2037 j=newcontlistj(ikont)
2038 itypi=iabs(itype(i))
2039 if (itypi.eq.ntyp1) cycle
2040 itypi1=iabs(itype(i+1))
2044 call to_box(xi,yi,zi)
2045 C define scaling factor for lipids
2047 C if (positi.le.0) positi=positi+boxzsize
2049 C first for peptide groups
2050 c for each residue check if it is in lipid or lipid water border area
2051 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2052 C xi=xi+xshift*boxxsize
2053 C yi=yi+yshift*boxysize
2054 C zi=zi+zshift*boxzsize
2056 dxi=dc_norm(1,nres+i)
2057 dyi=dc_norm(2,nres+i)
2058 dzi=dc_norm(3,nres+i)
2059 c dsci_inv=dsc_inv(itypi)
2060 dsci_inv=vbld_inv(i+nres)
2061 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2062 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2064 C Calculate SC interaction energy.
2066 c do iint=1,nint_gr(i)
2067 c do j=istart(i,iint),iend(i,iint)
2068 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2070 c write(iout,*) "PRZED ZWYKLE", evdwij
2071 call dyn_ssbond_ene(i,j,evdwij)
2072 c write(iout,*) "PO ZWYKLE", evdwij
2076 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2077 & 'evdw',i,j,evdwij,' ss'
2078 C triple bond artifac removal
2079 c do k=j+1,iend(i,iint)
2081 C search over all next residues
2082 if (dyn_ss_mask(k)) then
2083 C check if they are cysteins
2084 C write(iout,*) 'k=',k
2086 c write(iout,*) "PRZED TRI", evdwij
2087 evdwij_przed_tri=evdwij
2088 call triple_ssbond_ene(i,j,k,evdwij)
2089 c if(evdwij_przed_tri.ne.evdwij) then
2090 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2093 c write(iout,*) "PO TRI", evdwij
2094 C call the energy function that removes the artifical triple disulfide
2095 C bond the soubroutine is located in ssMD.F
2097 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2098 & 'evdw',i,j,evdwij,'tss'
2099 endif!dyn_ss_mask(k)
2103 itypj=iabs(itype(j))
2104 if (itypj.eq.ntyp1) cycle
2105 c dscj_inv=dsc_inv(itypj)
2106 dscj_inv=vbld_inv(j+nres)
2107 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2108 c & 1.0d0/vbld(j+nres)
2109 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2110 sig0ij=sigma(itypi,itypj)
2111 chi1=chi(itypi,itypj)
2112 chi2=chi(itypj,itypi)
2119 alf12=0.5D0*(alf1+alf2)
2120 C For diagnostics only!!!
2133 call to_box(xj,yj,zj)
2134 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2135 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2136 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2137 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2138 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2139 c write (iout,*) "aa bb",aa_lip(itypi,itypj),
2140 c & bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2141 c & bb_aq(itypi,itypj),aa,bb
2142 c write (iout,*) (sslipi+sslipj)/2.0d0,
2143 c & (2.0d0-sslipi-sslipj)/2.0d0
2145 c write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2146 c if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2147 c &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2148 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2149 C print *,sslipi,sslipj,bordlipbot,zi,zj
2150 xj=boxshift(xj-xi,boxxsize)
2151 yj=boxshift(yj-yi,boxysize)
2152 zj=boxshift(zj-zi,boxzsize)
2153 dxj=dc_norm(1,nres+j)
2154 dyj=dc_norm(2,nres+j)
2155 dzj=dc_norm(3,nres+j)
2159 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2160 c write (iout,*) "j",j," dc_norm",
2161 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2162 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2164 sss=sscale(1.0d0/rij,r_cut_int)
2165 c write (iout,'(a7,4f8.3)')
2166 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2167 if (sss.eq.0.0d0) cycle
2168 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2169 C Calculate angle-dependent terms of energy and contributions to their
2173 sig=sig0ij*dsqrt(sigsq)
2174 rij_shift=1.0D0/rij-sig+sig0ij
2176 c & write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2177 c & " sig",sig," sig0ij",sig0ij
2178 c for diagnostics; uncomment
2179 c rij_shift=1.2*sig0ij
2180 C I hate to put IF's in the loops, but here don't have another choice!!!!
2181 c if (rij_shift.le.0.0D0) then
2182 x0=alpha_GB*(sig-sig0ij)
2183 if (energy_dec) write (iout,*) i,j," x0",x0
2184 if (rij_shift.le.x0) then
2191 x0=alpha_GB*(sig-sig0ij)
2192 facx0=1.0d0/x0**expon
2194 r012=((1.0d0+alpha_GB)*(sig-sig0ij))**(2*expon)
2197 abfacx0=afacx0+0.5d0*bfacx0
2198 Afac=alpha_GB1*abfacx0
2199 Afacsig=0.5d0*alpha_GB1*bfacx0/(sig-sig0ij)
2200 BBfac=Afac-(afacx0+bfacx0)
2202 Bfacsig=(-alpha_GB1*(abfacx0+afacx0)+
2203 & (afacx0+afacx0+bfacx0))/(sig-sig0ij)
2206 Afacsig=Afacsig*r012
2209 c w(x)=4*eps*((1.0+1.0/alpha_GB)*(y0**12-0.5*y0**6)*(r0/x)**12-(1+1/alpha)*(y0**12-0.5*y0**6)+y0**12-y0**6)
2213 e1 = eps1*eps2rt*eps3rt*Afac*rij12
2214 e2 = -eps1*eps2rt*eps3rt*BBfac
2216 eps2der=evdwij*eps3rt
2217 eps3der=evdwij*eps2rt
2221 evdwij=evdwij*eps2rt*eps3rt
2225 write (iout,*) "aa",aa," bb",bb," sig0ij",sig0ij
2226 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2228 write (iout,'(2(a3,i3,2x),18(0pf9.5))')
2229 & restyp(itypi),i,restyp(itypj),j,
2230 & epsi,sigm,chi1,chi2,chip1,chip2,
2231 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2232 & eps1*eps2rt**2*eps3rt**2,om1,om2,om12,
2233 & 1.0D0/rij,rij_shift,
2236 if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2237 & 'RE r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2238 evdw=evdw+evdwij*sss
2239 C Calculate gradient components.
2241 sigder=-expon*eps1*eps2rt*eps2rt*eps3rt*eps3rt
2242 & *(Afacsig*rij12-Bfacsig)*sigder
2243 fac=-2.0d0*expon*e1*rij*rij
2244 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2245 c & evdwij,fac,sigma(itypi,itypj),expon
2246 fac=fac+evdwij*sssgrad/sss*rij
2248 c write (iout,*) "sigder",sigder," fac",fac," e1",e1,
2249 c & " e2",e2," sss",sss," sssgrad",sssgrad,"esp123",
2250 c & eps1*eps2rt**2*eps3rt**2
2251 C Calculate the radial part of the gradient
2252 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2253 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2254 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2255 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2256 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2257 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2264 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2265 cd & restyp(itypi),i,restyp(itypj),j,
2266 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2269 rij_shift=1.0D0/rij_shift
2271 c---------------------------------------------------------------
2272 fac=rij_shift**expon
2273 C here to start with
2278 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2279 eps2der=evdwij*eps3rt
2280 eps3der=evdwij*eps2rt
2281 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2282 C &((sslipi+sslipj)/2.0d0+
2283 C &(2.0d0-sslipi-sslipj)/2.0d0)
2284 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2285 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2286 evdwij=evdwij*eps2rt*eps3rt
2287 evdw=evdw+evdwij*sss
2288 if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2289 & 'GB r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2291 write (iout,*) "aa",aa," bb",bb," sig0ij",sig0ij
2292 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2294 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2295 & restyp(itypi),i,restyp(itypj),j,
2296 & epsi,sigm,chi1,chi2,chip1,chip2,
2297 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2298 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2303 C Calculate gradient components.
2304 e1=e1*eps1*eps2rt**2*eps3rt**2
2305 fac=-expon*(e1+evdwij)*rij_shift
2308 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2309 c & evdwij,fac,sigma(itypi,itypj),expon
2310 fac=fac+evdwij*sssgrad/sss*rij
2312 C Calculate the radial part of the gradient
2313 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2314 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2315 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2316 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2317 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2318 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2325 C Calculate angular part of the gradient.
2326 c call sc_grad_scale(sss)
2335 c write (iout,*) "Number of loop steps in EGB:",ind
2336 cccc energy_dec=.false.
2339 C-----------------------------------------------------------------------------
2340 subroutine egbv(evdw)
2342 C This subroutine calculates the interaction energy of nonbonded side chains
2343 C assuming the Gay-Berne-Vorobjev potential of interaction.
2346 include 'DIMENSIONS'
2347 include 'COMMON.GEO'
2348 include 'COMMON.VAR'
2349 include 'COMMON.LOCAL'
2350 include 'COMMON.CHAIN'
2351 include 'COMMON.DERIV'
2352 include 'COMMON.NAMES'
2353 include 'COMMON.INTERACT'
2354 include 'COMMON.IOUNITS'
2355 include 'COMMON.CALC'
2356 include 'COMMON.SPLITELE'
2357 double precision boxshift
2359 common /srutu/ icall
2361 double precision evdw
2362 integer itypi,itypj,itypi1,iint,ind,ikont
2363 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2364 & xi,yi,zi,fac_augm,e_augm
2365 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2366 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2367 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2369 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2373 c if (icall.eq.0) lprn=.true.
2375 c do i=iatsc_s,iatsc_e
2376 do ikont=g_listscsc_start,g_listscsc_end
2377 i=newcontlisti(ikont)
2378 j=newcontlistj(ikont)
2379 itypi=iabs(itype(i))
2380 if (itypi.eq.ntyp1) cycle
2381 itypi1=iabs(itype(i+1))
2385 call to_box(xi,yi,zi)
2386 C define scaling factor for lipids
2388 C if (positi.le.0) positi=positi+boxzsize
2390 C first for peptide groups
2391 c for each residue check if it is in lipid or lipid water border area
2392 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2393 dxi=dc_norm(1,nres+i)
2394 dyi=dc_norm(2,nres+i)
2395 dzi=dc_norm(3,nres+i)
2396 c dsci_inv=dsc_inv(itypi)
2397 dsci_inv=vbld_inv(i+nres)
2399 C Calculate SC interaction energy.
2401 c do iint=1,nint_gr(i)
2402 c do j=istart(i,iint),iend(i,iint)
2404 itypj=iabs(itype(j))
2405 if (itypj.eq.ntyp1) cycle
2406 c dscj_inv=dsc_inv(itypj)
2407 dscj_inv=vbld_inv(j+nres)
2408 sig0ij=sigma(itypi,itypj)
2409 r0ij=r0(itypi,itypj)
2410 chi1=chi(itypi,itypj)
2411 chi2=chi(itypj,itypi)
2418 alf12=0.5D0*(alf1+alf2)
2419 C For diagnostics only!!!
2432 call to_box(xj,yj,zj)
2433 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2434 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2435 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2436 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2437 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2438 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2439 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2440 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2441 xj=boxshift(xj-xi,boxxsize)
2442 yj=boxshift(yj-yi,boxysize)
2443 zj=boxshift(zj-zi,boxzsize)
2444 dxj=dc_norm(1,nres+j)
2445 dyj=dc_norm(2,nres+j)
2446 dzj=dc_norm(3,nres+j)
2447 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2449 sss=sscale(1.0d0/rij,r_cut_int)
2450 if (sss.eq.0.0d0) cycle
2451 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2452 C Calculate angle-dependent terms of energy and contributions to their
2456 sig=sig0ij*dsqrt(sigsq)
2457 rij_shift=1.0D0/rij-sig+r0ij
2458 C I hate to put IF's in the loops, but here don't have another choice!!!!
2459 if (rij_shift.le.0.0D0) then
2464 c---------------------------------------------------------------
2465 rij_shift=1.0D0/rij_shift
2466 fac=rij_shift**expon
2470 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2471 eps2der=evdwij*eps3rt
2472 eps3der=evdwij*eps2rt
2473 fac_augm=rrij**expon
2474 e_augm=augm(itypi,itypj)*fac_augm
2475 evdwij=evdwij*eps2rt*eps3rt
2476 evdw=evdw+evdwij+e_augm
2478 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2480 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2481 & restyp(itypi),i,restyp(itypj),j,
2482 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2483 & chi1,chi2,chip1,chip2,
2484 & eps1,eps2rt**2,eps3rt**2,
2485 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2488 C Calculate gradient components.
2489 e1=e1*eps1*eps2rt**2*eps3rt**2
2490 fac=-expon*(e1+evdwij)*rij_shift
2492 fac=rij*fac-2*expon*rrij*e_augm
2493 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2494 C Calculate the radial part of the gradient
2495 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2496 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2497 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2498 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2499 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2500 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2504 C Calculate angular part of the gradient.
2505 c call sc_grad_scale(sss)
2511 C-----------------------------------------------------------------------------
2512 subroutine sc_angular
2513 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2514 C om12. Called by ebp, egb, and egbv.
2516 include 'COMMON.CALC'
2517 include 'COMMON.IOUNITS'
2521 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2522 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2523 om12=dxi*dxj+dyi*dyj+dzi*dzj
2525 C Calculate eps1(om12) and its derivative in om12
2526 faceps1=1.0D0-om12*chiom12
2527 faceps1_inv=1.0D0/faceps1
2528 eps1=dsqrt(faceps1_inv)
2529 C Following variable is eps1*deps1/dom12
2530 eps1_om12=faceps1_inv*chiom12
2535 c write (iout,*) "om12",om12," eps1",eps1
2536 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2541 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2542 sigsq=1.0D0-facsig*faceps1_inv
2543 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2544 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2545 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2551 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2552 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2554 C Calculate eps2 and its derivatives in om1, om2, and om12.
2557 chipom12=chip12*om12
2558 facp=1.0D0-om12*chipom12
2560 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2561 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2562 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2563 C Following variable is the square root of eps2
2564 eps2rt=1.0D0-facp1*facp_inv
2565 C Following three variables are the derivatives of the square root of eps
2566 C in om1, om2, and om12.
2567 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2568 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2569 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2570 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2571 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2572 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2573 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2574 c & " eps2rt_om12",eps2rt_om12
2575 C Calculate whole angle-dependent part of epsilon and contributions
2576 C to its derivatives
2579 C----------------------------------------------------------------------------
2581 implicit real*8 (a-h,o-z)
2582 include 'DIMENSIONS'
2583 include 'COMMON.CHAIN'
2584 include 'COMMON.DERIV'
2585 include 'COMMON.CALC'
2586 include 'COMMON.IOUNITS'
2587 double precision dcosom1(3),dcosom2(3)
2588 cc print *,'sss=',sss
2589 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2590 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2591 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2592 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2596 c eom12=evdwij*eps1_om12
2598 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2599 c & " sigder",sigder
2600 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2601 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2603 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2604 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2607 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2609 c write (iout,*) "gg",(gg(k),k=1,3)
2611 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2612 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2613 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2614 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2615 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2616 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2617 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2618 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2619 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2620 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2623 C Calculate the components of the gradient in DC and X
2627 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2631 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2632 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2636 C-----------------------------------------------------------------------
2637 subroutine e_softsphere(evdw)
2639 C This subroutine calculates the interaction energy of nonbonded side chains
2640 C assuming the LJ potential of interaction.
2642 implicit real*8 (a-h,o-z)
2643 include 'DIMENSIONS'
2644 parameter (accur=1.0d-10)
2645 include 'COMMON.GEO'
2646 include 'COMMON.VAR'
2647 include 'COMMON.LOCAL'
2648 include 'COMMON.CHAIN'
2649 include 'COMMON.DERIV'
2650 include 'COMMON.INTERACT'
2651 include 'COMMON.TORSION'
2652 include 'COMMON.SBRIDGE'
2653 include 'COMMON.NAMES'
2654 include 'COMMON.IOUNITS'
2655 c include 'COMMON.CONTACTS'
2657 double precision boxshift
2658 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2660 c do i=iatsc_s,iatsc_e
2661 do ikont=g_listscsc_start,g_listscsc_end
2662 i=newcontlisti(ikont)
2663 j=newcontlistj(ikont)
2664 itypi=iabs(itype(i))
2665 if (itypi.eq.ntyp1) cycle
2666 itypi1=iabs(itype(i+1))
2670 call to_box(xi,yi,zi)
2672 C Calculate SC interaction energy.
2674 c do iint=1,nint_gr(i)
2675 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2676 cd & 'iend=',iend(i,iint)
2677 c do j=istart(i,iint),iend(i,iint)
2678 itypj=iabs(itype(j))
2679 if (itypj.eq.ntyp1) cycle
2680 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2681 yj=boxshift(c(2,nres+j)-yi,boxysize)
2682 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2683 rij=xj*xj+yj*yj+zj*zj
2684 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2685 r0ij=r0(itypi,itypj)
2687 c print *,i,j,r0ij,dsqrt(rij)
2688 if (rij.lt.r0ijsq) then
2689 evdwij=0.25d0*(rij-r0ijsq)**2
2697 C Calculate the components of the gradient in DC and X
2703 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2704 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2705 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2706 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2710 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2718 C--------------------------------------------------------------------------
2719 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2722 C Soft-sphere potential of p-p interaction
2724 implicit real*8 (a-h,o-z)
2725 include 'DIMENSIONS'
2726 include 'COMMON.CONTROL'
2727 include 'COMMON.IOUNITS'
2728 include 'COMMON.GEO'
2729 include 'COMMON.VAR'
2730 include 'COMMON.LOCAL'
2731 include 'COMMON.CHAIN'
2732 include 'COMMON.DERIV'
2733 include 'COMMON.INTERACT'
2734 c include 'COMMON.CONTACTS'
2735 include 'COMMON.TORSION'
2736 include 'COMMON.VECTORS'
2737 include 'COMMON.FFIELD'
2739 double precision boxshift
2740 C write(iout,*) 'In EELEC_soft_sphere'
2747 do i=iatel_s,iatel_e
2748 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2752 xmedi=c(1,i)+0.5d0*dxi
2753 ymedi=c(2,i)+0.5d0*dyi
2754 zmedi=c(3,i)+0.5d0*dzi
2755 call to_box(xmedi,ymedi,zmedi)
2757 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2758 do j=ielstart(i),ielend(i)
2759 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2763 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2764 r0ij=rpp(iteli,itelj)
2772 call to_box(xj,yj,zj)
2773 xj=boxshift(xj-xmedi,boxxsize)
2774 yj=boxshift(yj-ymedi,boxysize)
2775 zj=boxshift(zj-zmedi,boxzsize)
2776 rij=xj*xj+yj*yj+zj*zj
2777 sss=sscale(sqrt(rij),r_cut_int)
2778 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2779 if (rij.lt.r0ijsq) then
2780 evdw1ij=0.25d0*(rij-r0ijsq)**2
2786 evdw1=evdw1+evdw1ij*sss
2788 C Calculate contributions to the Cartesian gradient.
2790 ggg(1)=fac*xj*sssgrad
2791 ggg(2)=fac*yj*sssgrad
2792 ggg(3)=fac*zj*sssgrad
2794 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2795 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2798 * Loop over residues i+1 thru j-1.
2802 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2807 cgrad do i=nnt,nct-1
2809 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2811 cgrad do j=i+1,nct-1
2813 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2819 c------------------------------------------------------------------------------
2820 subroutine vec_and_deriv
2821 implicit real*8 (a-h,o-z)
2822 include 'DIMENSIONS'
2826 include 'COMMON.IOUNITS'
2827 include 'COMMON.GEO'
2828 include 'COMMON.VAR'
2829 include 'COMMON.LOCAL'
2830 include 'COMMON.CHAIN'
2831 include 'COMMON.VECTORS'
2832 include 'COMMON.SETUP'
2833 include 'COMMON.TIME1'
2834 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2835 C Compute the local reference systems. For reference system (i), the
2836 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2837 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2839 do i=ivec_start,ivec_end
2843 if (i.eq.nres-1) then
2844 C Case of the last full residue
2845 C Compute the Z-axis
2846 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2847 costh=dcos(pi-theta(nres))
2848 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2852 C Compute the derivatives of uz
2854 uzder(2,1,1)=-dc_norm(3,i-1)
2855 uzder(3,1,1)= dc_norm(2,i-1)
2856 uzder(1,2,1)= dc_norm(3,i-1)
2858 uzder(3,2,1)=-dc_norm(1,i-1)
2859 uzder(1,3,1)=-dc_norm(2,i-1)
2860 uzder(2,3,1)= dc_norm(1,i-1)
2863 uzder(2,1,2)= dc_norm(3,i)
2864 uzder(3,1,2)=-dc_norm(2,i)
2865 uzder(1,2,2)=-dc_norm(3,i)
2867 uzder(3,2,2)= dc_norm(1,i)
2868 uzder(1,3,2)= dc_norm(2,i)
2869 uzder(2,3,2)=-dc_norm(1,i)
2871 C Compute the Y-axis
2874 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2876 C Compute the derivatives of uy
2879 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2880 & -dc_norm(k,i)*dc_norm(j,i-1)
2881 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2883 uyder(j,j,1)=uyder(j,j,1)-costh
2884 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2889 uygrad(l,k,j,i)=uyder(l,k,j)
2890 uzgrad(l,k,j,i)=uzder(l,k,j)
2894 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2895 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2896 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2897 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2900 C Compute the Z-axis
2901 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2902 costh=dcos(pi-theta(i+2))
2903 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2907 C Compute the derivatives of uz
2909 uzder(2,1,1)=-dc_norm(3,i+1)
2910 uzder(3,1,1)= dc_norm(2,i+1)
2911 uzder(1,2,1)= dc_norm(3,i+1)
2913 uzder(3,2,1)=-dc_norm(1,i+1)
2914 uzder(1,3,1)=-dc_norm(2,i+1)
2915 uzder(2,3,1)= dc_norm(1,i+1)
2918 uzder(2,1,2)= dc_norm(3,i)
2919 uzder(3,1,2)=-dc_norm(2,i)
2920 uzder(1,2,2)=-dc_norm(3,i)
2922 uzder(3,2,2)= dc_norm(1,i)
2923 uzder(1,3,2)= dc_norm(2,i)
2924 uzder(2,3,2)=-dc_norm(1,i)
2926 C Compute the Y-axis
2929 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2931 C Compute the derivatives of uy
2934 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2935 & -dc_norm(k,i)*dc_norm(j,i+1)
2936 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2938 uyder(j,j,1)=uyder(j,j,1)-costh
2939 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2944 uygrad(l,k,j,i)=uyder(l,k,j)
2945 uzgrad(l,k,j,i)=uzder(l,k,j)
2949 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2950 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2951 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2952 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2956 vbld_inv_temp(1)=vbld_inv(i+1)
2957 if (i.lt.nres-1) then
2958 vbld_inv_temp(2)=vbld_inv(i+2)
2960 vbld_inv_temp(2)=vbld_inv(i)
2965 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2966 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2971 #if defined(PARVEC) && defined(MPI)
2972 if (nfgtasks1.gt.1) then
2974 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2975 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2976 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2977 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2978 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2980 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2981 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2983 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2984 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2985 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2986 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2987 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2988 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2989 time_gather=time_gather+MPI_Wtime()-time00
2993 if (fg_rank.eq.0) then
2994 write (iout,*) "Arrays UY and UZ"
2996 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
3003 C--------------------------------------------------------------------------
3004 subroutine set_matrices
3005 implicit real*8 (a-h,o-z)
3006 include 'DIMENSIONS'
3009 include "COMMON.SETUP"
3011 integer status(MPI_STATUS_SIZE)
3013 include 'COMMON.IOUNITS'
3014 include 'COMMON.GEO'
3015 include 'COMMON.VAR'
3016 include 'COMMON.LOCAL'
3017 include 'COMMON.CHAIN'
3018 include 'COMMON.DERIV'
3019 include 'COMMON.INTERACT'
3020 include 'COMMON.CORRMAT'
3021 include 'COMMON.TORSION'
3022 include 'COMMON.VECTORS'
3023 include 'COMMON.FFIELD'
3024 double precision auxvec(2),auxmat(2,2)
3026 C Compute the virtual-bond-torsional-angle dependent quantities needed
3027 C to calculate the el-loc multibody terms of various order.
3029 c write(iout,*) 'nphi=',nphi,nres
3030 c write(iout,*) "itype2loc",itype2loc
3032 do i=ivec_start+2,ivec_end+2
3037 c write (iout,*) "i",i,i-2," ii",ii
3039 innt=chain_border(1,ii)
3040 inct=chain_border(2,ii)
3041 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3042 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3043 if (i.gt. innt+2 .and. i.lt.inct+2) then
3044 iti = itype2loc(itype(i-2))
3048 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3049 if (i.gt. innt+1 .and. i.lt.inct+1) then
3050 iti1 = itype2loc(itype(i-1))
3054 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3055 c & " iti1",itype(i-1),iti1
3057 cost1=dcos(theta(i-1))
3058 sint1=dsin(theta(i-1))
3060 sint1cub=sint1sq*sint1
3061 sint1cost1=2*sint1*cost1
3062 c write (iout,*) "bnew1",i,iti
3063 c write (iout,*) (bnew1(k,1,iti),k=1,3)
3064 c write (iout,*) (bnew1(k,2,iti),k=1,3)
3065 c write (iout,*) "bnew2",i,iti
3066 c write (iout,*) (bnew2(k,1,iti),k=1,3)
3067 c write (iout,*) (bnew2(k,2,iti),k=1,3)
3069 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3071 gtb1(k,i-2)=cost1*b1k-sint1sq*
3072 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3073 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3075 gtb2(k,i-2)=cost1*b2k-sint1sq*
3076 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3079 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3080 cc(1,k,i-2)=sint1sq*aux
3081 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3082 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3083 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3084 dd(1,k,i-2)=sint1sq*aux
3085 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3086 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3088 cc(2,1,i-2)=cc(1,2,i-2)
3089 cc(2,2,i-2)=-cc(1,1,i-2)
3090 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3091 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3092 dd(2,1,i-2)=dd(1,2,i-2)
3093 dd(2,2,i-2)=-dd(1,1,i-2)
3094 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3095 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3098 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3099 EE(l,k,i-2)=sint1sq*aux
3100 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3103 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3104 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3105 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3106 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3107 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3108 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3109 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3110 c b1tilde(1,i-2)=b1(1,i-2)
3111 c b1tilde(2,i-2)=-b1(2,i-2)
3112 c b2tilde(1,i-2)=b2(1,i-2)
3113 c b2tilde(2,i-2)=-b2(2,i-2)
3115 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3116 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3117 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3118 write (iout,*) 'theta=', theta(i-1)
3121 if (i.gt. innt+2 .and. i.lt.inct+2) then
3122 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3123 iti = itype2loc(itype(i-2))
3127 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3128 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3129 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3130 iti1 = itype2loc(itype(i-1))
3140 CC(k,l,i-2)=ccold(k,l,iti)
3141 DD(k,l,i-2)=ddold(k,l,iti)
3142 EE(k,l,i-2)=eeold(k,l,iti)
3147 b1tilde(1,i-2)= b1(1,i-2)
3148 b1tilde(2,i-2)=-b1(2,i-2)
3149 b2tilde(1,i-2)= b2(1,i-2)
3150 b2tilde(2,i-2)=-b2(2,i-2)
3152 Ctilde(1,1,i-2)= CC(1,1,i-2)
3153 Ctilde(1,2,i-2)= CC(1,2,i-2)
3154 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3155 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3157 Dtilde(1,1,i-2)= DD(1,1,i-2)
3158 Dtilde(1,2,i-2)= DD(1,2,i-2)
3159 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3160 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3162 write(iout,*) "i",i," iti",iti
3163 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3164 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3169 do i=ivec_start+2,ivec_end+2
3173 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3174 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3212 obrot_der(1,i-2)=-sin1
3213 obrot_der(2,i-2)= cos1
3214 Ugder(1,1,i-2)= sin1
3215 Ugder(1,2,i-2)=-cos1
3216 Ugder(2,1,i-2)=-cos1
3217 Ugder(2,2,i-2)=-sin1
3220 obrot2_der(1,i-2)=-dwasin2
3221 obrot2_der(2,i-2)= dwacos2
3222 Ug2der(1,1,i-2)= dwasin2
3223 Ug2der(1,2,i-2)=-dwacos2
3224 Ug2der(2,1,i-2)=-dwacos2
3225 Ug2der(2,2,i-2)=-dwasin2
3227 obrot_der(1,i-2)=0.0d0
3228 obrot_der(2,i-2)=0.0d0
3229 Ugder(1,1,i-2)=0.0d0
3230 Ugder(1,2,i-2)=0.0d0
3231 Ugder(2,1,i-2)=0.0d0
3232 Ugder(2,2,i-2)=0.0d0
3233 obrot2_der(1,i-2)=0.0d0
3234 obrot2_der(2,i-2)=0.0d0
3235 Ug2der(1,1,i-2)=0.0d0
3236 Ug2der(1,2,i-2)=0.0d0
3237 Ug2der(2,1,i-2)=0.0d0
3238 Ug2der(2,2,i-2)=0.0d0
3240 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3241 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3242 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3243 iti = itype2loc(itype(i-2))
3247 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3248 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3249 iti1 = itype2loc(itype(i-1))
3253 cd write (iout,*) '*******i',i,' iti1',iti
3254 cd write (iout,*) 'b1',b1(:,iti)
3255 cd write (iout,*) 'b2',b2(:,iti)
3256 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3257 c if (i .gt. iatel_s+2) then
3258 if (i .gt. nnt+2) then
3259 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3261 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3262 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3264 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3265 c & EE(1,2,iti),EE(2,2,i)
3266 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3267 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3268 c write(iout,*) "Macierz EUG",
3269 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3272 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3274 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3275 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3276 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3277 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3278 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3290 DtUg2(l,k,i-2)=0.0d0
3294 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3295 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3297 muder(k,i-2)=Ub2der(k,i-2)
3299 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3300 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3301 if (itype(i-1).le.ntyp) then
3302 iti1 = itype2loc(itype(i-1))
3310 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3311 c mu(k,i-2)=b1(k,i-1)
3312 c mu(k,i-2)=Ub2(k,i-2)
3315 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3316 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3317 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3318 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3319 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3320 & ((ee(l,k,i-2),l=1,2),k=1,2)
3322 cd write (iout,*) 'mu1',mu1(:,i-2)
3323 cd write (iout,*) 'mu2',mu2(:,i-2)
3324 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3326 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3328 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3329 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3330 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3331 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3332 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3333 C Vectors and matrices dependent on a single virtual-bond dihedral.
3334 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3335 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3336 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3337 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3338 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3339 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3340 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3341 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3342 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3347 C Matrices dependent on two consecutive virtual-bond dihedrals.
3348 C The order of matrices is from left to right.
3349 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3351 c do i=max0(ivec_start,2),ivec_end
3353 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3354 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3355 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3356 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3357 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3358 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3359 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3360 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3364 #if defined(MPI) && defined(PARMAT)
3366 c if (fg_rank.eq.0) then
3367 write (iout,*) "Arrays UG and UGDER before GATHER"
3369 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3370 & ((ug(l,k,i),l=1,2),k=1,2),
3371 & ((ugder(l,k,i),l=1,2),k=1,2)
3373 write (iout,*) "Arrays UG2 and UG2DER"
3375 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376 & ((ug2(l,k,i),l=1,2),k=1,2),
3377 & ((ug2der(l,k,i),l=1,2),k=1,2)
3379 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3381 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3382 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3383 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3385 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3387 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3388 & costab(i),sintab(i),costab2(i),sintab2(i)
3390 write (iout,*) "Array MUDER"
3392 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3396 if (nfgtasks.gt.1) then
3398 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3399 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3400 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3402 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3403 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3405 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3406 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3408 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3409 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3411 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3412 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3414 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3415 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3417 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3418 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3420 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3421 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3422 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3423 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3424 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3425 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3426 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3427 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3428 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3429 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3430 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3431 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3433 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3435 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3436 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3438 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3439 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3441 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3442 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3444 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3445 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3447 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3448 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3450 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3451 & ivec_count(fg_rank1),
3452 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3454 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3455 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3457 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3458 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3460 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3461 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3463 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3464 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3466 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3467 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3469 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3470 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3472 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3473 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3475 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3476 & ivec_count(fg_rank1),
3477 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3479 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3480 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3482 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3483 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3485 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3486 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3488 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3489 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3491 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3492 & ivec_count(fg_rank1),
3493 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3495 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3496 & ivec_count(fg_rank1),
3497 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3499 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3500 & ivec_count(fg_rank1),
3501 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3502 & MPI_MAT2,FG_COMM1,IERR)
3503 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3504 & ivec_count(fg_rank1),
3505 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3506 & MPI_MAT2,FG_COMM1,IERR)
3510 c Passes matrix info through the ring
3513 if (irecv.lt.0) irecv=nfgtasks1-1
3516 if (inext.ge.nfgtasks1) inext=0
3518 c write (iout,*) "isend",isend," irecv",irecv
3520 lensend=lentyp(isend)
3521 lenrecv=lentyp(irecv)
3522 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3523 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3524 c & MPI_ROTAT1(lensend),inext,2200+isend,
3525 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3526 c & iprev,2200+irecv,FG_COMM,status,IERR)
3527 c write (iout,*) "Gather ROTAT1"
3529 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3530 c & MPI_ROTAT2(lensend),inext,3300+isend,
3531 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3532 c & iprev,3300+irecv,FG_COMM,status,IERR)
3533 c write (iout,*) "Gather ROTAT2"
3535 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3536 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3537 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3538 & iprev,4400+irecv,FG_COMM,status,IERR)
3539 c write (iout,*) "Gather ROTAT_OLD"
3541 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3542 & MPI_PRECOMP11(lensend),inext,5500+isend,
3543 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3544 & iprev,5500+irecv,FG_COMM,status,IERR)
3545 c write (iout,*) "Gather PRECOMP11"
3547 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3548 & MPI_PRECOMP12(lensend),inext,6600+isend,
3549 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3550 & iprev,6600+irecv,FG_COMM,status,IERR)
3551 c write (iout,*) "Gather PRECOMP12"
3554 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3556 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3557 & MPI_ROTAT2(lensend),inext,7700+isend,
3558 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3559 & iprev,7700+irecv,FG_COMM,status,IERR)
3560 c write (iout,*) "Gather PRECOMP21"
3562 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3563 & MPI_PRECOMP22(lensend),inext,8800+isend,
3564 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3565 & iprev,8800+irecv,FG_COMM,status,IERR)
3566 c write (iout,*) "Gather PRECOMP22"
3568 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3569 & MPI_PRECOMP23(lensend),inext,9900+isend,
3570 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3571 & MPI_PRECOMP23(lenrecv),
3572 & iprev,9900+irecv,FG_COMM,status,IERR)
3574 c write (iout,*) "Gather PRECOMP23"
3579 if (irecv.lt.0) irecv=nfgtasks1-1
3582 time_gather=time_gather+MPI_Wtime()-time00
3585 c if (fg_rank.eq.0) then
3586 write (iout,*) "Arrays UG and UGDER"
3588 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3589 & ((ug(l,k,i),l=1,2),k=1,2),
3590 & ((ugder(l,k,i),l=1,2),k=1,2)
3592 write (iout,*) "Arrays UG2 and UG2DER"
3594 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3595 & ((ug2(l,k,i),l=1,2),k=1,2),
3596 & ((ug2der(l,k,i),l=1,2),k=1,2)
3598 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3600 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3601 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3602 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3604 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3606 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3607 & costab(i),sintab(i),costab2(i),sintab2(i)
3609 write (iout,*) "Array MUDER"
3611 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3617 cd iti = itype2loc(itype(i))
3620 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3621 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3626 C-----------------------------------------------------------------------------
3627 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3629 C This subroutine calculates the average interaction energy and its gradient
3630 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3631 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3632 C The potential depends both on the distance of peptide-group centers and on
3633 C the orientation of the CA-CA virtual bonds.
3635 implicit real*8 (a-h,o-z)
3639 include 'DIMENSIONS'
3640 include 'COMMON.CONTROL'
3641 include 'COMMON.SETUP'
3642 include 'COMMON.IOUNITS'
3643 include 'COMMON.GEO'
3644 include 'COMMON.VAR'
3645 include 'COMMON.LOCAL'
3646 include 'COMMON.CHAIN'
3647 include 'COMMON.DERIV'
3648 include 'COMMON.INTERACT'
3650 include 'COMMON.CONTACTS'
3651 include 'COMMON.CONTMAT'
3653 include 'COMMON.CORRMAT'
3654 include 'COMMON.TORSION'
3655 include 'COMMON.VECTORS'
3656 include 'COMMON.FFIELD'
3657 include 'COMMON.TIME1'
3658 include 'COMMON.SPLITELE'
3659 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3660 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3661 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3662 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3663 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3664 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3666 double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3667 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3668 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3670 double precision scal_el /1.0d0/
3672 double precision scal_el /0.5d0/
3675 C 13-go grudnia roku pamietnego...
3676 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3677 & 0.0d0,1.0d0,0.0d0,
3678 & 0.0d0,0.0d0,1.0d0/
3679 cd write(iout,*) 'In EELEC'
3681 cd write(iout,*) 'Type',i
3682 cd write(iout,*) 'B1',B1(:,i)
3683 cd write(iout,*) 'B2',B2(:,i)
3684 cd write(iout,*) 'CC',CC(:,:,i)
3685 cd write(iout,*) 'DD',DD(:,:,i)
3686 cd write(iout,*) 'EE',EE(:,:,i)
3688 cd call check_vecgrad
3690 if (icheckgrad.eq.1) then
3692 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3694 dc_norm(k,i)=dc(k,i)*fac
3696 c write (iout,*) 'i',i,' fac',fac
3699 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3700 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3701 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3702 c call vec_and_deriv
3708 time_mat=time_mat+MPI_Wtime()-time01
3712 cd write (iout,*) 'i=',i
3714 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3717 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3718 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3733 cd print '(a)','Enter EELEC'
3734 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3736 gel_loc_loc(i)=0.0d0
3741 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3743 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3745 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3746 do i=iturn3_start,iturn3_end
3748 C write(iout,*) "tu jest i",i
3749 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3750 C changes suggested by Ana to avoid out of bounds
3751 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3752 c & .or.((i+4).gt.nres)
3753 c & .or.((i-1).le.0)
3754 C end of changes by Ana
3755 & .or. itype(i+2).eq.ntyp1
3756 & .or. itype(i+3).eq.ntyp1) cycle
3757 C Adam: Instructions below will switch off existing interactions
3759 c if(itype(i-1).eq.ntyp1)cycle
3761 c if(i.LT.nres-3)then
3762 c if (itype(i+4).eq.ntyp1) cycle
3767 dx_normi=dc_norm(1,i)
3768 dy_normi=dc_norm(2,i)
3769 dz_normi=dc_norm(3,i)
3770 xmedi=c(1,i)+0.5d0*dxi
3771 ymedi=c(2,i)+0.5d0*dyi
3772 zmedi=c(3,i)+0.5d0*dzi
3773 call to_box(xmedi,ymedi,zmedi)
3774 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3776 call eelecij(i,i+2,ees,evdw1,eel_loc)
3777 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3779 num_cont_hb(i)=num_conti
3782 do i=iturn4_start,iturn4_end
3784 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3785 C changes suggested by Ana to avoid out of bounds
3786 c & .or.((i+5).gt.nres)
3787 c & .or.((i-1).le.0)
3788 C end of changes suggested by Ana
3789 & .or. itype(i+3).eq.ntyp1
3790 & .or. itype(i+4).eq.ntyp1
3791 c & .or. itype(i+5).eq.ntyp1
3792 c & .or. itype(i).eq.ntyp1
3793 c & .or. itype(i-1).eq.ntyp1
3798 dx_normi=dc_norm(1,i)
3799 dy_normi=dc_norm(2,i)
3800 dz_normi=dc_norm(3,i)
3801 xmedi=c(1,i)+0.5d0*dxi
3802 ymedi=c(2,i)+0.5d0*dyi
3803 zmedi=c(3,i)+0.5d0*dzi
3804 C Return atom into box, boxxsize is size of box in x dimension
3806 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3807 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3808 C Condition for being inside the proper box
3809 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3810 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3814 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3815 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3816 C Condition for being inside the proper box
3817 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3818 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3822 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3823 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3824 C Condition for being inside the proper box
3825 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3826 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3829 call to_box(xmedi,ymedi,zmedi)
3830 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3832 num_conti=num_cont_hb(i)
3834 c write(iout,*) "JESTEM W PETLI"
3835 call eelecij(i,i+3,ees,evdw1,eel_loc)
3836 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3837 & call eturn4(i,eello_turn4)
3839 num_cont_hb(i)=num_conti
3842 C Loop over all neighbouring boxes
3847 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3850 c do i=iatel_s,iatel_e
3851 do ikont=g_listpp_start,g_listpp_end
3852 i=newcontlistppi(ikont)
3853 j=newcontlistppj(ikont)
3856 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3857 C changes suggested by Ana to avoid out of bounds
3858 c & .or.((i+2).gt.nres)
3859 c & .or.((i-1).le.0)
3860 C end of changes by Ana
3861 c & .or. itype(i+2).eq.ntyp1
3862 c & .or. itype(i-1).eq.ntyp1
3867 dx_normi=dc_norm(1,i)
3868 dy_normi=dc_norm(2,i)
3869 dz_normi=dc_norm(3,i)
3870 xmedi=c(1,i)+0.5d0*dxi
3871 ymedi=c(2,i)+0.5d0*dyi
3872 zmedi=c(3,i)+0.5d0*dzi
3873 call to_box(xmedi,ymedi,zmedi)
3874 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3875 C xmedi=xmedi+xshift*boxxsize
3876 C ymedi=ymedi+yshift*boxysize
3877 C zmedi=zmedi+zshift*boxzsize
3879 C Return tom into box, boxxsize is size of box in x dimension
3881 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3882 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3883 C Condition for being inside the proper box
3884 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3885 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3889 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3890 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3891 C Condition for being inside the proper box
3892 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3893 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3897 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3898 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3899 cC Condition for being inside the proper box
3900 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3901 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3905 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3907 num_conti=num_cont_hb(i)
3910 c do j=ielstart(i),ielend(i)
3912 C write (iout,*) i,j
3914 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3915 C changes suggested by Ana to avoid out of bounds
3916 c & .or.((j+2).gt.nres)
3917 c & .or.((j-1).le.0)
3918 C end of changes by Ana
3919 c & .or.itype(j+2).eq.ntyp1
3920 c & .or.itype(j-1).eq.ntyp1
3922 call eelecij(i,j,ees,evdw1,eel_loc)
3925 num_cont_hb(i)=num_conti
3932 c write (iout,*) "Number of loop steps in EELEC:",ind
3934 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3935 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3937 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3938 ccc eel_loc=eel_loc+eello_turn3
3939 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3942 C-------------------------------------------------------------------------------
3943 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3945 include 'DIMENSIONS'
3949 include 'COMMON.CONTROL'
3950 include 'COMMON.IOUNITS'
3951 include 'COMMON.GEO'
3952 include 'COMMON.VAR'
3953 include 'COMMON.LOCAL'
3954 include 'COMMON.CHAIN'
3955 include 'COMMON.DERIV'
3956 include 'COMMON.INTERACT'
3958 include 'COMMON.CONTACTS'
3959 include 'COMMON.CONTMAT'
3961 include 'COMMON.CORRMAT'
3962 include 'COMMON.TORSION'
3963 include 'COMMON.VECTORS'
3964 include 'COMMON.FFIELD'
3965 include 'COMMON.TIME1'
3966 include 'COMMON.SPLITELE'
3967 include 'COMMON.SHIELD'
3968 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3969 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3970 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3971 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3972 & gmuij2(4),gmuji2(4)
3973 double precision dxi,dyi,dzi
3974 double precision dx_normi,dy_normi,dz_normi,aux
3975 integer j1,j2,lll,num_conti
3976 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3977 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3979 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3980 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3981 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3982 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3983 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3984 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3985 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3986 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3987 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3988 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3989 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3990 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3991 double precision xmedi,ymedi,zmedi
3992 double precision sscale,sscagrad,scalar
3993 double precision boxshift
3994 double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3996 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3997 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3999 double precision scal_el /1.0d0/
4001 double precision scal_el /0.5d0/
4004 C 13-go grudnia roku pamietnego...
4005 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4006 & 0.0d0,1.0d0,0.0d0,
4007 & 0.0d0,0.0d0,1.0d0/
4008 c time00=MPI_Wtime()
4009 cd write (iout,*) "eelecij",i,j
4011 c write (iout,*) "lipscale",lipscale
4014 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4015 aaa=app(iteli,itelj)
4016 bbb=bpp(iteli,itelj)
4017 ael6i=ael6(iteli,itelj)
4018 ael3i=ael3(iteli,itelj)
4022 dx_normj=dc_norm(1,j)
4023 dy_normj=dc_norm(2,j)
4024 dz_normj=dc_norm(3,j)
4025 C xj=c(1,j)+0.5D0*dxj-xmedi
4026 C yj=c(2,j)+0.5D0*dyj-ymedi
4027 C zj=c(3,j)+0.5D0*dzj-zmedi
4031 call to_box(xj,yj,zj)
4032 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4033 faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
4034 faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4035 xj=boxshift(xj-xmedi,boxxsize)
4036 yj=boxshift(yj-ymedi,boxysize)
4037 zj=boxshift(zj-zmedi,boxzsize)
4038 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4040 rij=xj*xj+yj*yj+zj*zj
4042 sss=sscale(dsqrt(rij),r_cut_int)
4043 if (sss.eq.0.0d0) return
4044 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4045 c if (sss.gt.0.0d0) then
4051 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4052 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4053 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4054 fac=cosa-3.0D0*cosb*cosg
4056 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4057 if (j.eq.i+2) ev1=scal_el*ev1
4062 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4066 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4067 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4068 if (shield_mode.gt.0) then
4071 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4072 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4074 ees=ees+eesij*sss*faclipij2
4079 ees=ees+eesij*sss*faclipij2
4082 evdw1=evdw1+evdwij*sss*faclipij2
4083 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4084 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4085 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4086 cd & xmedi,ymedi,zmedi,xj,yj,zj
4088 if (energy_dec) then
4089 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4090 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4091 write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
4092 & fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
4097 C Calculate contributions to the Cartesian gradient.
4100 facvdw=-6*rrmij*(ev1+evdwij)*sss
4101 facel=-3*rrmij*(el1+eesij)
4108 * Radial derivatives. First process both termini of the fragment (i,j)
4110 aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
4114 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4115 & (shield_mode.gt.0)) then
4117 do ilist=1,ishield_list(i)
4118 iresshield=shield_list(ilist,i)
4120 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4122 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4124 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4125 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4126 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4127 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4128 C if (iresshield.gt.i) then
4129 C do ishi=i+1,iresshield-1
4130 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4131 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4135 C do ishi=iresshield,i
4136 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4137 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4143 do ilist=1,ishield_list(j)
4144 iresshield=shield_list(ilist,j)
4146 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4148 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4150 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4151 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4153 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4154 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4155 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4156 C if (iresshield.gt.j) then
4157 C do ishi=j+1,iresshield-1
4158 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4159 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4163 C do ishi=iresshield,j
4164 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4165 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4172 gshieldc(k,i)=gshieldc(k,i)+
4173 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4174 gshieldc(k,j)=gshieldc(k,j)+
4175 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4176 gshieldc(k,i-1)=gshieldc(k,i-1)+
4177 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4178 gshieldc(k,j-1)=gshieldc(k,j-1)+
4179 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4184 c ghalf=0.5D0*ggg(k)
4185 c gelc(k,i)=gelc(k,i)+ghalf
4186 c gelc(k,j)=gelc(k,j)+ghalf
4188 c 9/28/08 AL Gradient compotents will be summed only at the end
4189 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4191 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4192 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4194 gelc_long(3,j)=gelc_long(3,j)+
4195 & ssgradlipj*eesij/2.0d0*lipscale**2*sss
4197 gelc_long(3,i)=gelc_long(3,i)+
4198 & ssgradlipi*eesij/2.0d0*lipscale**2*sss
4202 * Loop over residues i+1 thru j-1.
4206 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4209 facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4214 c ghalf=0.5D0*ggg(k)
4215 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4216 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4218 c 9/28/08 AL Gradient compotents will be summed only at the end
4220 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4221 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4223 !C Lipidic part for scaling weight
4224 gvdwpp(3,j)=gvdwpp(3,j)+
4225 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4226 gvdwpp(3,i)=gvdwpp(3,i)+
4227 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4229 * Loop over residues i+1 thru j-1.
4233 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4238 facvdw=(ev1+evdwij)*faclipij2
4241 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4242 & +(evdwij+eesij)*sssgrad*rrmij
4247 * Radial derivatives. First process both termini of the fragment (i,j)
4250 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4252 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4254 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4256 c ghalf=0.5D0*ggg(k)
4257 c gelc(k,i)=gelc(k,i)+ghalf
4258 c gelc(k,j)=gelc(k,j)+ghalf
4260 c 9/28/08 AL Gradient compotents will be summed only at the end
4262 gelc_long(k,j)=gelc(k,j)+ggg(k)
4263 gelc_long(k,i)=gelc(k,i)-ggg(k)
4266 * Loop over residues i+1 thru j-1.
4270 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4273 c 9/28/08 AL Gradient compotents will be summed only at the end
4274 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4275 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4276 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4278 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4279 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4281 gvdwpp(3,j)=gvdwpp(3,j)+
4282 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4283 gvdwpp(3,i)=gvdwpp(3,i)+
4284 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4289 ecosa=2.0D0*fac3*fac1+fac4
4292 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4293 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4295 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4296 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4298 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4299 cd & (dcosg(k),k=1,3)
4301 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4302 & fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4305 c ghalf=0.5D0*ggg(k)
4306 c gelc(k,i)=gelc(k,i)+ghalf
4307 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4308 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4309 c gelc(k,j)=gelc(k,j)+ghalf
4310 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4315 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4318 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4321 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4322 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4323 & *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4325 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4326 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4327 & *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4328 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4329 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4331 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4335 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4336 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4337 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4339 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4340 C energy of a peptide unit is assumed in the form of a second-order
4341 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4342 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4343 C are computed for EVERY pair of non-contiguous peptide groups.
4346 if (j.lt.nres-1) then
4358 muij(kkk)=mu(k,i)*mu(l,j)
4359 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4361 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4362 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4363 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4364 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4365 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4366 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4371 write (iout,*) 'EELEC: i',i,' j',j
4372 write (iout,*) 'j',j,' j1',j1,' j2',j2
4373 write(iout,*) 'muij',muij
4375 ury=scalar(uy(1,i),erij)
4376 urz=scalar(uz(1,i),erij)
4377 vry=scalar(uy(1,j),erij)
4378 vrz=scalar(uz(1,j),erij)
4379 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4380 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4381 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4382 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4383 fac=dsqrt(-ael6i)*r3ij
4385 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4386 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4387 & "uyvz",scalar(uy(1,i),uz(1,j)),
4388 & "uzvy",scalar(uz(1,i),uy(1,j)),
4389 & "uzvz",scalar(uz(1,i),uz(1,j))
4390 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4391 write (iout,*) "fac",fac
4398 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4401 cd write (iout,'(4i5,4f10.5)')
4402 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4403 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4404 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4405 cd & uy(:,j),uz(:,j)
4406 cd write (iout,'(4f10.5)')
4407 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4408 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4409 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4410 cd write (iout,'(9f10.5/)')
4411 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4412 C Derivatives of the elements of A in virtual-bond vectors
4413 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4415 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4416 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4417 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4418 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4419 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4420 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4421 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4422 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4423 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4424 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4425 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4426 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4428 C Compute radial contributions to the gradient
4446 C Add the contributions coming from er
4449 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4450 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4451 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4452 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4455 C Derivatives in DC(i)
4456 cgrad ghalf1=0.5d0*agg(k,1)
4457 cgrad ghalf2=0.5d0*agg(k,2)
4458 cgrad ghalf3=0.5d0*agg(k,3)
4459 cgrad ghalf4=0.5d0*agg(k,4)
4460 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4461 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4462 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4463 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4464 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4465 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4466 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4467 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4468 C Derivatives in DC(i+1)
4469 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4470 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4471 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4472 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4473 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4474 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4475 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4476 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4477 C Derivatives in DC(j)
4478 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4479 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4480 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4481 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4482 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4483 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4484 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4485 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4486 C Derivatives in DC(j+1) or DC(nres-1)
4487 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4488 & -3.0d0*vryg(k,3)*ury)
4489 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4490 & -3.0d0*vrzg(k,3)*ury)
4491 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4492 & -3.0d0*vryg(k,3)*urz)
4493 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4494 & -3.0d0*vrzg(k,3)*urz)
4495 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4497 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4510 aggi(k,l)=-aggi(k,l)
4511 aggi1(k,l)=-aggi1(k,l)
4512 aggj(k,l)=-aggj(k,l)
4513 aggj1(k,l)=-aggj1(k,l)
4516 if (j.lt.nres-1) then
4522 aggi(k,l)=-aggi(k,l)
4523 aggi1(k,l)=-aggi1(k,l)
4524 aggj(k,l)=-aggj(k,l)
4525 aggj1(k,l)=-aggj1(k,l)
4536 aggi(k,l)=-aggi(k,l)
4537 aggi1(k,l)=-aggi1(k,l)
4538 aggj(k,l)=-aggj(k,l)
4539 aggj1(k,l)=-aggj1(k,l)
4544 IF (wel_loc.gt.0.0d0) THEN
4545 C Contribution to the local-electrostatic energy coming from the i-j pair
4546 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4549 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4551 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4552 & " wel_loc",wel_loc
4554 if (shield_mode.eq.0) then
4561 eel_loc_ij=eel_loc_ij
4562 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4563 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4564 c & 'eelloc',i,j,eel_loc_ij
4565 C Now derivative over eel_loc
4566 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4567 & (shield_mode.gt.0)) then
4570 do ilist=1,ishield_list(i)
4571 iresshield=shield_list(ilist,i)
4573 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4576 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4578 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4579 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4583 do ilist=1,ishield_list(j)
4584 iresshield=shield_list(ilist,j)
4586 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4589 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4591 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4592 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4599 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4600 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4601 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4602 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4603 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4604 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4605 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4606 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4611 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4612 c & ' eel_loc_ij',eel_loc_ij
4613 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4614 C Calculate patrial derivative for theta angle
4616 geel_loc_ij=(a22*gmuij1(1)
4620 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4621 c write(iout,*) "derivative over thatai"
4622 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4624 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4625 & geel_loc_ij*wel_loc
4626 c write(iout,*) "derivative over thatai-1"
4627 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4634 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4635 & geel_loc_ij*wel_loc
4636 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4638 c Derivative over j residue
4639 geel_loc_ji=a22*gmuji1(1)
4643 c write(iout,*) "derivative over thataj"
4644 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4647 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4648 & geel_loc_ji*wel_loc
4649 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4656 c write(iout,*) "derivative over thataj-1"
4657 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4659 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4660 & geel_loc_ji*wel_loc
4661 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4663 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4665 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4666 & 'eelloc',i,j,eel_loc_ij
4667 c if (eel_loc_ij.ne.0)
4668 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4669 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4671 eel_loc=eel_loc+eel_loc_ij
4672 C Partial derivatives in virtual-bond dihedral angles gamma
4674 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4675 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4676 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4677 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4679 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4680 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4681 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4682 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4683 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4684 aux=eel_loc_ij/sss*sssgrad*rmij
4689 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4690 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4691 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4692 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4693 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4694 cgrad ghalf=0.5d0*ggg(l)
4695 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4696 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4698 gel_loc_long(3,j)=gel_loc_long(3,j)+
4699 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4701 gel_loc_long(3,i)=gel_loc_long(3,i)+
4702 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4706 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4709 C Remaining derivatives of eello
4711 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4712 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4713 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4715 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4716 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4717 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4719 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4720 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4721 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4723 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4724 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4725 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4729 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4730 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4732 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4733 & .and. num_conti.le.maxconts) then
4734 c write (iout,*) i,j," entered corr"
4736 C Calculate the contact function. The ith column of the array JCONT will
4737 C contain the numbers of atoms that make contacts with the atom I (of numbers
4738 C greater than I). The arrays FACONT and GACONT will contain the values of
4739 C the contact function and its derivative.
4740 c r0ij=1.02D0*rpp(iteli,itelj)
4741 c r0ij=1.11D0*rpp(iteli,itelj)
4742 r0ij=2.20D0*rpp(iteli,itelj)
4743 c r0ij=1.55D0*rpp(iteli,itelj)
4744 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4745 if (fcont.gt.0.0D0) then
4746 num_conti=num_conti+1
4747 if (num_conti.gt.maxconts) then
4748 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4749 & ' will skip next contacts for this conf.'
4751 jcont_hb(num_conti,i)=j
4752 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4753 cd & " jcont_hb",jcont_hb(num_conti,i)
4754 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4755 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4756 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4758 d_cont(num_conti,i)=rij
4759 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4760 C --- Electrostatic-interaction matrix ---
4761 a_chuj(1,1,num_conti,i)=a22
4762 a_chuj(1,2,num_conti,i)=a23
4763 a_chuj(2,1,num_conti,i)=a32
4764 a_chuj(2,2,num_conti,i)=a33
4765 C --- Gradient of rij
4767 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4774 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4775 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4776 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4777 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4778 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4783 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4784 C Calculate contact energies
4786 wij=cosa-3.0D0*cosb*cosg
4789 c fac3=dsqrt(-ael6i)/r0ij**3
4790 fac3=dsqrt(-ael6i)*r3ij
4791 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4792 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4793 if (ees0tmp.gt.0) then
4794 ees0pij=dsqrt(ees0tmp)
4798 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4799 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4800 if (ees0tmp.gt.0) then
4801 ees0mij=dsqrt(ees0tmp)
4806 if (shield_mode.eq.0) then
4810 ees0plist(num_conti,i)=j
4811 C fac_shield(i)=0.4d0
4812 C fac_shield(j)=0.6d0
4814 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4815 & *fac_shield(i)*fac_shield(j)*sss
4816 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4817 & *fac_shield(i)*fac_shield(j)*sss
4818 C Diagnostics. Comment out or remove after debugging!
4819 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4820 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4821 c ees0m(num_conti,i)=0.0D0
4823 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4824 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4825 C Angular derivatives of the contact function
4826 ees0pij1=fac3/ees0pij
4827 ees0mij1=fac3/ees0mij
4828 fac3p=-3.0D0*fac3*rrmij
4829 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4830 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4832 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4833 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4834 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4835 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4836 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4837 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4838 ecosap=ecosa1+ecosa2
4839 ecosbp=ecosb1+ecosb2
4840 ecosgp=ecosg1+ecosg2
4841 ecosam=ecosa1-ecosa2
4842 ecosbm=ecosb1-ecosb2
4843 ecosgm=ecosg1-ecosg2
4852 facont_hb(num_conti,i)=fcont
4853 fprimcont=fprimcont/rij
4854 cd facont_hb(num_conti,i)=1.0D0
4855 C Following line is for diagnostics.
4858 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4859 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4862 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4863 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4865 gggp(1)=gggp(1)+ees0pijp*xj
4866 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4867 gggp(2)=gggp(2)+ees0pijp*yj
4868 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4869 gggp(3)=gggp(3)+ees0pijp*zj
4870 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4871 gggm(1)=gggm(1)+ees0mijp*xj
4872 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4873 gggm(2)=gggm(2)+ees0mijp*yj
4874 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4875 gggm(3)=gggm(3)+ees0mijp*zj
4876 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4877 C Derivatives due to the contact function
4878 gacont_hbr(1,num_conti,i)=fprimcont*xj
4879 gacont_hbr(2,num_conti,i)=fprimcont*yj
4880 gacont_hbr(3,num_conti,i)=fprimcont*zj
4883 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4884 c following the change of gradient-summation algorithm.
4886 cgrad ghalfp=0.5D0*gggp(k)
4887 cgrad ghalfm=0.5D0*gggm(k)
4888 gacontp_hb1(k,num_conti,i)=!ghalfp
4889 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4890 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4891 & *fac_shield(i)*fac_shield(j)*sss
4893 gacontp_hb2(k,num_conti,i)=!ghalfp
4894 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4895 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4896 & *fac_shield(i)*fac_shield(j)*sss
4898 gacontp_hb3(k,num_conti,i)=gggp(k)
4899 & *fac_shield(i)*fac_shield(j)*sss
4901 gacontm_hb1(k,num_conti,i)=!ghalfm
4902 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4903 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4904 & *fac_shield(i)*fac_shield(j)*sss
4906 gacontm_hb2(k,num_conti,i)=!ghalfm
4907 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4908 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4909 & *fac_shield(i)*fac_shield(j)*sss
4911 gacontm_hb3(k,num_conti,i)=gggm(k)
4912 & *fac_shield(i)*fac_shield(j)*sss
4915 C Diagnostics. Comment out or remove after debugging!
4917 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4918 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4919 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4920 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4921 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4922 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4925 endif ! num_conti.le.maxconts
4929 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4932 ghalf=0.5d0*agg(l,k)
4933 aggi(l,k)=aggi(l,k)+ghalf
4934 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4935 aggj(l,k)=aggj(l,k)+ghalf
4938 if (j.eq.nres-1 .and. i.lt.j-2) then
4941 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4946 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4949 C-----------------------------------------------------------------------------
4950 subroutine eturn3(i,eello_turn3)
4951 C Third- and fourth-order contributions from turns
4952 implicit real*8 (a-h,o-z)
4953 include 'DIMENSIONS'
4954 include 'COMMON.IOUNITS'
4955 include 'COMMON.GEO'
4956 include 'COMMON.VAR'
4957 include 'COMMON.LOCAL'
4958 include 'COMMON.CHAIN'
4959 include 'COMMON.DERIV'
4960 include 'COMMON.INTERACT'
4961 include 'COMMON.CORRMAT'
4962 include 'COMMON.TORSION'
4963 include 'COMMON.VECTORS'
4964 include 'COMMON.FFIELD'
4965 include 'COMMON.CONTROL'
4966 include 'COMMON.SHIELD'
4968 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4969 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4970 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4971 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4972 & auxgmat2(2,2),auxgmatt2(2,2)
4973 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4974 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4975 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4976 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4978 double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4979 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4981 c write (iout,*) "eturn3",i,j,j1,j2
4986 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4988 C Third-order contributions
4995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4996 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4997 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4998 c auxalary matices for theta gradient
4999 c auxalary matrix for i+1 and constant i+2
5000 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5001 c auxalary matrix for i+2 and constant i+1
5002 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5003 call transpose2(auxmat(1,1),auxmat1(1,1))
5004 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5005 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5006 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5007 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5008 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5009 if (shield_mode.eq.0) then
5016 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5017 & *fac_shield(i)*fac_shield(j)*faclipij
5018 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5019 & *fac_shield(i)*fac_shield(j)
5020 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5023 C Derivatives in theta
5024 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5025 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5026 & *fac_shield(i)*fac_shield(j)*faclipij
5027 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5028 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5029 & *fac_shield(i)*fac_shield(j)*faclipij
5032 C Derivatives in shield mode
5033 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5034 & (shield_mode.gt.0)) then
5037 do ilist=1,ishield_list(i)
5038 iresshield=shield_list(ilist,i)
5040 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5042 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5044 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5045 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5049 do ilist=1,ishield_list(j)
5050 iresshield=shield_list(ilist,j)
5052 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5054 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5056 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5057 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5064 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5065 & grad_shield(k,i)*eello_t3/fac_shield(i)
5066 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5067 & grad_shield(k,j)*eello_t3/fac_shield(j)
5068 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5069 & grad_shield(k,i)*eello_t3/fac_shield(i)
5070 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5071 & grad_shield(k,j)*eello_t3/fac_shield(j)
5075 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5076 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5077 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5078 cd & ' eello_turn3_num',4*eello_turn3_num
5079 C Derivatives in gamma(i)
5080 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5081 call transpose2(auxmat2(1,1),auxmat3(1,1))
5082 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5083 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5084 & *fac_shield(i)*fac_shield(j)*faclipij
5085 C Derivatives in gamma(i+1)
5086 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5087 call transpose2(auxmat2(1,1),auxmat3(1,1))
5088 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5089 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5090 & +0.5d0*(pizda(1,1)+pizda(2,2))
5091 & *fac_shield(i)*fac_shield(j)*faclipij
5092 C Cartesian derivatives
5094 c ghalf1=0.5d0*agg(l,1)
5095 c ghalf2=0.5d0*agg(l,2)
5096 c ghalf3=0.5d0*agg(l,3)
5097 c ghalf4=0.5d0*agg(l,4)
5098 a_temp(1,1)=aggi(l,1)!+ghalf1
5099 a_temp(1,2)=aggi(l,2)!+ghalf2
5100 a_temp(2,1)=aggi(l,3)!+ghalf3
5101 a_temp(2,2)=aggi(l,4)!+ghalf4
5102 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5103 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5104 & +0.5d0*(pizda(1,1)+pizda(2,2))
5105 & *fac_shield(i)*fac_shield(j)*faclipij
5107 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5108 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5109 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5110 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5111 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5112 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5113 & +0.5d0*(pizda(1,1)+pizda(2,2))
5114 & *fac_shield(i)*fac_shield(j)*faclipij
5115 a_temp(1,1)=aggj(l,1)!+ghalf1
5116 a_temp(1,2)=aggj(l,2)!+ghalf2
5117 a_temp(2,1)=aggj(l,3)!+ghalf3
5118 a_temp(2,2)=aggj(l,4)!+ghalf4
5119 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5120 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5121 & +0.5d0*(pizda(1,1)+pizda(2,2))
5122 & *fac_shield(i)*fac_shield(j)*faclipij
5123 a_temp(1,1)=aggj1(l,1)
5124 a_temp(1,2)=aggj1(l,2)
5125 a_temp(2,1)=aggj1(l,3)
5126 a_temp(2,2)=aggj1(l,4)
5127 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5128 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5129 & +0.5d0*(pizda(1,1)+pizda(2,2))
5130 & *fac_shield(i)*fac_shield(j)*faclipij
5132 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5133 & ssgradlipi*eello_t3/4.0d0*lipscale
5134 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5135 & ssgradlipj*eello_t3/4.0d0*lipscale
5136 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5137 & ssgradlipi*eello_t3/4.0d0*lipscale
5138 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5139 & ssgradlipj*eello_t3/4.0d0*lipscale
5143 C-------------------------------------------------------------------------------
5144 subroutine eturn4(i,eello_turn4)
5145 C Third- and fourth-order contributions from turns
5146 implicit real*8 (a-h,o-z)
5147 include 'DIMENSIONS'
5148 include 'COMMON.IOUNITS'
5149 include 'COMMON.GEO'
5150 include 'COMMON.VAR'
5151 include 'COMMON.LOCAL'
5152 include 'COMMON.CHAIN'
5153 include 'COMMON.DERIV'
5154 include 'COMMON.INTERACT'
5155 include 'COMMON.CORRMAT'
5156 include 'COMMON.TORSION'
5157 include 'COMMON.VECTORS'
5158 include 'COMMON.FFIELD'
5159 include 'COMMON.CONTROL'
5160 include 'COMMON.SHIELD'
5162 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5163 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5164 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5165 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5166 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5167 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5168 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5169 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5170 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5171 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5172 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5175 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5177 C Fourth-order contributions
5185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5186 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5187 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5188 c write(iout,*)"WCHODZE W PROGRAM"
5193 iti1=itype2loc(itype(i+1))
5194 iti2=itype2loc(itype(i+2))
5195 iti3=itype2loc(itype(i+3))
5196 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5197 call transpose2(EUg(1,1,i+1),e1t(1,1))
5198 call transpose2(Eug(1,1,i+2),e2t(1,1))
5199 call transpose2(Eug(1,1,i+3),e3t(1,1))
5200 C Ematrix derivative in theta
5201 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5202 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5203 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5204 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5205 c eta1 in derivative theta
5206 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5207 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5208 c auxgvec is derivative of Ub2 so i+3 theta
5209 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5210 c auxalary matrix of E i+1
5211 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5214 s1=scalar2(b1(1,i+2),auxvec(1))
5215 c derivative of theta i+2 with constant i+3
5216 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5217 c derivative of theta i+2 with constant i+2
5218 gs32=scalar2(b1(1,i+2),auxgvec(1))
5219 c derivative of E matix in theta of i+1
5220 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5222 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5223 c ea31 in derivative theta
5224 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5225 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5226 c auxilary matrix auxgvec of Ub2 with constant E matirx
5227 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5228 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5229 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5233 s2=scalar2(b1(1,i+1),auxvec(1))
5234 c derivative of theta i+1 with constant i+3
5235 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5236 c derivative of theta i+2 with constant i+1
5237 gs21=scalar2(b1(1,i+1),auxgvec(1))
5238 c derivative of theta i+3 with constant i+1
5239 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5240 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5242 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5243 c two derivatives over diffetent matrices
5244 c gtae3e2 is derivative over i+3
5245 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5246 c ae3gte2 is derivative over i+2
5247 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5248 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5249 c three possible derivative over theta E matices
5251 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5253 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5255 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5256 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5258 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5259 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5260 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5261 if (shield_mode.eq.0) then
5268 eello_turn4=eello_turn4-(s1+s2+s3)
5269 & *fac_shield(i)*fac_shield(j)*faclipij
5270 eello_t4=-(s1+s2+s3)
5271 & *fac_shield(i)*fac_shield(j)
5272 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5273 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5274 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5275 C Now derivative over shield:
5276 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5277 & (shield_mode.gt.0)) then
5280 do ilist=1,ishield_list(i)
5281 iresshield=shield_list(ilist,i)
5283 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5285 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5287 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5288 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5292 do ilist=1,ishield_list(j)
5293 iresshield=shield_list(ilist,j)
5295 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5297 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5299 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5300 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5307 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5308 & grad_shield(k,i)*eello_t4/fac_shield(i)
5309 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5310 & grad_shield(k,j)*eello_t4/fac_shield(j)
5311 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5312 & grad_shield(k,i)*eello_t4/fac_shield(i)
5313 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5314 & grad_shield(k,j)*eello_t4/fac_shield(j)
5317 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5318 cd & ' eello_turn4_num',8*eello_turn4_num
5320 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5321 & -(gs13+gsE13+gsEE1)*wturn4
5322 & *fac_shield(i)*fac_shield(j)
5323 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5324 & -(gs23+gs21+gsEE2)*wturn4
5325 & *fac_shield(i)*fac_shield(j)
5327 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5328 & -(gs32+gsE31+gsEE3)*wturn4
5329 & *fac_shield(i)*fac_shield(j)
5331 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5334 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5335 & 'eturn4',i,j,-(s1+s2+s3)
5336 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 c & ' eello_turn4_num',8*eello_turn4_num
5338 C Derivatives in gamma(i)
5339 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5340 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5341 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5342 s1=scalar2(b1(1,i+2),auxvec(1))
5343 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5344 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5345 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5346 & *fac_shield(i)*fac_shield(j)*faclipij
5347 C Derivatives in gamma(i+1)
5348 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5349 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5350 s2=scalar2(b1(1,i+1),auxvec(1))
5351 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5352 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5353 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5354 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5355 & *fac_shield(i)*fac_shield(j)*faclipij
5356 C Derivatives in gamma(i+2)
5357 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5358 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5359 s1=scalar2(b1(1,i+2),auxvec(1))
5360 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5361 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5362 s2=scalar2(b1(1,i+1),auxvec(1))
5363 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5364 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5365 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5366 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5367 & *fac_shield(i)*fac_shield(j)*faclipij
5368 C Cartesian derivatives
5369 C Derivatives of this turn contributions in DC(i+2)
5370 if (j.lt.nres-1) then
5372 a_temp(1,1)=agg(l,1)
5373 a_temp(1,2)=agg(l,2)
5374 a_temp(2,1)=agg(l,3)
5375 a_temp(2,2)=agg(l,4)
5376 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5377 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5378 s1=scalar2(b1(1,i+2),auxvec(1))
5379 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5380 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5381 s2=scalar2(b1(1,i+1),auxvec(1))
5382 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5383 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5384 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5386 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5387 & *fac_shield(i)*fac_shield(j)*faclipij
5390 C Remaining derivatives of this turn contribution
5392 a_temp(1,1)=aggi(l,1)
5393 a_temp(1,2)=aggi(l,2)
5394 a_temp(2,1)=aggi(l,3)
5395 a_temp(2,2)=aggi(l,4)
5396 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5397 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5398 s1=scalar2(b1(1,i+2),auxvec(1))
5399 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5400 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5401 s2=scalar2(b1(1,i+1),auxvec(1))
5402 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5403 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5404 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5405 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5406 & *fac_shield(i)*fac_shield(j)*faclipij
5407 a_temp(1,1)=aggi1(l,1)
5408 a_temp(1,2)=aggi1(l,2)
5409 a_temp(2,1)=aggi1(l,3)
5410 a_temp(2,2)=aggi1(l,4)
5411 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5412 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5413 s1=scalar2(b1(1,i+2),auxvec(1))
5414 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5415 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5416 s2=scalar2(b1(1,i+1),auxvec(1))
5417 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5418 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5419 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5420 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5421 & *fac_shield(i)*fac_shield(j)*faclipij
5422 a_temp(1,1)=aggj(l,1)
5423 a_temp(1,2)=aggj(l,2)
5424 a_temp(2,1)=aggj(l,3)
5425 a_temp(2,2)=aggj(l,4)
5426 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5427 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5428 s1=scalar2(b1(1,i+2),auxvec(1))
5429 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5430 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5431 s2=scalar2(b1(1,i+1),auxvec(1))
5432 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5433 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5434 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5436 & *fac_shield(i)*fac_shield(j)*faclipij
5437 a_temp(1,1)=aggj1(l,1)
5438 a_temp(1,2)=aggj1(l,2)
5439 a_temp(2,1)=aggj1(l,3)
5440 a_temp(2,2)=aggj1(l,4)
5441 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5442 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5443 s1=scalar2(b1(1,i+2),auxvec(1))
5444 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5445 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5446 s2=scalar2(b1(1,i+1),auxvec(1))
5447 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5448 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5449 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5450 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5451 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5452 & *fac_shield(i)*fac_shield(j)*faclipij
5454 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5455 & ssgradlipi*eello_t4/4.0d0*lipscale
5456 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5457 & ssgradlipj*eello_t4/4.0d0*lipscale
5458 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5459 & ssgradlipi*eello_t4/4.0d0*lipscale
5460 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5461 & ssgradlipj*eello_t4/4.0d0*lipscale
5464 C-----------------------------------------------------------------------------
5465 subroutine vecpr(u,v,w)
5466 implicit real*8(a-h,o-z)
5467 dimension u(3),v(3),w(3)
5468 w(1)=u(2)*v(3)-u(3)*v(2)
5469 w(2)=-u(1)*v(3)+u(3)*v(1)
5470 w(3)=u(1)*v(2)-u(2)*v(1)
5473 C-----------------------------------------------------------------------------
5474 subroutine unormderiv(u,ugrad,unorm,ungrad)
5475 C This subroutine computes the derivatives of a normalized vector u, given
5476 C the derivatives computed without normalization conditions, ugrad. Returns
5479 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5480 double precision vec(3)
5481 double precision scalar
5483 c write (2,*) 'ugrad',ugrad
5486 vec(i)=scalar(ugrad(1,i),u(1))
5488 c write (2,*) 'vec',vec
5491 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5494 c write (2,*) 'ungrad',ungrad
5497 C-----------------------------------------------------------------------------
5498 subroutine escp_soft_sphere(evdw2,evdw2_14)
5500 C This subroutine calculates the excluded-volume interaction energy between
5501 C peptide-group centers and side chains and its gradient in virtual-bond and
5502 C side-chain vectors.
5504 implicit real*8 (a-h,o-z)
5505 include 'DIMENSIONS'
5506 include 'COMMON.GEO'
5507 include 'COMMON.VAR'
5508 include 'COMMON.LOCAL'
5509 include 'COMMON.CHAIN'
5510 include 'COMMON.DERIV'
5511 include 'COMMON.INTERACT'
5512 include 'COMMON.FFIELD'
5513 include 'COMMON.IOUNITS'
5514 include 'COMMON.CONTROL'
5516 double precision boxshift
5520 cd print '(a)','Enter ESCP'
5521 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5525 c do i=iatscp_s,iatscp_e
5526 do ikont=g_listscp_start,g_listscp_end
5527 i=newcontlistscpi(ikont)
5528 j=newcontlistscpj(ikont)
5529 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5531 xi=0.5D0*(c(1,i)+c(1,i+1))
5532 yi=0.5D0*(c(2,i)+c(2,i+1))
5533 zi=0.5D0*(c(3,i)+c(3,i+1))
5534 C Return atom into box, boxxsize is size of box in x dimension
5536 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5537 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5538 C Condition for being inside the proper box
5539 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5540 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5544 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5545 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5546 C Condition for being inside the proper box
5547 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5548 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5552 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5553 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5554 cC Condition for being inside the proper box
5555 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5556 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5559 call to_box(xi,yi,zi)
5560 C xi=xi+xshift*boxxsize
5561 C yi=yi+yshift*boxysize
5562 C zi=zi+zshift*boxzsize
5563 c do iint=1,nscp_gr(i)
5565 c do j=iscpstart(i,iint),iscpend(i,iint)
5566 if (itype(j).eq.ntyp1) cycle
5567 itypj=iabs(itype(j))
5568 C Uncomment following three lines for SC-p interactions
5572 C Uncomment following three lines for Ca-p interactions
5576 call to_box(xj,yj,zj)
5577 xj=boxshift(xj-xi,boxxsize)
5578 yj=boxshift(yj-yi,boxysize)
5579 zj=boxshift(zj-zi,boxzsize)
5583 rij=xj*xj+yj*yj+zj*zj
5587 if (rij.lt.r0ijsq) then
5588 evdwij=0.25d0*(rij-r0ijsq)**2
5596 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5602 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5603 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5614 C-----------------------------------------------------------------------------
5615 subroutine escp(evdw2,evdw2_14)
5617 C This subroutine calculates the excluded-volume interaction energy between
5618 C peptide-group centers and side chains and its gradient in virtual-bond and
5619 C side-chain vectors.
5625 include 'DIMENSIONS'
5626 include 'COMMON.GEO'
5627 include 'COMMON.VAR'
5628 include 'COMMON.LOCAL'
5629 include 'COMMON.CHAIN'
5630 include 'COMMON.DERIV'
5631 include 'COMMON.INTERACT'
5632 include 'COMMON.FFIELD'
5633 include 'COMMON.IOUNITS'
5634 include 'COMMON.CONTROL'
5635 include 'COMMON.SPLITELE'
5636 include 'COMMON.TIME1'
5637 double precision ggg(3)
5638 integer i,iint,j,k,iteli,itypj,subchap,ikont
5639 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5641 double precision evdw2,evdw2_14,evdwij
5642 double precision sscale,sscagrad
5643 double precision boxshift
5644 external boxshift,to_box
5646 c double precision time01
5650 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5651 cd print '(a)','Enter ESCP'
5652 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5656 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5657 c do i=iatscp_s,iatscp_e
5658 do ikont=g_listscp_start,g_listscp_end
5660 c time01=MPI_Wtime()
5662 i=newcontlistscpi(ikont)
5663 j=newcontlistscpj(ikont)
5664 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5666 xi=0.5D0*(c(1,i)+c(1,i+1))
5667 yi=0.5D0*(c(2,i)+c(2,i+1))
5668 zi=0.5D0*(c(3,i)+c(3,i+1))
5670 call to_box(xi,yi,zi)
5671 c do iint=1,nscp_gr(i)
5673 c do j=iscpstart(i,iint),iscpend(i,iint)
5674 itypj=iabs(itype(j))
5675 if (itypj.eq.ntyp1) cycle
5676 C Uncomment following three lines for SC-p interactions
5680 C Uncomment following three lines for Ca-p interactions
5685 call to_box(xj,yj,zj)
5687 c time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5688 c time01=MPI_Wtime()
5691 xj=boxshift(xj-xi,boxxsize)
5692 yj=boxshift(yj-yi,boxysize)
5693 zj=boxshift(zj-zi,boxzsize)
5694 c print *,xj,yj,zj,'polozenie j'
5696 c time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5697 c time01=MPI_Wtime()
5699 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5701 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5702 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5703 c if (sss.eq.0) print *,'czasem jest OK'
5704 if (sss.le.0.0d0) cycle
5705 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5707 e1=fac*fac*aad(itypj,iteli)
5708 e2=fac*bad(itypj,iteli)
5709 if (iabs(j-i) .le. 2) then
5712 evdw2_14=evdw2_14+(e1+e2)*sss
5715 evdw2=evdw2+evdwij*sss
5716 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5717 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5718 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5721 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5723 fac=-(evdwij+e1)*rrij*sss
5724 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5728 cgrad if (j.lt.i) then
5729 cd write (iout,*) 'j<i'
5730 C Uncomment following three lines for SC-p interactions
5732 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5735 cd write (iout,*) 'j>i'
5737 cgrad ggg(k)=-ggg(k)
5738 C Uncomment following line for SC-p interactions
5739 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5740 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5744 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5746 cgrad kstart=min0(i+1,j)
5747 cgrad kend=max0(i-1,j-1)
5748 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5749 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5750 cgrad do k=kstart,kend
5752 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5756 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5757 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5760 c time_escpcalc=time_escpcalc+MPI_Wtime()-time01
5762 c endif !endif for sscale cutoff
5772 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5773 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5774 gradx_scp(j,i)=expon*gradx_scp(j,i)
5777 C******************************************************************************
5781 C To save time the factor EXPON has been extracted from ALL components
5782 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5785 C******************************************************************************
5788 C--------------------------------------------------------------------------
5789 subroutine edis(ehpb)
5791 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5793 implicit real*8 (a-h,o-z)
5794 include 'DIMENSIONS'
5795 include 'COMMON.SBRIDGE'
5796 include 'COMMON.CHAIN'
5797 include 'COMMON.DERIV'
5798 include 'COMMON.VAR'
5799 include 'COMMON.INTERACT'
5800 include 'COMMON.IOUNITS'
5801 include 'COMMON.CONTROL'
5802 dimension ggg(3),ggg_peak(3,1000)
5807 c 8/21/18 AL: added explicit restraints on reference coords
5808 c write (iout,*) "restr_on_coord",restr_on_coord
5809 if (restr_on_coord) then
5813 if (itype(i).eq.ntyp1) cycle
5815 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5816 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5818 if (itype(i).ne.10) then
5820 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5821 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5824 if (energy_dec) write (iout,*)
5825 & "i",i," bfac",bfac(i)," ecoor",ecoor
5826 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5830 C write (iout,*) ,"link_end",link_end,constr_dist
5831 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5832 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5833 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5834 c & " link_end_peak",link_end_peak
5835 if (link_end.eq.0.and.link_end_peak.eq.0) return
5836 do i=link_start_peak,link_end_peak
5838 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5839 c & ipeak(1,i),ipeak(2,i)
5840 do ip=ipeak(1,i),ipeak(2,i)
5845 C iii and jjj point to the residues for which the distance is assigned.
5846 c if (ii.gt.nres) then
5853 if (ii.gt.nres) then
5858 if (jj.gt.nres) then
5863 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5864 aux=dexp(-scal_peak*aux)
5865 ehpb_peak=ehpb_peak+aux
5866 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5867 & forcon_peak(ip))*aux/dd
5869 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5871 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5872 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5873 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5875 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5876 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5877 do ip=ipeak(1,i),ipeak(2,i)
5880 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5884 C iii and jjj point to the residues for which the distance is assigned.
5885 c if (ii.gt.nres) then
5892 if (ii.gt.nres) then
5897 if (jj.gt.nres) then
5904 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5909 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5913 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5914 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5918 do i=link_start,link_end
5919 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5920 C CA-CA distance used in regularization of structure.
5923 C iii and jjj point to the residues for which the distance is assigned.
5924 if (ii.gt.nres) then
5929 if (jj.gt.nres) then
5934 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5935 c & dhpb(i),dhpb1(i),forcon(i)
5936 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5937 C distance and angle dependent SS bond potential.
5938 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5939 C & iabs(itype(jjj)).eq.1) then
5940 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5941 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5942 if (.not.dyn_ss .and. i.le.nss) then
5943 C 15/02/13 CC dynamic SSbond - additional check
5944 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5945 & iabs(itype(jjj)).eq.1) then
5946 call ssbond_ene(iii,jjj,eij)
5950 cd write (iout,*) "eij",eij
5951 cd & ' waga=',waga,' fac=',fac
5952 ! else if (ii.gt.nres .and. jj.gt.nres) then
5954 C Calculate the distance between the two points and its difference from the
5957 if (irestr_type(i).eq.11) then
5958 ehpb=ehpb+fordepth(i)!**4.0d0
5959 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5960 fac=fordepth(i)!**4.0d0
5961 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5962 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5963 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5964 & ehpb,irestr_type(i)
5965 else if (irestr_type(i).eq.10) then
5966 c AL 6//19/2018 cross-link restraints
5967 xdis = 0.5d0*(dd/forcon(i))**2
5968 expdis = dexp(-xdis)
5969 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5970 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5971 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5972 c & " wboltzd",wboltzd
5973 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5974 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5975 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5976 & *expdis/(aux*forcon(i)**2)
5977 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5978 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5979 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5980 else if (irestr_type(i).eq.2) then
5981 c Quartic restraints
5982 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5983 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5984 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5985 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5986 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5988 c Quadratic restraints
5990 C Get the force constant corresponding to this distance.
5992 C Calculate the contribution to energy.
5993 ehpb=ehpb+0.5d0*waga*rdis*rdis
5994 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5995 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5996 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5998 C Evaluate gradient.
6002 c Calculate Cartesian gradient
6004 ggg(j)=fac*(c(j,jj)-c(j,ii))
6006 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6007 C If this is a SC-SC distance, we need to calculate the contributions to the
6008 C Cartesian gradient in the SC vectors (ghpbx).
6011 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6016 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6020 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6021 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6027 C--------------------------------------------------------------------------
6028 subroutine ssbond_ene(i,j,eij)
6030 C Calculate the distance and angle dependent SS-bond potential energy
6031 C using a free-energy function derived based on RHF/6-31G** ab initio
6032 C calculations of diethyl disulfide.
6034 C A. Liwo and U. Kozlowska, 11/24/03
6036 implicit real*8 (a-h,o-z)
6037 include 'DIMENSIONS'
6038 include 'COMMON.SBRIDGE'
6039 include 'COMMON.CHAIN'
6040 include 'COMMON.DERIV'
6041 include 'COMMON.LOCAL'
6042 include 'COMMON.INTERACT'
6043 include 'COMMON.VAR'
6044 include 'COMMON.IOUNITS'
6045 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6046 itypi=iabs(itype(i))
6050 dxi=dc_norm(1,nres+i)
6051 dyi=dc_norm(2,nres+i)
6052 dzi=dc_norm(3,nres+i)
6053 c dsci_inv=dsc_inv(itypi)
6054 dsci_inv=vbld_inv(nres+i)
6055 itypj=iabs(itype(j))
6056 c dscj_inv=dsc_inv(itypj)
6057 dscj_inv=vbld_inv(nres+j)
6061 dxj=dc_norm(1,nres+j)
6062 dyj=dc_norm(2,nres+j)
6063 dzj=dc_norm(3,nres+j)
6064 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6069 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6070 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6071 om12=dxi*dxj+dyi*dyj+dzi*dzj
6073 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6074 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6080 deltat12=om2-om1+2.0d0
6082 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6083 & +akct*deltad*deltat12
6084 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6085 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6086 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6087 c & " deltat12",deltat12," eij",eij
6088 ed=2*akcm*deltad+akct*deltat12
6090 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6091 eom1=-2*akth*deltat1-pom1-om2*pom2
6092 eom2= 2*akth*deltat2+pom1-om1*pom2
6095 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6096 ghpbx(k,i)=ghpbx(k,i)-ggk
6097 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6098 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6099 ghpbx(k,j)=ghpbx(k,j)+ggk
6100 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6101 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6102 ghpbc(k,i)=ghpbc(k,i)-ggk
6103 ghpbc(k,j)=ghpbc(k,j)+ggk
6106 C Calculate the components of the gradient in DC and X
6110 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6115 C--------------------------------------------------------------------------
6116 subroutine ebond(estr)
6118 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6120 implicit real*8 (a-h,o-z)
6121 include 'DIMENSIONS'
6122 include 'COMMON.LOCAL'
6123 include 'COMMON.GEO'
6124 include 'COMMON.INTERACT'
6125 include 'COMMON.DERIV'
6126 include 'COMMON.VAR'
6127 include 'COMMON.CHAIN'
6128 include 'COMMON.IOUNITS'
6129 include 'COMMON.NAMES'
6130 include 'COMMON.FFIELD'
6131 include 'COMMON.CONTROL'
6132 include 'COMMON.SETUP'
6133 double precision u(3),ud(3)
6136 do i=ibondp_start,ibondp_end
6137 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6140 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6141 diff = vbld(i)-vbldp0
6143 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6144 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6146 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6147 c & *dc(j,i-1)/vbld(i)
6149 c if (energy_dec) write(iout,*)
6150 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6152 C Checking if it involves dummy (NH3+ or COO-) group
6153 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6154 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6155 diff = vbld(i)-vbldpDUM
6156 if (energy_dec) write(iout,*) "dum_bond",i,diff
6158 C NO vbldp0 is the equlibrium length of spring for peptide group
6159 diff = vbld(i)-vbldp0
6162 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6163 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6166 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6168 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6172 estr=0.5d0*AKP*estr+estr1
6174 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6176 do i=ibond_start,ibond_end
6178 if (iti.ne.10 .and. iti.ne.ntyp1) then
6181 diff=vbld(i+nres)-vbldsc0(1,iti)
6182 if (energy_dec) write (iout,*)
6183 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6184 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6185 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6187 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6191 diff=vbld(i+nres)-vbldsc0(j,iti)
6192 ud(j)=aksc(j,iti)*diff
6193 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6207 uprod2=uprod2*u(k)*u(k)
6211 usumsqder=usumsqder+ud(j)*uprod2
6213 estr=estr+uprod/usum
6215 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6223 C--------------------------------------------------------------------------
6224 subroutine ebend(etheta)
6226 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6227 C angles gamma and its derivatives in consecutive thetas and gammas.
6229 implicit real*8 (a-h,o-z)
6230 include 'DIMENSIONS'
6231 include 'COMMON.LOCAL'
6232 include 'COMMON.GEO'
6233 include 'COMMON.INTERACT'
6234 include 'COMMON.DERIV'
6235 include 'COMMON.VAR'
6236 include 'COMMON.CHAIN'
6237 include 'COMMON.IOUNITS'
6238 include 'COMMON.NAMES'
6239 include 'COMMON.FFIELD'
6240 include 'COMMON.CONTROL'
6241 include 'COMMON.TORCNSTR'
6242 common /calcthet/ term1,term2,termm,diffak,ratak,
6243 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6244 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6245 double precision y(2),z(2)
6247 c time11=dexp(-2*time)
6250 c write (*,'(a,i2)') 'EBEND ICG=',icg
6251 do i=ithet_start,ithet_end
6252 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6253 & .or.itype(i).eq.ntyp1) cycle
6254 C Zero the energy function and its derivative at 0 or pi.
6255 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6257 ichir1=isign(1,itype(i-2))
6258 ichir2=isign(1,itype(i))
6259 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6260 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6261 if (itype(i-1).eq.10) then
6262 itype1=isign(10,itype(i-2))
6263 ichir11=isign(1,itype(i-2))
6264 ichir12=isign(1,itype(i-2))
6265 itype2=isign(10,itype(i))
6266 ichir21=isign(1,itype(i))
6267 ichir22=isign(1,itype(i))
6270 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6273 if (phii.ne.phii) phii=150.0
6283 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6286 if (phii1.ne.phii1) phii1=150.0
6298 C Calculate the "mean" value of theta from the part of the distribution
6299 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6300 C In following comments this theta will be referred to as t_c.
6301 thet_pred_mean=0.0d0
6303 athetk=athet(k,it,ichir1,ichir2)
6304 bthetk=bthet(k,it,ichir1,ichir2)
6306 athetk=athet(k,itype1,ichir11,ichir12)
6307 bthetk=bthet(k,itype2,ichir21,ichir22)
6309 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6310 c write(iout,*) 'chuj tu', y(k),z(k)
6312 dthett=thet_pred_mean*ssd
6313 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6314 C Derivatives of the "mean" values in gamma1 and gamma2.
6315 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6316 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6317 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6318 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6320 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6321 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6322 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6323 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6325 if (theta(i).gt.pi-delta) then
6326 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6328 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6329 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6330 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6332 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6334 else if (theta(i).lt.delta) then
6335 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6336 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6337 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6339 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6340 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6343 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6346 etheta=etheta+ethetai
6347 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6348 & 'ebend',i,ethetai,theta(i),itype(i)
6349 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6350 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6351 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6354 C Ufff.... We've done all this!!!
6357 C---------------------------------------------------------------------------
6358 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6360 implicit real*8 (a-h,o-z)
6361 include 'DIMENSIONS'
6362 include 'COMMON.LOCAL'
6363 include 'COMMON.IOUNITS'
6364 common /calcthet/ term1,term2,termm,diffak,ratak,
6365 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6366 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6367 C Calculate the contributions to both Gaussian lobes.
6368 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6369 C The "polynomial part" of the "standard deviation" of this part of
6370 C the distributioni.
6371 ccc write (iout,*) thetai,thet_pred_mean
6374 sig=sig*thet_pred_mean+polthet(j,it)
6376 C Derivative of the "interior part" of the "standard deviation of the"
6377 C gamma-dependent Gaussian lobe in t_c.
6378 sigtc=3*polthet(3,it)
6380 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6383 C Set the parameters of both Gaussian lobes of the distribution.
6384 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6385 fac=sig*sig+sigc0(it)
6388 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6389 sigsqtc=-4.0D0*sigcsq*sigtc
6390 c print *,i,sig,sigtc,sigsqtc
6391 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6392 sigtc=-sigtc/(fac*fac)
6393 C Following variable is sigma(t_c)**(-2)
6394 sigcsq=sigcsq*sigcsq
6396 sig0inv=1.0D0/sig0i**2
6397 delthec=thetai-thet_pred_mean
6398 delthe0=thetai-theta0i
6399 term1=-0.5D0*sigcsq*delthec*delthec
6400 term2=-0.5D0*sig0inv*delthe0*delthe0
6401 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6402 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6403 C NaNs in taking the logarithm. We extract the largest exponent which is added
6404 C to the energy (this being the log of the distribution) at the end of energy
6405 C term evaluation for this virtual-bond angle.
6406 if (term1.gt.term2) then
6408 term2=dexp(term2-termm)
6412 term1=dexp(term1-termm)
6415 C The ratio between the gamma-independent and gamma-dependent lobes of
6416 C the distribution is a Gaussian function of thet_pred_mean too.
6417 diffak=gthet(2,it)-thet_pred_mean
6418 ratak=diffak/gthet(3,it)**2
6419 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6420 C Let's differentiate it in thet_pred_mean NOW.
6422 C Now put together the distribution terms to make complete distribution.
6423 termexp=term1+ak*term2
6424 termpre=sigc+ak*sig0i
6425 C Contribution of the bending energy from this theta is just the -log of
6426 C the sum of the contributions from the two lobes and the pre-exponential
6427 C factor. Simple enough, isn't it?
6428 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6429 C write (iout,*) 'termexp',termexp,termm,termpre,i
6430 C NOW the derivatives!!!
6431 C 6/6/97 Take into account the deformation.
6432 E_theta=(delthec*sigcsq*term1
6433 & +ak*delthe0*sig0inv*term2)/termexp
6434 E_tc=((sigtc+aktc*sig0i)/termpre
6435 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6436 & aktc*term2)/termexp)
6439 c-----------------------------------------------------------------------------
6440 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6441 implicit real*8 (a-h,o-z)
6442 include 'DIMENSIONS'
6443 include 'COMMON.LOCAL'
6444 include 'COMMON.IOUNITS'
6445 common /calcthet/ term1,term2,termm,diffak,ratak,
6446 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6447 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6448 delthec=thetai-thet_pred_mean
6449 delthe0=thetai-theta0i
6450 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6451 t3 = thetai-thet_pred_mean
6455 t14 = t12+t6*sigsqtc
6457 t21 = thetai-theta0i
6463 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6464 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6465 & *(-t12*t9-ak*sig0inv*t27)
6469 C--------------------------------------------------------------------------
6470 subroutine ebend(etheta)
6472 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6473 C angles gamma and its derivatives in consecutive thetas and gammas.
6474 C ab initio-derived potentials from
6475 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6477 implicit real*8 (a-h,o-z)
6478 include 'DIMENSIONS'
6479 include 'COMMON.LOCAL'
6480 include 'COMMON.GEO'
6481 include 'COMMON.INTERACT'
6482 include 'COMMON.DERIV'
6483 include 'COMMON.VAR'
6484 include 'COMMON.CHAIN'
6485 include 'COMMON.IOUNITS'
6486 include 'COMMON.NAMES'
6487 include 'COMMON.FFIELD'
6488 include 'COMMON.CONTROL'
6489 include 'COMMON.TORCNSTR'
6490 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6491 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6492 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6493 & sinph1ph2(maxdouble,maxdouble)
6494 logical lprn /.false./, lprn1 /.false./
6496 do i=ithet_start,ithet_end
6497 c print *,i,itype(i-1),itype(i),itype(i-2)
6498 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6499 & .or.itype(i).eq.ntyp1) cycle
6500 C print *,i,theta(i)
6501 if (iabs(itype(i+1)).eq.20) iblock=2
6502 if (iabs(itype(i+1)).ne.20) iblock=1
6506 theti2=0.5d0*theta(i)
6507 ityp2=ithetyp((itype(i-1)))
6509 coskt(k)=dcos(k*theti2)
6510 sinkt(k)=dsin(k*theti2)
6513 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6516 if (phii.ne.phii) phii=150.0
6520 ityp1=ithetyp((itype(i-2)))
6521 C propagation of chirality for glycine type
6523 cosph1(k)=dcos(k*phii)
6524 sinph1(k)=dsin(k*phii)
6529 ityp1=ithetyp((itype(i-2)))
6534 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6537 if (phii1.ne.phii1) phii1=150.0
6542 ityp3=ithetyp((itype(i)))
6544 cosph2(k)=dcos(k*phii1)
6545 sinph2(k)=dsin(k*phii1)
6549 ityp3=ithetyp((itype(i)))
6555 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6558 ccl=cosph1(l)*cosph2(k-l)
6559 ssl=sinph1(l)*sinph2(k-l)
6560 scl=sinph1(l)*cosph2(k-l)
6561 csl=cosph1(l)*sinph2(k-l)
6562 cosph1ph2(l,k)=ccl-ssl
6563 cosph1ph2(k,l)=ccl+ssl
6564 sinph1ph2(l,k)=scl+csl
6565 sinph1ph2(k,l)=scl-csl
6569 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6570 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6571 write (iout,*) "coskt and sinkt"
6573 write (iout,*) k,coskt(k),sinkt(k)
6577 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6578 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6581 & write (iout,*) "k",k,"
6582 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6583 & " ethetai",ethetai
6586 write (iout,*) "cosph and sinph"
6588 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6590 write (iout,*) "cosph1ph2 and sinph2ph2"
6593 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6594 & sinph1ph2(l,k),sinph1ph2(k,l)
6597 write(iout,*) "ethetai",ethetai
6602 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6603 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6604 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6605 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6606 ethetai=ethetai+sinkt(m)*aux
6607 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6608 dephii=dephii+k*sinkt(m)*(
6609 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6610 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6611 dephii1=dephii1+k*sinkt(m)*(
6612 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6613 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6615 & write (iout,*) "m",m," k",k," bbthet",
6616 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6617 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6618 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6619 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6620 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6623 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6624 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6625 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6626 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6628 & write(iout,*) "ethetai",ethetai
6629 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6633 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6634 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6635 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6636 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6637 ethetai=ethetai+sinkt(m)*aux
6638 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6639 dephii=dephii+l*sinkt(m)*(
6640 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6641 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6642 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6643 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6644 dephii1=dephii1+(k-l)*sinkt(m)*(
6645 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6646 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6647 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6648 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6650 write (iout,*) "m",m," k",k," l",l," ffthet",
6651 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6652 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6653 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6654 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6655 & " ethetai",ethetai
6656 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6657 & cosph1ph2(k,l)*sinkt(m),
6658 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6667 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6668 & i,theta(i)*rad2deg,phii*rad2deg,
6669 & phii1*rad2deg,ethetai
6671 etheta=etheta+ethetai
6672 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6673 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6674 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6681 c-----------------------------------------------------------------------------
6682 subroutine esc(escloc)
6683 C Calculate the local energy of a side chain and its derivatives in the
6684 C corresponding virtual-bond valence angles THETA and the spherical angles
6686 implicit real*8 (a-h,o-z)
6687 include 'DIMENSIONS'
6688 include 'COMMON.GEO'
6689 include 'COMMON.LOCAL'
6690 include 'COMMON.VAR'
6691 include 'COMMON.INTERACT'
6692 include 'COMMON.DERIV'
6693 include 'COMMON.CHAIN'
6694 include 'COMMON.IOUNITS'
6695 include 'COMMON.NAMES'
6696 include 'COMMON.FFIELD'
6697 include 'COMMON.CONTROL'
6698 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6699 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6700 common /sccalc/ time11,time12,time112,theti,it,nlobit
6703 c write (iout,'(a)') 'ESC'
6704 do i=loc_start,loc_end
6706 if (it.eq.ntyp1) cycle
6707 if (it.eq.10) goto 1
6708 nlobit=nlob(iabs(it))
6709 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6710 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6711 theti=theta(i+1)-pipol
6716 if (x(2).gt.pi-delta) then
6720 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6722 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6723 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6725 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6726 & ddersc0(1),dersc(1))
6727 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6728 & ddersc0(3),dersc(3))
6730 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6732 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6733 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6734 & dersc0(2),esclocbi,dersc02)
6735 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6737 call splinthet(x(2),0.5d0*delta,ss,ssd)
6742 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6744 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6745 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6747 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6749 c write (iout,*) escloci
6750 else if (x(2).lt.delta) then
6754 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6756 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6757 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6759 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6760 & ddersc0(1),dersc(1))
6761 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6762 & ddersc0(3),dersc(3))
6764 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6766 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6767 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6768 & dersc0(2),esclocbi,dersc02)
6769 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6774 call splinthet(x(2),0.5d0*delta,ss,ssd)
6776 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6778 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6779 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6781 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6782 c write (iout,*) escloci
6784 call enesc(x,escloci,dersc,ddummy,.false.)
6787 escloc=escloc+escloci
6788 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6789 & 'escloc',i,escloci
6790 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6792 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6794 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6795 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6800 C---------------------------------------------------------------------------
6801 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6802 implicit real*8 (a-h,o-z)
6803 include 'DIMENSIONS'
6804 include 'COMMON.GEO'
6805 include 'COMMON.LOCAL'
6806 include 'COMMON.IOUNITS'
6807 common /sccalc/ time11,time12,time112,theti,it,nlobit
6808 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6809 double precision contr(maxlob,-1:1)
6811 c write (iout,*) 'it=',it,' nlobit=',nlobit
6815 if (mixed) ddersc(j)=0.0d0
6819 C Because of periodicity of the dependence of the SC energy in omega we have
6820 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6821 C To avoid underflows, first compute & store the exponents.
6829 z(k)=x(k)-censc(k,j,it)
6834 Axk=Axk+gaussc(l,k,j,it)*z(l)
6840 expfac=expfac+Ax(k,j,iii)*z(k)
6848 C As in the case of ebend, we want to avoid underflows in exponentiation and
6849 C subsequent NaNs and INFs in energy calculation.
6850 C Find the largest exponent
6854 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6858 cd print *,'it=',it,' emin=',emin
6860 C Compute the contribution to SC energy and derivatives
6865 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6866 if(adexp.ne.adexp) adexp=1.0
6869 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6871 cd print *,'j=',j,' expfac=',expfac
6872 escloc_i=escloc_i+expfac
6874 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6878 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6879 & +gaussc(k,2,j,it))*expfac
6886 dersc(1)=dersc(1)/cos(theti)**2
6887 ddersc(1)=ddersc(1)/cos(theti)**2
6890 escloci=-(dlog(escloc_i)-emin)
6892 dersc(j)=dersc(j)/escloc_i
6896 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6901 C------------------------------------------------------------------------------
6902 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6903 implicit real*8 (a-h,o-z)
6904 include 'DIMENSIONS'
6905 include 'COMMON.GEO'
6906 include 'COMMON.LOCAL'
6907 include 'COMMON.IOUNITS'
6908 common /sccalc/ time11,time12,time112,theti,it,nlobit
6909 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6910 double precision contr(maxlob)
6921 z(k)=x(k)-censc(k,j,it)
6927 Axk=Axk+gaussc(l,k,j,it)*z(l)
6933 expfac=expfac+Ax(k,j)*z(k)
6938 C As in the case of ebend, we want to avoid underflows in exponentiation and
6939 C subsequent NaNs and INFs in energy calculation.
6940 C Find the largest exponent
6943 if (emin.gt.contr(j)) emin=contr(j)
6947 C Compute the contribution to SC energy and derivatives
6951 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6952 escloc_i=escloc_i+expfac
6954 dersc(k)=dersc(k)+Ax(k,j)*expfac
6956 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6957 & +gaussc(1,2,j,it))*expfac
6961 dersc(1)=dersc(1)/cos(theti)**2
6962 dersc12=dersc12/cos(theti)**2
6963 escloci=-(dlog(escloc_i)-emin)
6965 dersc(j)=dersc(j)/escloc_i
6967 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6971 c----------------------------------------------------------------------------------
6972 subroutine esc(escloc)
6973 C Calculate the local energy of a side chain and its derivatives in the
6974 C corresponding virtual-bond valence angles THETA and the spherical angles
6975 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6976 C added by Urszula Kozlowska. 07/11/2007
6978 implicit real*8 (a-h,o-z)
6979 include 'DIMENSIONS'
6980 include 'COMMON.GEO'
6981 include 'COMMON.LOCAL'
6982 include 'COMMON.VAR'
6983 include 'COMMON.SCROT'
6984 include 'COMMON.INTERACT'
6985 include 'COMMON.DERIV'
6986 include 'COMMON.CHAIN'
6987 include 'COMMON.IOUNITS'
6988 include 'COMMON.NAMES'
6989 include 'COMMON.FFIELD'
6990 include 'COMMON.CONTROL'
6991 include 'COMMON.VECTORS'
6992 double precision x_prime(3),y_prime(3),z_prime(3)
6993 & , sumene,dsc_i,dp2_i,x(65),
6994 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6995 & de_dxx,de_dyy,de_dzz,de_dt
6996 double precision s1_t,s1_6_t,s2_t,s2_6_t
6998 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6999 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7000 & dt_dCi(3),dt_dCi1(3)
7001 common /sccalc/ time11,time12,time112,theti,it,nlobit
7004 do i=loc_start,loc_end
7005 if (itype(i).eq.ntyp1) cycle
7006 costtab(i+1) =dcos(theta(i+1))
7007 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7008 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7009 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7010 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7011 cosfac=dsqrt(cosfac2)
7012 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7013 sinfac=dsqrt(sinfac2)
7015 if (it.eq.10) goto 1
7017 C Compute the axes of tghe local cartesian coordinates system; store in
7018 c x_prime, y_prime and z_prime
7025 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7026 C & dc_norm(3,i+nres)
7028 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7029 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7032 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7035 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7036 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7037 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7038 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7039 c & " xy",scalar(x_prime(1),y_prime(1)),
7040 c & " xz",scalar(x_prime(1),z_prime(1)),
7041 c & " yy",scalar(y_prime(1),y_prime(1)),
7042 c & " yz",scalar(y_prime(1),z_prime(1)),
7043 c & " zz",scalar(z_prime(1),z_prime(1))
7045 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7046 C to local coordinate system. Store in xx, yy, zz.
7052 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7053 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7054 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7061 C Compute the energy of the ith side cbain
7063 c write (2,*) "xx",xx," yy",yy," zz",zz
7066 x(j) = sc_parmin(j,it)
7069 Cc diagnostics - remove later
7071 yy1 = dsin(alph(2))*dcos(omeg(2))
7072 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7073 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7074 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7076 C," --- ", xx_w,yy_w,zz_w
7079 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7080 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7082 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7083 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7085 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7086 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7087 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7088 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7089 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7091 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7092 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7093 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7094 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7095 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7097 dsc_i = 0.743d0+x(61)
7099 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7100 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7101 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7102 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7103 s1=(1+x(63))/(0.1d0 + dscp1)
7104 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7105 s2=(1+x(65))/(0.1d0 + dscp2)
7106 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7107 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7108 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7109 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7111 c & dscp1,dscp2,sumene
7112 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7113 escloc = escloc + sumene
7114 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7115 & " escloc",sumene,escloc,it,itype(i)
7120 C This section to check the numerical derivatives of the energy of ith side
7121 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7122 C #define DEBUG in the code to turn it on.
7124 write (2,*) "sumene =",sumene
7128 write (2,*) xx,yy,zz
7129 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7130 de_dxx_num=(sumenep-sumene)/aincr
7132 write (2,*) "xx+ sumene from enesc=",sumenep
7135 write (2,*) xx,yy,zz
7136 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7137 de_dyy_num=(sumenep-sumene)/aincr
7139 write (2,*) "yy+ sumene from enesc=",sumenep
7142 write (2,*) xx,yy,zz
7143 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7144 de_dzz_num=(sumenep-sumene)/aincr
7146 write (2,*) "zz+ sumene from enesc=",sumenep
7147 costsave=cost2tab(i+1)
7148 sintsave=sint2tab(i+1)
7149 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7150 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7151 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7152 de_dt_num=(sumenep-sumene)/aincr
7153 write (2,*) " t+ sumene from enesc=",sumenep
7154 cost2tab(i+1)=costsave
7155 sint2tab(i+1)=sintsave
7156 C End of diagnostics section.
7159 C Compute the gradient of esc
7161 c zz=zz*dsign(1.0,dfloat(itype(i)))
7162 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7163 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7164 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7165 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7166 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7167 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7168 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7169 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7170 pom1=(sumene3*sint2tab(i+1)+sumene1)
7171 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7172 pom2=(sumene4*cost2tab(i+1)+sumene2)
7173 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7174 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7175 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7176 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7178 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7179 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7180 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7182 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7183 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7184 & +(pom1+pom2)*pom_dx
7186 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7189 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7190 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7191 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7193 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7194 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7195 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7196 & +x(59)*zz**2 +x(60)*xx*zz
7197 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7198 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7199 & +(pom1-pom2)*pom_dy
7201 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7204 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7205 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7206 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7207 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7208 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7209 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7210 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7211 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7213 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7216 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7217 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7218 & +pom1*pom_dt1+pom2*pom_dt2
7220 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7225 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7226 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7227 cosfac2xx=cosfac2*xx
7228 sinfac2yy=sinfac2*yy
7230 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7232 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7234 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7235 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7236 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7237 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7238 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7239 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7240 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7241 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7242 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7243 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7247 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7248 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7249 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7250 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7253 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7254 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7255 dZZ_XYZ(k)=vbld_inv(i+nres)*
7256 & (z_prime(k)-zz*dC_norm(k,i+nres))
7258 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7259 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7263 dXX_Ctab(k,i)=dXX_Ci(k)
7264 dXX_C1tab(k,i)=dXX_Ci1(k)
7265 dYY_Ctab(k,i)=dYY_Ci(k)
7266 dYY_C1tab(k,i)=dYY_Ci1(k)
7267 dZZ_Ctab(k,i)=dZZ_Ci(k)
7268 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7269 dXX_XYZtab(k,i)=dXX_XYZ(k)
7270 dYY_XYZtab(k,i)=dYY_XYZ(k)
7271 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7275 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7276 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7277 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7278 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7279 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7281 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7282 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7283 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7284 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7285 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7286 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7287 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7288 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7290 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7291 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7293 C to check gradient call subroutine check_grad
7299 c------------------------------------------------------------------------------
7300 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7302 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7303 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7304 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7305 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7307 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7308 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7310 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7311 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7312 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7313 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7314 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7316 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7317 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7318 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7319 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7320 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7322 dsc_i = 0.743d0+x(61)
7324 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7325 & *(xx*cost2+yy*sint2))
7326 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7327 & *(xx*cost2-yy*sint2))
7328 s1=(1+x(63))/(0.1d0 + dscp1)
7329 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7330 s2=(1+x(65))/(0.1d0 + dscp2)
7331 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7332 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7333 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7338 c------------------------------------------------------------------------------
7339 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7341 C This procedure calculates two-body contact function g(rij) and its derivative:
7344 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7347 C where x=(rij-r0ij)/delta
7349 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7352 double precision rij,r0ij,eps0ij,fcont,fprimcont
7353 double precision x,x2,x4,delta
7357 if (x.lt.-1.0D0) then
7360 else if (x.le.1.0D0) then
7363 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7364 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7371 c------------------------------------------------------------------------------
7372 subroutine splinthet(theti,delta,ss,ssder)
7373 implicit real*8 (a-h,o-z)
7374 include 'DIMENSIONS'
7375 include 'COMMON.VAR'
7376 include 'COMMON.GEO'
7379 if (theti.gt.pipol) then
7380 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7382 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7387 c------------------------------------------------------------------------------
7388 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7390 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7391 double precision ksi,ksi2,ksi3,a1,a2,a3
7392 a1=fprim0*delta/(f1-f0)
7398 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7399 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7402 c------------------------------------------------------------------------------
7403 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7405 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7406 double precision ksi,ksi2,ksi3,a1,a2,a3
7411 a2=3*(f1x-f0x)-2*fprim0x*delta
7412 a3=fprim0x*delta-2*(f1x-f0x)
7413 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7416 C-----------------------------------------------------------------------------
7418 C-----------------------------------------------------------------------------
7419 subroutine etor(etors)
7420 implicit real*8 (a-h,o-z)
7421 include 'DIMENSIONS'
7422 include 'COMMON.VAR'
7423 include 'COMMON.GEO'
7424 include 'COMMON.LOCAL'
7425 include 'COMMON.TORSION'
7426 include 'COMMON.INTERACT'
7427 include 'COMMON.DERIV'
7428 include 'COMMON.CHAIN'
7429 include 'COMMON.NAMES'
7430 include 'COMMON.IOUNITS'
7431 include 'COMMON.FFIELD'
7432 include 'COMMON.TORCNSTR'
7433 include 'COMMON.CONTROL'
7435 C Set lprn=.true. for debugging
7439 do i=iphi_start,iphi_end
7441 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7442 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7443 itori=itortyp(itype(i-2))
7444 itori1=itortyp(itype(i-1))
7447 C Proline-Proline pair is a special case...
7448 if (itori.eq.3 .and. itori1.eq.3) then
7449 if (phii.gt.-dwapi3) then
7451 fac=1.0D0/(1.0D0-cosphi)
7452 etorsi=v1(1,3,3)*fac
7453 etorsi=etorsi+etorsi
7454 etors=etors+etorsi-v1(1,3,3)
7455 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7456 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7459 v1ij=v1(j+1,itori,itori1)
7460 v2ij=v2(j+1,itori,itori1)
7463 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7464 if (energy_dec) etors_ii=etors_ii+
7465 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7466 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7470 v1ij=v1(j,itori,itori1)
7471 v2ij=v2(j,itori,itori1)
7474 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7475 if (energy_dec) etors_ii=etors_ii+
7476 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7477 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7480 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7483 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7484 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7485 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7486 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7487 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7491 c------------------------------------------------------------------------------
7492 subroutine etor_d(etors_d)
7496 c----------------------------------------------------------------------------
7497 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7498 subroutine e_modeller(ehomology_constr)
7499 ehomology_constr=0.0d0
7500 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7503 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7505 c------------------------------------------------------------------------------
7506 subroutine etor_d(etors_d)
7510 c----------------------------------------------------------------------------
7512 subroutine etor(etors)
7513 implicit real*8 (a-h,o-z)
7514 include 'DIMENSIONS'
7515 include 'COMMON.VAR'
7516 include 'COMMON.GEO'
7517 include 'COMMON.LOCAL'
7518 include 'COMMON.TORSION'
7519 include 'COMMON.INTERACT'
7520 include 'COMMON.DERIV'
7521 include 'COMMON.CHAIN'
7522 include 'COMMON.NAMES'
7523 include 'COMMON.IOUNITS'
7524 include 'COMMON.FFIELD'
7525 include 'COMMON.TORCNSTR'
7526 include 'COMMON.CONTROL'
7528 C Set lprn=.true. for debugging
7532 do i=iphi_start,iphi_end
7533 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7534 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7535 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7536 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7537 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7538 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7539 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7540 C For introducing the NH3+ and COO- group please check the etor_d for reference
7543 if (iabs(itype(i)).eq.20) then
7548 itori=itortyp(itype(i-2))
7549 itori1=itortyp(itype(i-1))
7552 C Regular cosine and sine terms
7553 do j=1,nterm(itori,itori1,iblock)
7554 v1ij=v1(j,itori,itori1,iblock)
7555 v2ij=v2(j,itori,itori1,iblock)
7558 etors=etors+v1ij*cosphi+v2ij*sinphi
7559 if (energy_dec) etors_ii=etors_ii+
7560 & v1ij*cosphi+v2ij*sinphi
7561 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7565 C E = SUM ----------------------------------- - v1
7566 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7568 cosphi=dcos(0.5d0*phii)
7569 sinphi=dsin(0.5d0*phii)
7570 do j=1,nlor(itori,itori1,iblock)
7571 vl1ij=vlor1(j,itori,itori1)
7572 vl2ij=vlor2(j,itori,itori1)
7573 vl3ij=vlor3(j,itori,itori1)
7574 pom=vl2ij*cosphi+vl3ij*sinphi
7575 pom1=1.0d0/(pom*pom+1.0d0)
7576 etors=etors+vl1ij*pom1
7577 if (energy_dec) etors_ii=etors_ii+
7580 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7582 C Subtract the constant term
7583 etors=etors-v0(itori,itori1,iblock)
7584 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7585 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7587 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7588 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7589 & (v1(j,itori,itori1,iblock),j=1,6),
7590 & (v2(j,itori,itori1,iblock),j=1,6)
7591 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7592 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7596 c----------------------------------------------------------------------------
7597 subroutine etor_d(etors_d)
7598 C 6/23/01 Compute double torsional energy
7599 implicit real*8 (a-h,o-z)
7600 include 'DIMENSIONS'
7601 include 'COMMON.VAR'
7602 include 'COMMON.GEO'
7603 include 'COMMON.LOCAL'
7604 include 'COMMON.TORSION'
7605 include 'COMMON.INTERACT'
7606 include 'COMMON.DERIV'
7607 include 'COMMON.CHAIN'
7608 include 'COMMON.NAMES'
7609 include 'COMMON.IOUNITS'
7610 include 'COMMON.FFIELD'
7611 include 'COMMON.TORCNSTR'
7613 C Set lprn=.true. for debugging
7617 c write(iout,*) "a tu??"
7618 do i=iphid_start,iphid_end
7619 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7620 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7621 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7622 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7623 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7624 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7625 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7626 & (itype(i+1).eq.ntyp1)) cycle
7627 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7628 itori=itortyp(itype(i-2))
7629 itori1=itortyp(itype(i-1))
7630 itori2=itortyp(itype(i))
7636 if (iabs(itype(i+1)).eq.20) iblock=2
7637 C Iblock=2 Proline type
7638 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7639 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7640 C if (itype(i+1).eq.ntyp1) iblock=3
7641 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7642 C IS or IS NOT need for this
7643 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7644 C is (itype(i-3).eq.ntyp1) ntblock=2
7645 C ntblock is N-terminal blocking group
7647 C Regular cosine and sine terms
7648 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7649 C Example of changes for NH3+ blocking group
7650 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7651 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7652 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7653 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7654 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7655 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7656 cosphi1=dcos(j*phii)
7657 sinphi1=dsin(j*phii)
7658 cosphi2=dcos(j*phii1)
7659 sinphi2=dsin(j*phii1)
7660 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7661 & v2cij*cosphi2+v2sij*sinphi2
7662 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7663 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7665 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7667 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7668 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7669 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7670 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7671 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7672 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7673 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7674 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7675 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7676 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7677 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7678 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7679 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7680 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7683 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7684 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7689 C----------------------------------------------------------------------------------
7690 C The rigorous attempt to derive energy function
7691 subroutine etor_kcc(etors)
7692 implicit real*8 (a-h,o-z)
7693 include 'DIMENSIONS'
7694 include 'COMMON.VAR'
7695 include 'COMMON.GEO'
7696 include 'COMMON.LOCAL'
7697 include 'COMMON.TORSION'
7698 include 'COMMON.INTERACT'
7699 include 'COMMON.DERIV'
7700 include 'COMMON.CHAIN'
7701 include 'COMMON.NAMES'
7702 include 'COMMON.IOUNITS'
7703 include 'COMMON.FFIELD'
7704 include 'COMMON.TORCNSTR'
7705 include 'COMMON.CONTROL'
7706 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7708 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7709 C Set lprn=.true. for debugging
7712 C print *,"wchodze kcc"
7713 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7715 do i=iphi_start,iphi_end
7716 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7717 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7718 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7719 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7720 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7721 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7722 itori=itortyp(itype(i-2))
7723 itori1=itortyp(itype(i-1))
7728 C to avoid multiple devision by 2
7729 c theti22=0.5d0*theta(i)
7730 C theta 12 is the theta_1 /2
7731 C theta 22 is theta_2 /2
7732 c theti12=0.5d0*theta(i-1)
7733 C and appropriate sinus function
7734 sinthet1=dsin(theta(i-1))
7735 sinthet2=dsin(theta(i))
7736 costhet1=dcos(theta(i-1))
7737 costhet2=dcos(theta(i))
7738 C to speed up lets store its mutliplication
7739 sint1t2=sinthet2*sinthet1
7741 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7742 C +d_n*sin(n*gamma)) *
7743 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7744 C we have two sum 1) Non-Chebyshev which is with n and gamma
7745 nval=nterm_kcc_Tb(itori,itori1)
7751 c1(j)=c1(j-1)*costhet1
7752 c2(j)=c2(j-1)*costhet2
7755 do j=1,nterm_kcc(itori,itori1)
7759 sint1t2n=sint1t2n*sint1t2
7765 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7766 gradvalct1=gradvalct1+
7767 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7768 gradvalct2=gradvalct2+
7769 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7772 gradvalct1=-gradvalct1*sinthet1
7773 gradvalct2=-gradvalct2*sinthet2
7779 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7780 gradvalst1=gradvalst1+
7781 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7782 gradvalst2=gradvalst2+
7783 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7786 gradvalst1=-gradvalst1*sinthet1
7787 gradvalst2=-gradvalst2*sinthet2
7788 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7789 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7790 C glocig is the gradient local i site in gamma
7791 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7792 C now gradient over theta_1
7793 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7794 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7795 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7796 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7799 C derivative over gamma
7800 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7801 C derivative over theta1
7802 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7803 C now derivative over theta2
7804 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7806 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7807 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7808 write (iout,*) "c1",(c1(k),k=0,nval),
7809 & " c2",(c2(k),k=0,nval)
7814 c---------------------------------------------------------------------------------------------
7815 subroutine etor_constr(edihcnstr)
7816 implicit real*8 (a-h,o-z)
7817 include 'DIMENSIONS'
7818 include 'COMMON.VAR'
7819 include 'COMMON.GEO'
7820 include 'COMMON.LOCAL'
7821 include 'COMMON.TORSION'
7822 include 'COMMON.INTERACT'
7823 include 'COMMON.DERIV'
7824 include 'COMMON.CHAIN'
7825 include 'COMMON.NAMES'
7826 include 'COMMON.IOUNITS'
7827 include 'COMMON.FFIELD'
7828 include 'COMMON.TORCNSTR'
7829 include 'COMMON.BOUNDS'
7830 include 'COMMON.CONTROL'
7831 ! 6/20/98 - dihedral angle constraints
7833 c do i=1,ndih_constr
7834 if (raw_psipred) then
7835 do i=idihconstr_start,idihconstr_end
7836 itori=idih_constr(i)
7838 gaudih_i=vpsipred(1,i)
7842 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7843 dexpcos_i=dexp(-cos_i*cos_i)
7844 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7845 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7846 & *cos_i*dexpcos_i/s**2
7848 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7849 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7851 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7852 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7853 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7854 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7855 & -wdihc*dlog(gaudih_i)
7859 do i=idihconstr_start,idihconstr_end
7860 itori=idih_constr(i)
7862 difi=pinorm(phii-phi0(i))
7863 if (difi.gt.drange(i)) then
7865 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7866 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7867 else if (difi.lt.-drange(i)) then
7869 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7870 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7880 c----------------------------------------------------------------------------
7881 c MODELLER restraint function
7882 subroutine e_modeller(ehomology_constr)
7884 include 'DIMENSIONS'
7886 double precision ehomology_constr
7887 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7888 integer katy, odleglosci, test7
7889 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7891 real*8 distance(max_template),distancek(max_template),
7892 & min_odl,godl(max_template),dih_diff(max_template)
7895 c FP - 30/10/2014 Temporary specifications for homology restraints
7897 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7899 double precision, dimension (maxres) :: guscdiff,usc_diff
7900 double precision, dimension (max_template) ::
7901 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7903 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7904 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7905 & betai,sum_sgodl,dij
7906 double precision dist,pinorm
7908 include 'COMMON.SBRIDGE'
7909 include 'COMMON.CHAIN'
7910 include 'COMMON.GEO'
7911 include 'COMMON.DERIV'
7912 include 'COMMON.LOCAL'
7913 include 'COMMON.INTERACT'
7914 include 'COMMON.VAR'
7915 include 'COMMON.IOUNITS'
7916 c include 'COMMON.MD'
7917 include 'COMMON.CONTROL'
7918 include 'COMMON.HOMOLOGY'
7919 include 'COMMON.QRESTR'
7921 c From subroutine Econstr_back
7923 include 'COMMON.NAMES'
7924 include 'COMMON.TIME1'
7929 distancek(i)=9999999.9
7935 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7937 C AL 5/2/14 - Introduce list of restraints
7938 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7940 write(iout,*) "------- dist restrs start -------"
7942 do ii = link_start_homo,link_end_homo
7946 c write (iout,*) "dij(",i,j,") =",dij
7948 do k=1,constr_homology
7949 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7950 if(.not.l_homo(k,ii)) then
7954 distance(k)=odl(k,ii)-dij
7955 c write (iout,*) "distance(",k,") =",distance(k)
7957 c For Gaussian-type Urestr
7959 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7960 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7961 c write (iout,*) "distancek(",k,") =",distancek(k)
7962 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7964 c For Lorentzian-type Urestr
7966 if (waga_dist.lt.0.0d0) then
7967 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7968 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7969 & (distance(k)**2+sigma_odlir(k,ii)**2))
7973 c min_odl=minval(distancek)
7977 do kk=1,constr_homology
7978 if(l_homo(kk,ii)) then
7979 min_odl=distancek(kk)
7983 do kk=1,constr_homology
7984 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7985 & min_odl=distancek(kk)
7989 c write (iout,* )"min_odl",min_odl
7991 write (iout,*) "ij dij",i,j,dij
7992 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7993 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7994 write (iout,* )"min_odl",min_odl
7999 if (waga_dist.ge.0.0d0) then
8005 do k=1,constr_homology
8006 c Nie wiem po co to liczycie jeszcze raz!
8007 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8008 c & (2*(sigma_odl(i,j,k))**2))
8009 if(.not.l_homo(k,ii)) cycle
8010 if (waga_dist.ge.0.0d0) then
8012 c For Gaussian-type Urestr
8014 godl(k)=dexp(-distancek(k)+min_odl)
8015 odleg2=odleg2+godl(k)
8017 c For Lorentzian-type Urestr
8020 odleg2=odleg2+distancek(k)
8023 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8024 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8025 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8026 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8029 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8030 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8032 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8033 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8035 if (waga_dist.ge.0.0d0) then
8037 c For Gaussian-type Urestr
8039 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8041 c For Lorentzian-type Urestr
8044 odleg=odleg+odleg2/constr_homology
8047 c write (iout,*) "odleg",odleg ! sum of -ln-s
8050 c For Gaussian-type Urestr
8052 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8054 do k=1,constr_homology
8055 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8056 c & *waga_dist)+min_odl
8057 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8059 if(.not.l_homo(k,ii)) cycle
8060 if (waga_dist.ge.0.0d0) then
8061 c For Gaussian-type Urestr
8063 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8065 c For Lorentzian-type Urestr
8068 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8069 & sigma_odlir(k,ii)**2)**2)
8071 sum_sgodl=sum_sgodl+sgodl
8073 c sgodl2=sgodl2+sgodl
8074 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8075 c write(iout,*) "constr_homology=",constr_homology
8076 c write(iout,*) i, j, k, "TEST K"
8078 if (waga_dist.ge.0.0d0) then
8080 c For Gaussian-type Urestr
8082 grad_odl3=waga_homology(iset)*waga_dist
8083 & *sum_sgodl/(sum_godl*dij)
8085 c For Lorentzian-type Urestr
8088 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8089 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8090 grad_odl3=-waga_homology(iset)*waga_dist*
8091 & sum_sgodl/(constr_homology*dij)
8094 c grad_odl3=sum_sgodl/(sum_godl*dij)
8097 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8098 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8099 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8101 ccc write(iout,*) godl, sgodl, grad_odl3
8103 c grad_odl=grad_odl+grad_odl3
8106 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8107 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8108 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8109 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8110 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8111 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8112 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8113 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8114 c if (i.eq.25.and.j.eq.27) then
8115 c write(iout,*) "jik",jik,"i",i,"j",j
8116 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8117 c write(iout,*) "grad_odl3",grad_odl3
8118 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8119 c write(iout,*) "ggodl",ggodl
8120 c write(iout,*) "ghpbc(",jik,i,")",
8121 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8125 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8126 ccc & dLOG(odleg2),"-odleg=", -odleg
8128 enddo ! ii-loop for dist
8130 write(iout,*) "------- dist restrs end -------"
8131 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8132 c & waga_d.eq.1.0d0) call sum_gradient
8134 c Pseudo-energy and gradient from dihedral-angle restraints from
8135 c homology templates
8136 c write (iout,*) "End of distance loop"
8139 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8141 write(iout,*) "------- dih restrs start -------"
8142 do i=idihconstr_start_homo,idihconstr_end_homo
8143 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8146 do i=idihconstr_start_homo,idihconstr_end_homo
8148 c betai=beta(i,i+1,i+2,i+3)
8150 c write (iout,*) "betai =",betai
8151 do k=1,constr_homology
8152 dih_diff(k)=pinorm(dih(k,i)-betai)
8153 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8154 cd & ,sigma_dih(k,i)
8155 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8156 c & -(6.28318-dih_diff(i,k))
8157 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8158 c & 6.28318+dih_diff(i,k)
8160 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8162 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8164 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8167 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8170 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8171 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8173 write (iout,*) "i",i," betai",betai," kat2",kat2
8174 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8176 if (kat2.le.1.0d-14) cycle
8177 kat=kat-dLOG(kat2/constr_homology)
8178 c write (iout,*) "kat",kat ! sum of -ln-s
8180 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8181 ccc & dLOG(kat2), "-kat=", -kat
8183 c ----------------------------------------------------------------------
8185 c ----------------------------------------------------------------------
8189 do k=1,constr_homology
8191 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8193 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8195 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8196 sum_sgdih=sum_sgdih+sgdih
8198 c grad_dih3=sum_sgdih/sum_gdih
8199 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8201 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8202 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8203 ccc & gloc(nphi+i-3,icg)
8204 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8206 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8208 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8209 ccc & gloc(nphi+i-3,icg)
8211 enddo ! i-loop for dih
8213 write(iout,*) "------- dih restrs end -------"
8216 c Pseudo-energy and gradient for theta angle restraints from
8217 c homology templates
8218 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8222 c For constr_homology reference structures (FP)
8224 c Uconst_back_tot=0.0d0
8227 c Econstr_back legacy
8229 c do i=ithet_start,ithet_end
8232 c do i=loc_start,loc_end
8235 duscdiffx(j,i)=0.0d0
8240 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8241 c write (iout,*) "waga_theta",waga_theta
8242 if (waga_theta.gt.0.0d0) then
8244 write (iout,*) "usampl",usampl
8245 write(iout,*) "------- theta restrs start -------"
8246 c do i=ithet_start,ithet_end
8247 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8250 c write (iout,*) "maxres",maxres,"nres",nres
8252 do i=ithet_start,ithet_end
8255 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8257 c Deviation of theta angles wrt constr_homology ref structures
8259 utheta_i=0.0d0 ! argument of Gaussian for single k
8260 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8261 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8262 c over residues in a fragment
8263 c write (iout,*) "theta(",i,")=",theta(i)
8264 do k=1,constr_homology
8266 c dtheta_i=theta(j)-thetaref(j,iref)
8267 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8268 theta_diff(k)=thetatpl(k,i)-theta(i)
8269 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8270 cd & ,sigma_theta(k,i)
8273 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8274 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8275 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8276 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8277 c Gradient for single Gaussian restraint in subr Econstr_back
8278 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8281 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8282 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8285 c Gradient for multiple Gaussian restraint
8286 sum_gtheta=gutheta_i
8288 do k=1,constr_homology
8289 c New generalized expr for multiple Gaussian from Econstr_back
8290 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8292 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8293 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8295 c Final value of gradient using same var as in Econstr_back
8296 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8297 & +sum_sgtheta/sum_gtheta*waga_theta
8298 & *waga_homology(iset)
8299 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8300 c & *waga_homology(iset)
8301 c dutheta(i)=sum_sgtheta/sum_gtheta
8303 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8304 Eval=Eval-dLOG(gutheta_i/constr_homology)
8305 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8306 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8307 c Uconst_back=Uconst_back+utheta(i)
8308 enddo ! (i-loop for theta)
8310 write(iout,*) "------- theta restrs end -------"
8314 c Deviation of local SC geometry
8316 c Separation of two i-loops (instructed by AL - 11/3/2014)
8318 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8319 c write (iout,*) "waga_d",waga_d
8322 write(iout,*) "------- SC restrs start -------"
8323 write (iout,*) "Initial duscdiff,duscdiffx"
8324 do i=loc_start,loc_end
8325 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8326 & (duscdiffx(jik,i),jik=1,3)
8329 do i=loc_start,loc_end
8330 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8331 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8332 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8333 c write(iout,*) "xxtab, yytab, zztab"
8334 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8335 do k=1,constr_homology
8337 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8338 c Original sign inverted for calc of gradients (s. Econstr_back)
8339 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8340 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8341 c write(iout,*) "dxx, dyy, dzz"
8342 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8344 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8345 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8346 c uscdiffk(k)=usc_diff(i)
8347 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8348 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8349 c & " guscdiff2",guscdiff2(k)
8350 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8351 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8352 c & xxref(j),yyref(j),zzref(j)
8357 c Generalized expression for multiple Gaussian acc to that for a single
8358 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8360 c Original implementation
8361 c sum_guscdiff=guscdiff(i)
8363 c sum_sguscdiff=0.0d0
8364 c do k=1,constr_homology
8365 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8366 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8367 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8370 c Implementation of new expressions for gradient (Jan. 2015)
8372 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8373 do k=1,constr_homology
8375 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8376 c before. Now the drivatives should be correct
8378 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8379 c Original sign inverted for calc of gradients (s. Econstr_back)
8380 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8381 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8383 c New implementation
8385 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8386 & sigma_d(k,i) ! for the grad wrt r'
8387 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8390 c New implementation
8391 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8393 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8394 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8395 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8396 duscdiff(jik,i)=duscdiff(jik,i)+
8397 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8398 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8399 duscdiffx(jik,i)=duscdiffx(jik,i)+
8400 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8401 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8404 write(iout,*) "jik",jik,"i",i
8405 write(iout,*) "dxx, dyy, dzz"
8406 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8407 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8408 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8409 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8410 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8411 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8412 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8413 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8414 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8415 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8416 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8417 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8418 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8419 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8420 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8426 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8427 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8429 c write (iout,*) i," uscdiff",uscdiff(i)
8431 c Put together deviations from local geometry
8433 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8434 c & wfrag_back(3,i,iset)*uscdiff(i)
8435 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8436 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8437 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8438 c Uconst_back=Uconst_back+usc_diff(i)
8440 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8442 c New implment: multiplied by sum_sguscdiff
8445 enddo ! (i-loop for dscdiff)
8450 write(iout,*) "------- SC restrs end -------"
8451 write (iout,*) "------ After SC loop in e_modeller ------"
8452 do i=loc_start,loc_end
8453 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8454 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8456 if (waga_theta.eq.1.0d0) then
8457 write (iout,*) "in e_modeller after SC restr end: dutheta"
8458 do i=ithet_start,ithet_end
8459 write (iout,*) i,dutheta(i)
8462 if (waga_d.eq.1.0d0) then
8463 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8465 write (iout,*) i,(duscdiff(j,i),j=1,3)
8466 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8471 c Total energy from homology restraints
8473 write (iout,*) "odleg",odleg," kat",kat
8476 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8478 c ehomology_constr=odleg+kat
8480 c For Lorentzian-type Urestr
8483 if (waga_dist.ge.0.0d0) then
8485 c For Gaussian-type Urestr
8487 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8488 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8489 c write (iout,*) "ehomology_constr=",ehomology_constr
8492 c For Lorentzian-type Urestr
8494 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8495 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8496 c write (iout,*) "ehomology_constr=",ehomology_constr
8499 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8500 & "Eval",waga_theta,eval,
8501 & "Erot",waga_d,Erot
8502 write (iout,*) "ehomology_constr",ehomology_constr
8508 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8509 747 format(a12,i4,i4,i4,f8.3,f8.3)
8510 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8511 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8512 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8513 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8515 c----------------------------------------------------------------------------
8516 C The rigorous attempt to derive energy function
8517 subroutine ebend_kcc(etheta)
8519 implicit real*8 (a-h,o-z)
8520 include 'DIMENSIONS'
8521 include 'COMMON.VAR'
8522 include 'COMMON.GEO'
8523 include 'COMMON.LOCAL'
8524 include 'COMMON.TORSION'
8525 include 'COMMON.INTERACT'
8526 include 'COMMON.DERIV'
8527 include 'COMMON.CHAIN'
8528 include 'COMMON.NAMES'
8529 include 'COMMON.IOUNITS'
8530 include 'COMMON.FFIELD'
8531 include 'COMMON.TORCNSTR'
8532 include 'COMMON.CONTROL'
8534 double precision thybt1(maxang_kcc)
8535 C Set lprn=.true. for debugging
8538 C print *,"wchodze kcc"
8539 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8541 do i=ithet_start,ithet_end
8542 c print *,i,itype(i-1),itype(i),itype(i-2)
8543 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8544 & .or.itype(i).eq.ntyp1) cycle
8545 iti=iabs(itortyp(itype(i-1)))
8546 sinthet=dsin(theta(i))
8547 costhet=dcos(theta(i))
8548 do j=1,nbend_kcc_Tb(iti)
8549 thybt1(j)=v1bend_chyb(j,iti)
8551 sumth1thyb=v1bend_chyb(0,iti)+
8552 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8553 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8555 ihelp=nbend_kcc_Tb(iti)-1
8556 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8557 etheta=etheta+sumth1thyb
8558 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8559 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8563 c-------------------------------------------------------------------------------------
8564 subroutine etheta_constr(ethetacnstr)
8566 implicit real*8 (a-h,o-z)
8567 include 'DIMENSIONS'
8568 include 'COMMON.VAR'
8569 include 'COMMON.GEO'
8570 include 'COMMON.LOCAL'
8571 include 'COMMON.TORSION'
8572 include 'COMMON.INTERACT'
8573 include 'COMMON.DERIV'
8574 include 'COMMON.CHAIN'
8575 include 'COMMON.NAMES'
8576 include 'COMMON.IOUNITS'
8577 include 'COMMON.FFIELD'
8578 include 'COMMON.TORCNSTR'
8579 include 'COMMON.CONTROL'
8581 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8582 do i=ithetaconstr_start,ithetaconstr_end
8583 itheta=itheta_constr(i)
8584 thetiii=theta(itheta)
8585 difi=pinorm(thetiii-theta_constr0(i))
8586 if (difi.gt.theta_drange(i)) then
8587 difi=difi-theta_drange(i)
8588 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8589 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8590 & +for_thet_constr(i)*difi**3
8591 else if (difi.lt.-drange(i)) then
8593 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8594 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8595 & +for_thet_constr(i)*difi**3
8599 if (energy_dec) then
8600 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8601 & i,itheta,rad2deg*thetiii,
8602 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8603 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8604 & gloc(itheta+nphi-2,icg)
8609 c------------------------------------------------------------------------------
8610 subroutine eback_sc_corr(esccor)
8611 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8612 c conformational states; temporarily implemented as differences
8613 c between UNRES torsional potentials (dependent on three types of
8614 c residues) and the torsional potentials dependent on all 20 types
8615 c of residues computed from AM1 energy surfaces of terminally-blocked
8616 c amino-acid residues.
8617 implicit real*8 (a-h,o-z)
8618 include 'DIMENSIONS'
8619 include 'COMMON.VAR'
8620 include 'COMMON.GEO'
8621 include 'COMMON.LOCAL'
8622 include 'COMMON.TORSION'
8623 include 'COMMON.SCCOR'
8624 include 'COMMON.INTERACT'
8625 include 'COMMON.DERIV'
8626 include 'COMMON.CHAIN'
8627 include 'COMMON.NAMES'
8628 include 'COMMON.IOUNITS'
8629 include 'COMMON.FFIELD'
8630 include 'COMMON.CONTROL'
8632 C Set lprn=.true. for debugging
8635 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8637 do i=itau_start,itau_end
8638 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8640 isccori=isccortyp(itype(i-2))
8641 isccori1=isccortyp(itype(i-1))
8642 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8644 do intertyp=1,3 !intertyp
8645 cc Added 09 May 2012 (Adasko)
8646 cc Intertyp means interaction type of backbone mainchain correlation:
8647 c 1 = SC...Ca...Ca...Ca
8648 c 2 = Ca...Ca...Ca...SC
8649 c 3 = SC...Ca...Ca...SCi
8651 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8652 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8653 & (itype(i-1).eq.ntyp1)))
8654 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8655 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8656 & .or.(itype(i).eq.ntyp1)))
8657 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8658 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8659 & (itype(i-3).eq.ntyp1)))) cycle
8660 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8661 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8663 do j=1,nterm_sccor(isccori,isccori1)
8664 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8665 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8666 cosphi=dcos(j*tauangle(intertyp,i))
8667 sinphi=dsin(j*tauangle(intertyp,i))
8668 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8669 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8671 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8672 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8674 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8675 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8676 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8677 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8678 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8685 c----------------------------------------------------------------------------
8686 subroutine multibody(ecorr)
8687 C This subroutine calculates multi-body contributions to energy following
8688 C the idea of Skolnick et al. If side chains I and J make a contact and
8689 C at the same time side chains I+1 and J+1 make a contact, an extra
8690 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8691 implicit real*8 (a-h,o-z)
8692 include 'DIMENSIONS'
8693 include 'COMMON.IOUNITS'
8694 include 'COMMON.DERIV'
8695 include 'COMMON.INTERACT'
8696 include 'COMMON.CONTACTS'
8697 include 'COMMON.CONTMAT'
8698 include 'COMMON.CORRMAT'
8699 double precision gx(3),gx1(3)
8702 C Set lprn=.true. for debugging
8706 write (iout,'(a)') 'Contact function values:'
8708 write (iout,'(i2,20(1x,i2,f10.5))')
8709 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8724 num_conti=num_cont(i)
8725 num_conti1=num_cont(i1)
8730 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8731 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8732 cd & ' ishift=',ishift
8733 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8734 C The system gains extra energy.
8735 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8736 endif ! j1==j+-ishift
8745 c------------------------------------------------------------------------------
8746 double precision function esccorr(i,j,k,l,jj,kk)
8747 implicit real*8 (a-h,o-z)
8748 include 'DIMENSIONS'
8749 include 'COMMON.IOUNITS'
8750 include 'COMMON.DERIV'
8751 include 'COMMON.INTERACT'
8752 include 'COMMON.CONTACTS'
8753 include 'COMMON.CONTMAT'
8754 include 'COMMON.CORRMAT'
8755 include 'COMMON.SHIELD'
8756 double precision gx(3),gx1(3)
8761 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8762 C Calculate the multi-body contribution to energy.
8763 C Calculate multi-body contributions to the gradient.
8764 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8765 cd & k,l,(gacont(m,kk,k),m=1,3)
8767 gx(m) =ekl*gacont(m,jj,i)
8768 gx1(m)=eij*gacont(m,kk,k)
8769 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8770 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8771 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8772 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8776 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8781 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8787 c------------------------------------------------------------------------------
8788 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8789 C This subroutine calculates multi-body contributions to hydrogen-bonding
8790 implicit real*8 (a-h,o-z)
8791 include 'DIMENSIONS'
8792 include 'COMMON.IOUNITS'
8795 parameter (max_cont=maxconts)
8796 parameter (max_dim=26)
8797 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8798 double precision zapas(max_dim,maxconts,max_fg_procs),
8799 & zapas_recv(max_dim,maxconts,max_fg_procs)
8800 common /przechowalnia/ zapas
8801 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8802 & status_array(MPI_STATUS_SIZE,maxconts*2)
8804 include 'COMMON.SETUP'
8805 include 'COMMON.FFIELD'
8806 include 'COMMON.DERIV'
8807 include 'COMMON.INTERACT'
8808 include 'COMMON.CONTACTS'
8809 include 'COMMON.CONTMAT'
8810 include 'COMMON.CORRMAT'
8811 include 'COMMON.CONTROL'
8812 include 'COMMON.LOCAL'
8813 double precision gx(3),gx1(3),time00
8816 C Set lprn=.true. for debugging
8821 if (nfgtasks.le.1) goto 30
8823 write (iout,'(a)') 'Contact function values before RECEIVE:'
8825 write (iout,'(2i3,50(1x,i2,f5.2))')
8826 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8827 & j=1,num_cont_hb(i))
8831 do i=1,ntask_cont_from
8834 do i=1,ntask_cont_to
8837 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8839 C Make the list of contacts to send to send to other procesors
8840 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8842 do i=iturn3_start,iturn3_end
8843 c write (iout,*) "make contact list turn3",i," num_cont",
8845 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8847 do i=iturn4_start,iturn4_end
8848 c write (iout,*) "make contact list turn4",i," num_cont",
8850 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8854 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8856 do j=1,num_cont_hb(i)
8859 iproc=iint_sent_local(k,jjc,ii)
8860 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8861 if (iproc.gt.0) then
8862 ncont_sent(iproc)=ncont_sent(iproc)+1
8863 nn=ncont_sent(iproc)
8865 zapas(2,nn,iproc)=jjc
8866 zapas(3,nn,iproc)=facont_hb(j,i)
8867 zapas(4,nn,iproc)=ees0p(j,i)
8868 zapas(5,nn,iproc)=ees0m(j,i)
8869 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8870 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8871 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8872 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8873 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8874 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8875 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8876 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8877 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8878 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8879 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8880 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8881 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8882 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8883 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8884 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8885 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8886 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8887 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8888 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8889 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8896 & "Numbers of contacts to be sent to other processors",
8897 & (ncont_sent(i),i=1,ntask_cont_to)
8898 write (iout,*) "Contacts sent"
8899 do ii=1,ntask_cont_to
8901 iproc=itask_cont_to(ii)
8902 write (iout,*) nn," contacts to processor",iproc,
8903 & " of CONT_TO_COMM group"
8905 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8913 CorrelID1=nfgtasks+fg_rank+1
8915 C Receive the numbers of needed contacts from other processors
8916 do ii=1,ntask_cont_from
8917 iproc=itask_cont_from(ii)
8919 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8920 & FG_COMM,req(ireq),IERR)
8922 c write (iout,*) "IRECV ended"
8924 C Send the number of contacts needed by other processors
8925 do ii=1,ntask_cont_to
8926 iproc=itask_cont_to(ii)
8928 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8929 & FG_COMM,req(ireq),IERR)
8931 c write (iout,*) "ISEND ended"
8932 c write (iout,*) "number of requests (nn)",ireq
8935 & call MPI_Waitall(ireq,req,status_array,ierr)
8937 c & "Numbers of contacts to be received from other processors",
8938 c & (ncont_recv(i),i=1,ntask_cont_from)
8942 do ii=1,ntask_cont_from
8943 iproc=itask_cont_from(ii)
8945 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8946 c & " of CONT_TO_COMM group"
8950 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8951 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8952 c write (iout,*) "ireq,req",ireq,req(ireq)
8955 C Send the contacts to processors that need them
8956 do ii=1,ntask_cont_to
8957 iproc=itask_cont_to(ii)
8959 c write (iout,*) nn," contacts to processor",iproc,
8960 c & " of CONT_TO_COMM group"
8963 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8964 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8965 c write (iout,*) "ireq,req",ireq,req(ireq)
8967 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8971 c write (iout,*) "number of requests (contacts)",ireq
8972 c write (iout,*) "req",(req(i),i=1,4)
8975 & call MPI_Waitall(ireq,req,status_array,ierr)
8976 do iii=1,ntask_cont_from
8977 iproc=itask_cont_from(iii)
8980 write (iout,*) "Received",nn," contacts from processor",iproc,
8981 & " of CONT_FROM_COMM group"
8984 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8989 ii=zapas_recv(1,i,iii)
8990 c Flag the received contacts to prevent double-counting
8991 jj=-zapas_recv(2,i,iii)
8992 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8994 nnn=num_cont_hb(ii)+1
8997 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8998 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8999 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9000 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9001 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9002 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9003 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9004 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9005 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9006 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9007 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9008 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9009 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9010 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9011 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9012 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9013 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9014 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9015 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9016 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9017 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9018 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9019 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9020 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9024 write (iout,'(a)') 'Contact function values after receive:'
9026 write (iout,'(2i3,50(1x,i3,f5.2))')
9027 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9028 & j=1,num_cont_hb(i))
9035 write (iout,'(a)') 'Contact function values:'
9037 write (iout,'(2i3,50(1x,i3,f5.2))')
9038 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9039 & j=1,num_cont_hb(i))
9044 C Remove the loop below after debugging !!!
9051 C Calculate the local-electrostatic correlation terms
9052 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9054 num_conti=num_cont_hb(i)
9055 num_conti1=num_cont_hb(i+1)
9062 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9063 c & ' jj=',jj,' kk=',kk
9065 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9066 & .or. j.lt.0 .and. j1.gt.0) .and.
9067 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9068 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9069 C The system gains extra energy.
9070 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9071 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9072 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9074 else if (j1.eq.j) then
9075 C Contacts I-J and I-(J+1) occur simultaneously.
9076 C The system loses extra energy.
9077 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9082 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9083 c & ' jj=',jj,' kk=',kk
9085 C Contacts I-J and (I+1)-J occur simultaneously.
9086 C The system loses extra energy.
9087 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9094 c------------------------------------------------------------------------------
9095 subroutine add_hb_contact(ii,jj,itask)
9096 implicit real*8 (a-h,o-z)
9097 include "DIMENSIONS"
9098 include "COMMON.IOUNITS"
9101 parameter (max_cont=maxconts)
9102 parameter (max_dim=26)
9103 include "COMMON.CONTACTS"
9104 include 'COMMON.CONTMAT'
9105 include 'COMMON.CORRMAT'
9106 double precision zapas(max_dim,maxconts,max_fg_procs),
9107 & zapas_recv(max_dim,maxconts,max_fg_procs)
9108 common /przechowalnia/ zapas
9109 integer i,j,ii,jj,iproc,itask(4),nn
9110 c write (iout,*) "itask",itask
9113 if (iproc.gt.0) then
9114 do j=1,num_cont_hb(ii)
9116 c write (iout,*) "i",ii," j",jj," jjc",jjc
9118 ncont_sent(iproc)=ncont_sent(iproc)+1
9119 nn=ncont_sent(iproc)
9120 zapas(1,nn,iproc)=ii
9121 zapas(2,nn,iproc)=jjc
9122 zapas(3,nn,iproc)=facont_hb(j,ii)
9123 zapas(4,nn,iproc)=ees0p(j,ii)
9124 zapas(5,nn,iproc)=ees0m(j,ii)
9125 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9126 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9127 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9128 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9129 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9130 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9131 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9132 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9133 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9134 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9135 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9136 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9137 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9138 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9139 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9140 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9141 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9142 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9143 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9144 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9145 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9153 c------------------------------------------------------------------------------
9154 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9156 C This subroutine calculates multi-body contributions to hydrogen-bonding
9157 implicit real*8 (a-h,o-z)
9158 include 'DIMENSIONS'
9159 include 'COMMON.IOUNITS'
9162 parameter (max_cont=maxconts)
9163 parameter (max_dim=70)
9164 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9165 double precision zapas(max_dim,maxconts,max_fg_procs),
9166 & zapas_recv(max_dim,maxconts,max_fg_procs)
9167 common /przechowalnia/ zapas
9168 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9169 & status_array(MPI_STATUS_SIZE,maxconts*2)
9171 include 'COMMON.SETUP'
9172 include 'COMMON.FFIELD'
9173 include 'COMMON.DERIV'
9174 include 'COMMON.LOCAL'
9175 include 'COMMON.INTERACT'
9176 include 'COMMON.CONTACTS'
9177 include 'COMMON.CONTMAT'
9178 include 'COMMON.CORRMAT'
9179 include 'COMMON.CHAIN'
9180 include 'COMMON.CONTROL'
9181 include 'COMMON.SHIELD'
9182 double precision gx(3),gx1(3)
9183 integer num_cont_hb_old(maxres)
9185 double precision eello4,eello5,eelo6,eello_turn6
9186 external eello4,eello5,eello6,eello_turn6
9187 C Set lprn=.true. for debugging
9192 num_cont_hb_old(i)=num_cont_hb(i)
9196 if (nfgtasks.le.1) goto 30
9198 write (iout,'(a)') 'Contact function values before RECEIVE:'
9200 write (iout,'(2i3,50(1x,i2,f5.2))')
9201 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9202 & j=1,num_cont_hb(i))
9205 do i=1,ntask_cont_from
9208 do i=1,ntask_cont_to
9211 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9213 C Make the list of contacts to send to send to other procesors
9214 do i=iturn3_start,iturn3_end
9215 c write (iout,*) "make contact list turn3",i," num_cont",
9217 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9219 do i=iturn4_start,iturn4_end
9220 c write (iout,*) "make contact list turn4",i," num_cont",
9222 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9226 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9228 do j=1,num_cont_hb(i)
9231 iproc=iint_sent_local(k,jjc,ii)
9232 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9233 if (iproc.ne.0) then
9234 ncont_sent(iproc)=ncont_sent(iproc)+1
9235 nn=ncont_sent(iproc)
9237 zapas(2,nn,iproc)=jjc
9238 zapas(3,nn,iproc)=d_cont(j,i)
9242 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9247 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9255 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9266 & "Numbers of contacts to be sent to other processors",
9267 & (ncont_sent(i),i=1,ntask_cont_to)
9268 write (iout,*) "Contacts sent"
9269 do ii=1,ntask_cont_to
9271 iproc=itask_cont_to(ii)
9272 write (iout,*) nn," contacts to processor",iproc,
9273 & " of CONT_TO_COMM group"
9275 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9283 CorrelID1=nfgtasks+fg_rank+1
9285 C Receive the numbers of needed contacts from other processors
9286 do ii=1,ntask_cont_from
9287 iproc=itask_cont_from(ii)
9289 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9290 & FG_COMM,req(ireq),IERR)
9292 c write (iout,*) "IRECV ended"
9294 C Send the number of contacts needed by other processors
9295 do ii=1,ntask_cont_to
9296 iproc=itask_cont_to(ii)
9298 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9299 & FG_COMM,req(ireq),IERR)
9301 c write (iout,*) "ISEND ended"
9302 c write (iout,*) "number of requests (nn)",ireq
9305 & call MPI_Waitall(ireq,req,status_array,ierr)
9307 c & "Numbers of contacts to be received from other processors",
9308 c & (ncont_recv(i),i=1,ntask_cont_from)
9312 do ii=1,ntask_cont_from
9313 iproc=itask_cont_from(ii)
9315 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9316 c & " of CONT_TO_COMM group"
9320 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9321 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9322 c write (iout,*) "ireq,req",ireq,req(ireq)
9325 C Send the contacts to processors that need them
9326 do ii=1,ntask_cont_to
9327 iproc=itask_cont_to(ii)
9329 c write (iout,*) nn," contacts to processor",iproc,
9330 c & " of CONT_TO_COMM group"
9333 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9334 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9335 c write (iout,*) "ireq,req",ireq,req(ireq)
9337 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9341 c write (iout,*) "number of requests (contacts)",ireq
9342 c write (iout,*) "req",(req(i),i=1,4)
9345 & call MPI_Waitall(ireq,req,status_array,ierr)
9346 do iii=1,ntask_cont_from
9347 iproc=itask_cont_from(iii)
9350 write (iout,*) "Received",nn," contacts from processor",iproc,
9351 & " of CONT_FROM_COMM group"
9354 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9359 ii=zapas_recv(1,i,iii)
9360 c Flag the received contacts to prevent double-counting
9361 jj=-zapas_recv(2,i,iii)
9362 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9364 nnn=num_cont_hb(ii)+1
9367 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9371 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9376 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9384 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9392 write (iout,'(a)') 'Contact function values after receive:'
9394 write (iout,'(2i3,50(1x,i3,5f6.3))')
9395 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9396 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9403 write (iout,'(a)') 'Contact function values:'
9405 write (iout,'(2i3,50(1x,i2,5f6.3))')
9406 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9407 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9413 C Remove the loop below after debugging !!!
9420 C Calculate the dipole-dipole interaction energies
9421 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9422 do i=iatel_s,iatel_e+1
9423 num_conti=num_cont_hb(i)
9432 C Calculate the local-electrostatic correlation terms
9433 c write (iout,*) "gradcorr5 in eello5 before loop"
9435 c write (iout,'(i5,3f10.5)')
9436 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9438 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9439 c write (iout,*) "corr loop i",i
9441 num_conti=num_cont_hb(i)
9442 num_conti1=num_cont_hb(i+1)
9449 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9450 c & ' jj=',jj,' kk=',kk
9451 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9452 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9453 & .or. j.lt.0 .and. j1.gt.0) .and.
9454 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9455 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9456 C The system gains extra energy.
9458 sqd1=dsqrt(d_cont(jj,i))
9459 sqd2=dsqrt(d_cont(kk,i1))
9460 sred_geom = sqd1*sqd2
9461 IF (sred_geom.lt.cutoff_corr) THEN
9462 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9464 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9465 cd & ' jj=',jj,' kk=',kk
9466 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9467 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9469 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9470 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9473 cd write (iout,*) 'sred_geom=',sred_geom,
9474 cd & ' ekont=',ekont,' fprim=',fprimcont,
9475 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9476 cd write (iout,*) "g_contij",g_contij
9477 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9478 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9479 call calc_eello(i,jp,i+1,jp1,jj,kk)
9480 if (wcorr4.gt.0.0d0)
9481 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9482 CC & *fac_shield(i)**2*fac_shield(j)**2
9483 if (energy_dec.and.wcorr4.gt.0.0d0)
9484 1 write (iout,'(a6,4i5,0pf7.3)')
9485 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9486 c write (iout,*) "gradcorr5 before eello5"
9488 c write (iout,'(i5,3f10.5)')
9489 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9491 if (wcorr5.gt.0.0d0)
9492 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9493 c write (iout,*) "gradcorr5 after eello5"
9495 c write (iout,'(i5,3f10.5)')
9496 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9498 if (energy_dec.and.wcorr5.gt.0.0d0)
9499 1 write (iout,'(a6,4i5,0pf7.3)')
9500 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9501 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9502 cd write(2,*)'ijkl',i,jp,i+1,jp1
9503 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9504 & .or. wturn6.eq.0.0d0))then
9505 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9506 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9507 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9508 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9509 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9510 cd & 'ecorr6=',ecorr6
9511 cd write (iout,'(4e15.5)') sred_geom,
9512 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9513 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9514 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9515 else if (wturn6.gt.0.0d0
9516 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9517 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9518 eturn6=eturn6+eello_turn6(i,jj,kk)
9519 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9520 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9521 cd write (2,*) 'multibody_eello:eturn6',eturn6
9530 num_cont_hb(i)=num_cont_hb_old(i)
9532 c write (iout,*) "gradcorr5 in eello5"
9534 c write (iout,'(i5,3f10.5)')
9535 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9539 c------------------------------------------------------------------------------
9540 subroutine add_hb_contact_eello(ii,jj,itask)
9541 implicit real*8 (a-h,o-z)
9542 include "DIMENSIONS"
9543 include "COMMON.IOUNITS"
9546 parameter (max_cont=maxconts)
9547 parameter (max_dim=70)
9548 include "COMMON.CONTACTS"
9549 include 'COMMON.CONTMAT'
9550 include 'COMMON.CORRMAT'
9551 double precision zapas(max_dim,maxconts,max_fg_procs),
9552 & zapas_recv(max_dim,maxconts,max_fg_procs)
9553 common /przechowalnia/ zapas
9554 integer i,j,ii,jj,iproc,itask(4),nn
9555 c write (iout,*) "itask",itask
9558 if (iproc.gt.0) then
9559 do j=1,num_cont_hb(ii)
9561 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9563 ncont_sent(iproc)=ncont_sent(iproc)+1
9564 nn=ncont_sent(iproc)
9565 zapas(1,nn,iproc)=ii
9566 zapas(2,nn,iproc)=jjc
9567 zapas(3,nn,iproc)=d_cont(j,ii)
9571 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9576 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9584 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9596 c------------------------------------------------------------------------------
9597 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9598 implicit real*8 (a-h,o-z)
9599 include 'DIMENSIONS'
9600 include 'COMMON.IOUNITS'
9601 include 'COMMON.DERIV'
9602 include 'COMMON.INTERACT'
9603 include 'COMMON.CONTACTS'
9604 include 'COMMON.CONTMAT'
9605 include 'COMMON.CORRMAT'
9606 include 'COMMON.SHIELD'
9607 include 'COMMON.CONTROL'
9608 double precision gx(3),gx1(3)
9611 C print *,"wchodze",fac_shield(i),shield_mode
9619 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9621 C & fac_shield(i)**2*fac_shield(j)**2
9622 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9623 C Following 4 lines for diagnostics.
9628 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9629 c & 'Contacts ',i,j,
9630 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9631 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9633 C Calculate the multi-body contribution to energy.
9634 C ecorr=ecorr+ekont*ees
9635 C Calculate multi-body contributions to the gradient.
9636 coeffpees0pij=coeffp*ees0pij
9637 coeffmees0mij=coeffm*ees0mij
9638 coeffpees0pkl=coeffp*ees0pkl
9639 coeffmees0mkl=coeffm*ees0mkl
9641 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9642 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9643 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9644 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9645 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9646 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9647 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9648 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9649 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9650 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9651 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9652 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9653 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9654 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9655 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9656 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9657 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9658 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9659 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9660 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9661 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9662 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9663 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9664 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9665 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9670 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9671 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9672 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9673 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9678 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9679 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9680 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9681 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9684 c write (iout,*) "ehbcorr",ekont*ees
9685 C print *,ekont,ees,i,k
9687 C now gradient over shielding
9689 if (shield_mode.gt.0) then
9692 C print *,i,j,fac_shield(i),fac_shield(j),
9693 C &fac_shield(k),fac_shield(l)
9694 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9695 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9696 do ilist=1,ishield_list(i)
9697 iresshield=shield_list(ilist,i)
9699 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9701 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9703 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9704 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9708 do ilist=1,ishield_list(j)
9709 iresshield=shield_list(ilist,j)
9711 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9713 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9715 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9716 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9721 do ilist=1,ishield_list(k)
9722 iresshield=shield_list(ilist,k)
9724 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9726 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9728 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9729 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9733 do ilist=1,ishield_list(l)
9734 iresshield=shield_list(ilist,l)
9736 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9738 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9740 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9741 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9745 C print *,gshieldx(m,iresshield)
9747 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9748 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9749 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9750 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9751 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9752 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9753 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9754 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9756 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9757 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9758 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9759 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9760 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9761 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9762 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9763 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9771 C---------------------------------------------------------------------------
9772 subroutine dipole(i,j,jj)
9773 implicit real*8 (a-h,o-z)
9774 include 'DIMENSIONS'
9775 include 'COMMON.IOUNITS'
9776 include 'COMMON.CHAIN'
9777 include 'COMMON.FFIELD'
9778 include 'COMMON.DERIV'
9779 include 'COMMON.INTERACT'
9780 include 'COMMON.CONTACTS'
9781 include 'COMMON.CONTMAT'
9782 include 'COMMON.CORRMAT'
9783 include 'COMMON.TORSION'
9784 include 'COMMON.VAR'
9785 include 'COMMON.GEO'
9786 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9788 iti1 = itortyp(itype(i+1))
9789 if (j.lt.nres-1) then
9790 itj1 = itype2loc(itype(j+1))
9795 dipi(iii,1)=Ub2(iii,i)
9796 dipderi(iii)=Ub2der(iii,i)
9797 dipi(iii,2)=b1(iii,i+1)
9798 dipj(iii,1)=Ub2(iii,j)
9799 dipderj(iii)=Ub2der(iii,j)
9800 dipj(iii,2)=b1(iii,j+1)
9804 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9807 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9814 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9818 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9823 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9824 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9826 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9828 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9830 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9835 C---------------------------------------------------------------------------
9836 subroutine calc_eello(i,j,k,l,jj,kk)
9838 C This subroutine computes matrices and vectors needed to calculate
9839 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9841 implicit real*8 (a-h,o-z)
9842 include 'DIMENSIONS'
9843 include 'COMMON.IOUNITS'
9844 include 'COMMON.CHAIN'
9845 include 'COMMON.DERIV'
9846 include 'COMMON.INTERACT'
9847 include 'COMMON.CONTACTS'
9848 include 'COMMON.CONTMAT'
9849 include 'COMMON.CORRMAT'
9850 include 'COMMON.TORSION'
9851 include 'COMMON.VAR'
9852 include 'COMMON.GEO'
9853 include 'COMMON.FFIELD'
9854 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9855 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9858 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9859 cd & ' jj=',jj,' kk=',kk
9860 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9861 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9862 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9865 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9866 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9869 call transpose2(aa1(1,1),aa1t(1,1))
9870 call transpose2(aa2(1,1),aa2t(1,1))
9873 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9874 & aa1tder(1,1,lll,kkk))
9875 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9876 & aa2tder(1,1,lll,kkk))
9880 C parallel orientation of the two CA-CA-CA frames.
9882 iti=itype2loc(itype(i))
9886 itk1=itype2loc(itype(k+1))
9887 itj=itype2loc(itype(j))
9888 if (l.lt.nres-1) then
9889 itl1=itype2loc(itype(l+1))
9893 C A1 kernel(j+1) A2T
9895 cd write (iout,'(3f10.5,5x,3f10.5)')
9896 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9898 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9899 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9900 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9901 C Following matrices are needed only for 6-th order cumulants
9902 IF (wcorr6.gt.0.0d0) THEN
9903 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9904 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9905 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9906 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9907 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9908 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9909 & ADtEAderx(1,1,1,1,1,1))
9911 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9912 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9913 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9914 & ADtEA1derx(1,1,1,1,1,1))
9916 C End 6-th order cumulants
9919 cd write (2,*) 'In calc_eello6'
9921 cd write (2,*) 'iii=',iii
9923 cd write (2,*) 'kkk=',kkk
9925 cd write (2,'(3(2f10.5),5x)')
9926 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9931 call transpose2(EUgder(1,1,k),auxmat(1,1))
9932 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9933 call transpose2(EUg(1,1,k),auxmat(1,1))
9934 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9935 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9936 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9937 c in theta; to be sriten later.
9939 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9940 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9941 c call transpose2(EUg(1,1,k),auxmat(1,1))
9942 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9947 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9948 & EAEAderx(1,1,lll,kkk,iii,1))
9952 C A1T kernel(i+1) A2
9953 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9954 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9955 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9956 C Following matrices are needed only for 6-th order cumulants
9957 IF (wcorr6.gt.0.0d0) THEN
9958 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9959 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9960 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9961 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9962 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9963 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9964 & ADtEAderx(1,1,1,1,1,2))
9965 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9966 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9967 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9968 & ADtEA1derx(1,1,1,1,1,2))
9970 C End 6-th order cumulants
9971 call transpose2(EUgder(1,1,l),auxmat(1,1))
9972 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9973 call transpose2(EUg(1,1,l),auxmat(1,1))
9974 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9975 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9979 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9980 & EAEAderx(1,1,lll,kkk,iii,2))
9985 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9986 C They are needed only when the fifth- or the sixth-order cumulants are
9988 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9989 call transpose2(AEA(1,1,1),auxmat(1,1))
9990 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9991 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9992 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9993 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9994 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9995 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9996 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9997 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9998 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9999 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10000 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10001 call transpose2(AEA(1,1,2),auxmat(1,1))
10002 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10003 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10004 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10005 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10006 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10007 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10008 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10009 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10010 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10011 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10012 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10013 C Calculate the Cartesian derivatives of the vectors.
10017 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10018 call matvec2(auxmat(1,1),b1(1,i),
10019 & AEAb1derx(1,lll,kkk,iii,1,1))
10020 call matvec2(auxmat(1,1),Ub2(1,i),
10021 & AEAb2derx(1,lll,kkk,iii,1,1))
10022 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10023 & AEAb1derx(1,lll,kkk,iii,2,1))
10024 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10025 & AEAb2derx(1,lll,kkk,iii,2,1))
10026 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10027 call matvec2(auxmat(1,1),b1(1,j),
10028 & AEAb1derx(1,lll,kkk,iii,1,2))
10029 call matvec2(auxmat(1,1),Ub2(1,j),
10030 & AEAb2derx(1,lll,kkk,iii,1,2))
10031 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10032 & AEAb1derx(1,lll,kkk,iii,2,2))
10033 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10034 & AEAb2derx(1,lll,kkk,iii,2,2))
10041 C Antiparallel orientation of the two CA-CA-CA frames.
10043 iti=itype2loc(itype(i))
10047 itk1=itype2loc(itype(k+1))
10048 itl=itype2loc(itype(l))
10049 itj=itype2loc(itype(j))
10050 if (j.lt.nres-1) then
10051 itj1=itype2loc(itype(j+1))
10055 C A2 kernel(j-1)T A1T
10056 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10057 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10058 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10059 C Following matrices are needed only for 6-th order cumulants
10060 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10061 & j.eq.i+4 .and. l.eq.i+3)) THEN
10062 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10063 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10064 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10065 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10066 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10067 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10068 & ADtEAderx(1,1,1,1,1,1))
10069 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10070 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10071 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10072 & ADtEA1derx(1,1,1,1,1,1))
10074 C End 6-th order cumulants
10075 call transpose2(EUgder(1,1,k),auxmat(1,1))
10076 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10077 call transpose2(EUg(1,1,k),auxmat(1,1))
10078 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10079 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10083 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10084 & EAEAderx(1,1,lll,kkk,iii,1))
10088 C A2T kernel(i+1)T A1
10089 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10090 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10091 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10092 C Following matrices are needed only for 6-th order cumulants
10093 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10094 & j.eq.i+4 .and. l.eq.i+3)) THEN
10095 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10096 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10097 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10098 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10099 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10100 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10101 & ADtEAderx(1,1,1,1,1,2))
10102 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10103 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10104 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10105 & ADtEA1derx(1,1,1,1,1,2))
10107 C End 6-th order cumulants
10108 call transpose2(EUgder(1,1,j),auxmat(1,1))
10109 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10110 call transpose2(EUg(1,1,j),auxmat(1,1))
10111 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10112 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10116 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10117 & EAEAderx(1,1,lll,kkk,iii,2))
10122 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10123 C They are needed only when the fifth- or the sixth-order cumulants are
10125 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10126 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10127 call transpose2(AEA(1,1,1),auxmat(1,1))
10128 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10129 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10130 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10131 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10132 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10133 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10134 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10135 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10136 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10137 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10138 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10139 call transpose2(AEA(1,1,2),auxmat(1,1))
10140 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10141 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10142 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10143 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10144 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10145 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10146 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10147 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10148 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10149 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10150 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10151 C Calculate the Cartesian derivatives of the vectors.
10155 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10156 call matvec2(auxmat(1,1),b1(1,i),
10157 & AEAb1derx(1,lll,kkk,iii,1,1))
10158 call matvec2(auxmat(1,1),Ub2(1,i),
10159 & AEAb2derx(1,lll,kkk,iii,1,1))
10160 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10161 & AEAb1derx(1,lll,kkk,iii,2,1))
10162 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10163 & AEAb2derx(1,lll,kkk,iii,2,1))
10164 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10165 call matvec2(auxmat(1,1),b1(1,l),
10166 & AEAb1derx(1,lll,kkk,iii,1,2))
10167 call matvec2(auxmat(1,1),Ub2(1,l),
10168 & AEAb2derx(1,lll,kkk,iii,1,2))
10169 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10170 & AEAb1derx(1,lll,kkk,iii,2,2))
10171 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10172 & AEAb2derx(1,lll,kkk,iii,2,2))
10181 C---------------------------------------------------------------------------
10182 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10183 & KK,KKderg,AKA,AKAderg,AKAderx)
10187 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10188 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10189 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10190 integer iii,kkk,lll
10193 common /kutas/ lprn
10194 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10196 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10197 & AKAderg(1,1,iii))
10199 cd if (lprn) write (2,*) 'In kernel'
10201 cd if (lprn) write (2,*) 'kkk=',kkk
10203 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10204 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10206 cd write (2,*) 'lll=',lll
10207 cd write (2,*) 'iii=1'
10209 cd write (2,'(3(2f10.5),5x)')
10210 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10213 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10214 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10216 cd write (2,*) 'lll=',lll
10217 cd write (2,*) 'iii=2'
10219 cd write (2,'(3(2f10.5),5x)')
10220 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10227 C---------------------------------------------------------------------------
10228 double precision function eello4(i,j,k,l,jj,kk)
10229 implicit real*8 (a-h,o-z)
10230 include 'DIMENSIONS'
10231 include 'COMMON.IOUNITS'
10232 include 'COMMON.CHAIN'
10233 include 'COMMON.DERIV'
10234 include 'COMMON.INTERACT'
10235 include 'COMMON.CONTACTS'
10236 include 'COMMON.CONTMAT'
10237 include 'COMMON.CORRMAT'
10238 include 'COMMON.TORSION'
10239 include 'COMMON.VAR'
10240 include 'COMMON.GEO'
10241 double precision pizda(2,2),ggg1(3),ggg2(3)
10242 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10246 cd print *,'eello4:',i,j,k,l,jj,kk
10247 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10248 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10249 cold eij=facont_hb(jj,i)
10250 cold ekl=facont_hb(kk,k)
10252 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10253 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10254 gcorr_loc(k-1)=gcorr_loc(k-1)
10255 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10257 gcorr_loc(l-1)=gcorr_loc(l-1)
10258 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10259 C Al 4/16/16: Derivatives in theta, to be added later.
10261 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10262 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10265 gcorr_loc(j-1)=gcorr_loc(j-1)
10266 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10268 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10269 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10275 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10276 & -EAEAderx(2,2,lll,kkk,iii,1)
10277 cd derx(lll,kkk,iii)=0.0d0
10281 cd gcorr_loc(l-1)=0.0d0
10282 cd gcorr_loc(j-1)=0.0d0
10283 cd gcorr_loc(k-1)=0.0d0
10285 cd write (iout,*)'Contacts have occurred for peptide groups',
10286 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10287 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10288 if (j.lt.nres-1) then
10295 if (l.lt.nres-1) then
10303 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10304 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10305 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10306 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10307 cgrad ghalf=0.5d0*ggg1(ll)
10308 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10309 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10310 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10311 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10312 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10313 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10314 cgrad ghalf=0.5d0*ggg2(ll)
10315 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10316 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10317 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10318 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10319 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10320 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10324 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10329 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10334 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10339 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10343 cd write (2,*) iii,gcorr_loc(iii)
10346 cd write (2,*) 'ekont',ekont
10347 cd write (iout,*) 'eello4',ekont*eel4
10350 C---------------------------------------------------------------------------
10351 double precision function eello5(i,j,k,l,jj,kk)
10352 implicit real*8 (a-h,o-z)
10353 include 'DIMENSIONS'
10354 include 'COMMON.IOUNITS'
10355 include 'COMMON.CHAIN'
10356 include 'COMMON.DERIV'
10357 include 'COMMON.INTERACT'
10358 include 'COMMON.CONTACTS'
10359 include 'COMMON.CONTMAT'
10360 include 'COMMON.CORRMAT'
10361 include 'COMMON.TORSION'
10362 include 'COMMON.VAR'
10363 include 'COMMON.GEO'
10364 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10365 double precision ggg1(3),ggg2(3)
10366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10368 C Parallel chains C
10371 C /l\ / \ \ / \ / \ / C
10372 C / \ / \ \ / \ / \ / C
10373 C j| o |l1 | o | o| o | | o |o C
10374 C \ |/k\| |/ \| / |/ \| |/ \| C
10375 C \i/ \ / \ / / \ / \ C
10377 C (I) (II) (III) (IV) C
10379 C eello5_1 eello5_2 eello5_3 eello5_4 C
10381 C Antiparallel chains C
10384 C /j\ / \ \ / \ / \ / C
10385 C / \ / \ \ / \ / \ / C
10386 C j1| o |l | o | o| o | | o |o C
10387 C \ |/k\| |/ \| / |/ \| |/ \| C
10388 C \i/ \ / \ / / \ / \ C
10390 C (I) (II) (III) (IV) C
10392 C eello5_1 eello5_2 eello5_3 eello5_4 C
10394 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10396 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10397 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10402 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10404 itk=itype2loc(itype(k))
10405 itl=itype2loc(itype(l))
10406 itj=itype2loc(itype(j))
10411 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10412 cd & eel5_3_num,eel5_4_num)
10416 derx(lll,kkk,iii)=0.0d0
10420 cd eij=facont_hb(jj,i)
10421 cd ekl=facont_hb(kk,k)
10423 cd write (iout,*)'Contacts have occurred for peptide groups',
10424 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10426 C Contribution from the graph I.
10427 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10428 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10429 call transpose2(EUg(1,1,k),auxmat(1,1))
10430 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10431 vv(1)=pizda(1,1)-pizda(2,2)
10432 vv(2)=pizda(1,2)+pizda(2,1)
10433 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10434 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10435 C Explicit gradient in virtual-dihedral angles.
10436 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10437 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10438 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10439 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10440 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10441 vv(1)=pizda(1,1)-pizda(2,2)
10442 vv(2)=pizda(1,2)+pizda(2,1)
10443 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10444 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10445 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10446 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10447 vv(1)=pizda(1,1)-pizda(2,2)
10448 vv(2)=pizda(1,2)+pizda(2,1)
10450 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10451 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10452 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10454 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10455 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10456 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10458 C Cartesian gradient
10462 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10464 vv(1)=pizda(1,1)-pizda(2,2)
10465 vv(2)=pizda(1,2)+pizda(2,1)
10466 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10467 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10468 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10474 C Contribution from graph II
10475 call transpose2(EE(1,1,k),auxmat(1,1))
10476 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10477 vv(1)=pizda(1,1)+pizda(2,2)
10478 vv(2)=pizda(2,1)-pizda(1,2)
10479 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10480 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10481 C Explicit gradient in virtual-dihedral angles.
10482 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10483 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10484 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10485 vv(1)=pizda(1,1)+pizda(2,2)
10486 vv(2)=pizda(2,1)-pizda(1,2)
10488 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10489 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10490 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10492 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10493 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10494 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10496 C Cartesian gradient
10500 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10502 vv(1)=pizda(1,1)+pizda(2,2)
10503 vv(2)=pizda(2,1)-pizda(1,2)
10504 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10505 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10506 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10514 C Parallel orientation
10515 C Contribution from graph III
10516 call transpose2(EUg(1,1,l),auxmat(1,1))
10517 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10518 vv(1)=pizda(1,1)-pizda(2,2)
10519 vv(2)=pizda(1,2)+pizda(2,1)
10520 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10521 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10522 C Explicit gradient in virtual-dihedral angles.
10523 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10524 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10525 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10526 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10527 vv(1)=pizda(1,1)-pizda(2,2)
10528 vv(2)=pizda(1,2)+pizda(2,1)
10529 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10530 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10531 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10532 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10533 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10534 vv(1)=pizda(1,1)-pizda(2,2)
10535 vv(2)=pizda(1,2)+pizda(2,1)
10536 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10537 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10538 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10539 C Cartesian gradient
10543 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10545 vv(1)=pizda(1,1)-pizda(2,2)
10546 vv(2)=pizda(1,2)+pizda(2,1)
10547 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10548 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10549 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10554 C Contribution from graph IV
10556 call transpose2(EE(1,1,l),auxmat(1,1))
10557 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10558 vv(1)=pizda(1,1)+pizda(2,2)
10559 vv(2)=pizda(2,1)-pizda(1,2)
10560 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10561 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10562 C Explicit gradient in virtual-dihedral angles.
10563 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10564 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10565 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10566 vv(1)=pizda(1,1)+pizda(2,2)
10567 vv(2)=pizda(2,1)-pizda(1,2)
10568 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10569 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10570 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10571 C Cartesian gradient
10575 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10577 vv(1)=pizda(1,1)+pizda(2,2)
10578 vv(2)=pizda(2,1)-pizda(1,2)
10579 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10580 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10581 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10586 C Antiparallel orientation
10587 C Contribution from graph III
10589 call transpose2(EUg(1,1,j),auxmat(1,1))
10590 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10591 vv(1)=pizda(1,1)-pizda(2,2)
10592 vv(2)=pizda(1,2)+pizda(2,1)
10593 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10594 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10595 C Explicit gradient in virtual-dihedral angles.
10596 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10597 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10598 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10599 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10600 vv(1)=pizda(1,1)-pizda(2,2)
10601 vv(2)=pizda(1,2)+pizda(2,1)
10602 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10603 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10604 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10605 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10606 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10607 vv(1)=pizda(1,1)-pizda(2,2)
10608 vv(2)=pizda(1,2)+pizda(2,1)
10609 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10610 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10611 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10612 C Cartesian gradient
10616 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10618 vv(1)=pizda(1,1)-pizda(2,2)
10619 vv(2)=pizda(1,2)+pizda(2,1)
10620 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10621 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10622 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10627 C Contribution from graph IV
10629 call transpose2(EE(1,1,j),auxmat(1,1))
10630 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10631 vv(1)=pizda(1,1)+pizda(2,2)
10632 vv(2)=pizda(2,1)-pizda(1,2)
10633 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10634 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10635 C Explicit gradient in virtual-dihedral angles.
10636 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10637 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10638 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10639 vv(1)=pizda(1,1)+pizda(2,2)
10640 vv(2)=pizda(2,1)-pizda(1,2)
10641 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10642 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10643 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10644 C Cartesian gradient
10648 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10650 vv(1)=pizda(1,1)+pizda(2,2)
10651 vv(2)=pizda(2,1)-pizda(1,2)
10652 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10653 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10654 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10660 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10661 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10662 cd write (2,*) 'ijkl',i,j,k,l
10663 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10664 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10666 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10667 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10668 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10669 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10670 if (j.lt.nres-1) then
10677 if (l.lt.nres-1) then
10687 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10688 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10689 C summed up outside the subrouine as for the other subroutines
10690 C handling long-range interactions. The old code is commented out
10691 C with "cgrad" to keep track of changes.
10693 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10694 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10695 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10696 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10697 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10698 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10699 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10700 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10701 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10702 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10704 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10705 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10706 cgrad ghalf=0.5d0*ggg1(ll)
10708 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10709 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10710 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10711 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10712 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10713 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10714 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10715 cgrad ghalf=0.5d0*ggg2(ll)
10717 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10718 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10719 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10720 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10721 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10722 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10727 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10728 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10733 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10734 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10740 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10745 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10749 cd write (2,*) iii,g_corr5_loc(iii)
10752 cd write (2,*) 'ekont',ekont
10753 cd write (iout,*) 'eello5',ekont*eel5
10756 c--------------------------------------------------------------------------
10757 double precision function eello6(i,j,k,l,jj,kk)
10758 implicit real*8 (a-h,o-z)
10759 include 'DIMENSIONS'
10760 include 'COMMON.IOUNITS'
10761 include 'COMMON.CHAIN'
10762 include 'COMMON.DERIV'
10763 include 'COMMON.INTERACT'
10764 include 'COMMON.CONTACTS'
10765 include 'COMMON.CONTMAT'
10766 include 'COMMON.CORRMAT'
10767 include 'COMMON.TORSION'
10768 include 'COMMON.VAR'
10769 include 'COMMON.GEO'
10770 include 'COMMON.FFIELD'
10771 double precision ggg1(3),ggg2(3)
10772 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10777 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10785 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10786 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10790 derx(lll,kkk,iii)=0.0d0
10794 cd eij=facont_hb(jj,i)
10795 cd ekl=facont_hb(kk,k)
10801 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10802 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10803 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10804 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10805 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10806 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10808 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10809 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10810 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10811 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10812 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10813 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10817 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10819 C If turn contributions are considered, they will be handled separately.
10820 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10821 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10822 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10823 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10824 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10825 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10826 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10828 if (j.lt.nres-1) then
10835 if (l.lt.nres-1) then
10843 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10844 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10845 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10846 cgrad ghalf=0.5d0*ggg1(ll)
10848 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10849 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10850 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10851 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10852 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10853 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10854 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10855 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10856 cgrad ghalf=0.5d0*ggg2(ll)
10857 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10859 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10860 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10861 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10862 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10863 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10864 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10869 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10870 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10875 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10876 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10882 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10887 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10891 cd write (2,*) iii,g_corr6_loc(iii)
10894 cd write (2,*) 'ekont',ekont
10895 cd write (iout,*) 'eello6',ekont*eel6
10898 c--------------------------------------------------------------------------
10899 double precision function eello6_graph1(i,j,k,l,imat,swap)
10900 implicit real*8 (a-h,o-z)
10901 include 'DIMENSIONS'
10902 include 'COMMON.IOUNITS'
10903 include 'COMMON.CHAIN'
10904 include 'COMMON.DERIV'
10905 include 'COMMON.INTERACT'
10906 include 'COMMON.CONTACTS'
10907 include 'COMMON.CONTMAT'
10908 include 'COMMON.CORRMAT'
10909 include 'COMMON.TORSION'
10910 include 'COMMON.VAR'
10911 include 'COMMON.GEO'
10912 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10915 common /kutas/ lprn
10916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10918 C Parallel Antiparallel C
10924 C \ j|/k\| / \ |/k\|l / C
10925 C \ / \ / \ / \ / C
10929 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10930 itk=itype2loc(itype(k))
10931 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10932 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10933 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10934 call transpose2(EUgC(1,1,k),auxmat(1,1))
10935 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10936 vv1(1)=pizda1(1,1)-pizda1(2,2)
10937 vv1(2)=pizda1(1,2)+pizda1(2,1)
10938 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10939 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10940 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10941 s5=scalar2(vv(1),Dtobr2(1,i))
10942 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10943 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10944 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10945 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10946 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10947 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10948 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10949 & +scalar2(vv(1),Dtobr2der(1,i)))
10950 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10951 vv1(1)=pizda1(1,1)-pizda1(2,2)
10952 vv1(2)=pizda1(1,2)+pizda1(2,1)
10953 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10954 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10956 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10957 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10958 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10959 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10960 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10962 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10963 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10964 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10965 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10966 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10968 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10969 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10970 vv1(1)=pizda1(1,1)-pizda1(2,2)
10971 vv1(2)=pizda1(1,2)+pizda1(2,1)
10972 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10973 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10974 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10975 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10984 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10985 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10986 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10987 call transpose2(EUgC(1,1,k),auxmat(1,1))
10988 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10990 vv1(1)=pizda1(1,1)-pizda1(2,2)
10991 vv1(2)=pizda1(1,2)+pizda1(2,1)
10992 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10993 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10994 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10995 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10996 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10997 s5=scalar2(vv(1),Dtobr2(1,i))
10998 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11004 c----------------------------------------------------------------------------
11005 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11006 implicit real*8 (a-h,o-z)
11007 include 'DIMENSIONS'
11008 include 'COMMON.IOUNITS'
11009 include 'COMMON.CHAIN'
11010 include 'COMMON.DERIV'
11011 include 'COMMON.INTERACT'
11012 include 'COMMON.CONTACTS'
11013 include 'COMMON.CONTMAT'
11014 include 'COMMON.CORRMAT'
11015 include 'COMMON.TORSION'
11016 include 'COMMON.VAR'
11017 include 'COMMON.GEO'
11019 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11020 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11022 common /kutas/ lprn
11023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11025 C Parallel Antiparallel C
11031 C \ j|/k\| \ |/k\|l C
11036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11037 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11038 C AL 7/4/01 s1 would occur in the sixth-order moment,
11039 C but not in a cluster cumulant
11041 s1=dip(1,jj,i)*dip(1,kk,k)
11043 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11044 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11045 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11046 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11047 call transpose2(EUg(1,1,k),auxmat(1,1))
11048 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11049 vv(1)=pizda(1,1)-pizda(2,2)
11050 vv(2)=pizda(1,2)+pizda(2,1)
11051 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11052 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11054 eello6_graph2=-(s1+s2+s3+s4)
11056 eello6_graph2=-(s2+s3+s4)
11058 c eello6_graph2=-s3
11059 C Derivatives in gamma(i-1)
11062 s1=dipderg(1,jj,i)*dip(1,kk,k)
11064 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11065 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11066 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11067 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11069 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11071 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11073 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11075 C Derivatives in gamma(k-1)
11077 s1=dip(1,jj,i)*dipderg(1,kk,k)
11079 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11080 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11081 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11082 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11083 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11084 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11085 vv(1)=pizda(1,1)-pizda(2,2)
11086 vv(2)=pizda(1,2)+pizda(2,1)
11087 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11089 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11091 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11093 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11094 C Derivatives in gamma(j-1) or gamma(l-1)
11097 s1=dipderg(3,jj,i)*dip(1,kk,k)
11099 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11100 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11101 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11102 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11103 vv(1)=pizda(1,1)-pizda(2,2)
11104 vv(2)=pizda(1,2)+pizda(2,1)
11105 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11108 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11110 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11113 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11114 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11116 C Derivatives in gamma(l-1) or gamma(j-1)
11119 s1=dip(1,jj,i)*dipderg(3,kk,k)
11121 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11122 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11123 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11124 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11125 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11126 vv(1)=pizda(1,1)-pizda(2,2)
11127 vv(2)=pizda(1,2)+pizda(2,1)
11128 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11131 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11133 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11136 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11137 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11139 C Cartesian derivatives.
11141 write (2,*) 'In eello6_graph2'
11143 write (2,*) 'iii=',iii
11145 write (2,*) 'kkk=',kkk
11147 write (2,'(3(2f10.5),5x)')
11148 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11158 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11160 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11163 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11165 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11166 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11168 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11169 call transpose2(EUg(1,1,k),auxmat(1,1))
11170 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11172 vv(1)=pizda(1,1)-pizda(2,2)
11173 vv(2)=pizda(1,2)+pizda(2,1)
11174 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11175 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11177 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11179 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11182 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11184 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11191 c----------------------------------------------------------------------------
11192 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11193 implicit real*8 (a-h,o-z)
11194 include 'DIMENSIONS'
11195 include 'COMMON.IOUNITS'
11196 include 'COMMON.CHAIN'
11197 include 'COMMON.DERIV'
11198 include 'COMMON.INTERACT'
11199 include 'COMMON.CONTACTS'
11200 include 'COMMON.CONTMAT'
11201 include 'COMMON.CORRMAT'
11202 include 'COMMON.TORSION'
11203 include 'COMMON.VAR'
11204 include 'COMMON.GEO'
11205 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11207 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11209 C Parallel Antiparallel C
11214 C /| o |o o| o |\ C
11215 C j|/k\| / |/k\|l / C
11220 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11222 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11223 C energy moment and not to the cluster cumulant.
11224 iti=itortyp(itype(i))
11225 if (j.lt.nres-1) then
11226 itj1=itype2loc(itype(j+1))
11230 itk=itype2loc(itype(k))
11231 itk1=itype2loc(itype(k+1))
11232 if (l.lt.nres-1) then
11233 itl1=itype2loc(itype(l+1))
11238 s1=dip(4,jj,i)*dip(4,kk,k)
11240 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11241 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11242 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11243 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11244 call transpose2(EE(1,1,k),auxmat(1,1))
11245 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11246 vv(1)=pizda(1,1)+pizda(2,2)
11247 vv(2)=pizda(2,1)-pizda(1,2)
11248 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11249 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11250 cd & "sum",-(s2+s3+s4)
11252 eello6_graph3=-(s1+s2+s3+s4)
11254 eello6_graph3=-(s2+s3+s4)
11256 c eello6_graph3=-s4
11257 C Derivatives in gamma(k-1)
11258 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11259 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11260 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11261 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11262 C Derivatives in gamma(l-1)
11263 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11264 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11265 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11266 vv(1)=pizda(1,1)+pizda(2,2)
11267 vv(2)=pizda(2,1)-pizda(1,2)
11268 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11269 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11270 C Cartesian derivatives.
11276 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11278 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11281 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11283 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11284 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11286 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11287 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11289 vv(1)=pizda(1,1)+pizda(2,2)
11290 vv(2)=pizda(2,1)-pizda(1,2)
11291 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11293 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11295 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11298 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11300 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11302 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11308 c----------------------------------------------------------------------------
11309 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11310 implicit real*8 (a-h,o-z)
11311 include 'DIMENSIONS'
11312 include 'COMMON.IOUNITS'
11313 include 'COMMON.CHAIN'
11314 include 'COMMON.DERIV'
11315 include 'COMMON.INTERACT'
11316 include 'COMMON.CONTACTS'
11317 include 'COMMON.CONTMAT'
11318 include 'COMMON.CORRMAT'
11319 include 'COMMON.TORSION'
11320 include 'COMMON.VAR'
11321 include 'COMMON.GEO'
11322 include 'COMMON.FFIELD'
11323 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11324 & auxvec1(2),auxmat1(2,2)
11326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11328 C Parallel Antiparallel C
11333 C /| o |o o| o |\ C
11334 C \ j|/k\| \ |/k\|l C
11339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11341 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11342 C energy moment and not to the cluster cumulant.
11343 cd write (2,*) 'eello_graph4: wturn6',wturn6
11344 iti=itype2loc(itype(i))
11345 itj=itype2loc(itype(j))
11346 if (j.lt.nres-1) then
11347 itj1=itype2loc(itype(j+1))
11351 itk=itype2loc(itype(k))
11352 if (k.lt.nres-1) then
11353 itk1=itype2loc(itype(k+1))
11357 itl=itype2loc(itype(l))
11358 if (l.lt.nres-1) then
11359 itl1=itype2loc(itype(l+1))
11363 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11364 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11365 cd & ' itl',itl,' itl1',itl1
11367 if (imat.eq.1) then
11368 s1=dip(3,jj,i)*dip(3,kk,k)
11370 s1=dip(2,jj,j)*dip(2,kk,l)
11373 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11374 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11376 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11377 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11379 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11380 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11382 call transpose2(EUg(1,1,k),auxmat(1,1))
11383 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11384 vv(1)=pizda(1,1)-pizda(2,2)
11385 vv(2)=pizda(2,1)+pizda(1,2)
11386 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11387 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11389 eello6_graph4=-(s1+s2+s3+s4)
11391 eello6_graph4=-(s2+s3+s4)
11393 C Derivatives in gamma(i-1)
11396 if (imat.eq.1) then
11397 s1=dipderg(2,jj,i)*dip(3,kk,k)
11399 s1=dipderg(4,jj,j)*dip(2,kk,l)
11402 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11404 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11405 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11407 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11408 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11410 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11411 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11412 cd write (2,*) 'turn6 derivatives'
11414 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11416 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11420 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11422 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11426 C Derivatives in gamma(k-1)
11428 if (imat.eq.1) then
11429 s1=dip(3,jj,i)*dipderg(2,kk,k)
11431 s1=dip(2,jj,j)*dipderg(4,kk,l)
11434 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11435 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11437 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11438 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11440 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11441 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11443 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11444 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11445 vv(1)=pizda(1,1)-pizda(2,2)
11446 vv(2)=pizda(2,1)+pizda(1,2)
11447 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11448 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11450 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11452 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11456 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11458 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11461 C Derivatives in gamma(j-1) or gamma(l-1)
11462 if (l.eq.j+1 .and. l.gt.1) then
11463 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11464 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11465 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11466 vv(1)=pizda(1,1)-pizda(2,2)
11467 vv(2)=pizda(2,1)+pizda(1,2)
11468 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11469 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11470 else if (j.gt.1) then
11471 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11472 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11473 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11474 vv(1)=pizda(1,1)-pizda(2,2)
11475 vv(2)=pizda(2,1)+pizda(1,2)
11476 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11477 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11478 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11480 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11483 C Cartesian derivatives.
11489 if (imat.eq.1) then
11490 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11492 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11495 if (imat.eq.1) then
11496 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11498 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11502 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11504 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11506 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11507 & b1(1,j+1),auxvec(1))
11508 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11510 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11511 & b1(1,l+1),auxvec(1))
11512 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11514 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11516 vv(1)=pizda(1,1)-pizda(2,2)
11517 vv(2)=pizda(2,1)+pizda(1,2)
11518 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11520 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11522 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11525 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11528 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11531 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11533 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11535 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11539 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11541 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11544 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11546 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11554 c----------------------------------------------------------------------------
11555 double precision function eello_turn6(i,jj,kk)
11556 implicit real*8 (a-h,o-z)
11557 include 'DIMENSIONS'
11558 include 'COMMON.IOUNITS'
11559 include 'COMMON.CHAIN'
11560 include 'COMMON.DERIV'
11561 include 'COMMON.INTERACT'
11562 include 'COMMON.CONTACTS'
11563 include 'COMMON.CONTMAT'
11564 include 'COMMON.CORRMAT'
11565 include 'COMMON.TORSION'
11566 include 'COMMON.VAR'
11567 include 'COMMON.GEO'
11568 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11569 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11571 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11572 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11573 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11574 C the respective energy moment and not to the cluster cumulant.
11583 iti=itype2loc(itype(i))
11584 itk=itype2loc(itype(k))
11585 itk1=itype2loc(itype(k+1))
11586 itl=itype2loc(itype(l))
11587 itj=itype2loc(itype(j))
11588 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11589 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11590 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11595 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11597 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11601 derx_turn(lll,kkk,iii)=0.0d0
11608 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11610 cd write (2,*) 'eello6_5',eello6_5
11612 call transpose2(AEA(1,1,1),auxmat(1,1))
11613 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11614 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11615 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11617 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11618 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11619 s2 = scalar2(b1(1,k),vtemp1(1))
11621 call transpose2(AEA(1,1,2),atemp(1,1))
11622 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11623 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11624 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11626 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11627 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11628 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11630 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11631 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11632 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11633 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11634 ss13 = scalar2(b1(1,k),vtemp4(1))
11635 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11637 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11643 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11644 C Derivatives in gamma(i+2)
11648 call transpose2(AEA(1,1,1),auxmatd(1,1))
11649 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11650 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11651 call transpose2(AEAderg(1,1,2),atempd(1,1))
11652 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11653 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11655 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11656 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11657 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11663 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11664 C Derivatives in gamma(i+3)
11666 call transpose2(AEA(1,1,1),auxmatd(1,1))
11667 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11668 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11669 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11671 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11672 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11673 s2d = scalar2(b1(1,k),vtemp1d(1))
11675 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11676 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11678 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11680 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11681 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11682 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11690 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11691 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11693 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11694 & -0.5d0*ekont*(s2d+s12d)
11696 C Derivatives in gamma(i+4)
11697 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11698 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11699 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11701 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11702 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11703 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11711 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11713 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11715 C Derivatives in gamma(i+5)
11717 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11718 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11719 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11721 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11722 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11723 s2d = scalar2(b1(1,k),vtemp1d(1))
11725 call transpose2(AEA(1,1,2),atempd(1,1))
11726 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11727 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11729 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11730 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11732 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11733 ss13d = scalar2(b1(1,k),vtemp4d(1))
11734 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11742 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11743 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11745 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11746 & -0.5d0*ekont*(s2d+s12d)
11748 C Cartesian derivatives
11753 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11754 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11755 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11757 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11758 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11760 s2d = scalar2(b1(1,k),vtemp1d(1))
11762 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11763 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11764 s8d = -(atempd(1,1)+atempd(2,2))*
11765 & scalar2(cc(1,1,l),vtemp2(1))
11767 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11769 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11770 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11777 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11778 & - 0.5d0*(s1d+s2d)
11780 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11784 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11785 & - 0.5d0*(s8d+s12d)
11787 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11796 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11797 & achuj_tempd(1,1))
11798 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11799 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11800 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11801 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11802 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11804 ss13d = scalar2(b1(1,k),vtemp4d(1))
11805 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11806 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11810 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11811 cd & 16*eel_turn6_num
11813 if (j.lt.nres-1) then
11820 if (l.lt.nres-1) then
11828 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11829 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11830 cgrad ghalf=0.5d0*ggg1(ll)
11832 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11833 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11834 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11835 & +ekont*derx_turn(ll,2,1)
11836 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11837 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11838 & +ekont*derx_turn(ll,4,1)
11839 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11840 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11841 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11842 cgrad ghalf=0.5d0*ggg2(ll)
11844 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11845 & +ekont*derx_turn(ll,2,2)
11846 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11847 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11848 & +ekont*derx_turn(ll,4,2)
11849 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11850 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11851 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11856 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11861 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11867 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11872 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11876 cd write (2,*) iii,g_corr6_loc(iii)
11878 eello_turn6=ekont*eel_turn6
11879 cd write (2,*) 'ekont',ekont
11880 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11883 C-----------------------------------------------------------------------------
11885 double precision function scalar(u,v)
11886 !DIR$ INLINEALWAYS scalar
11888 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11891 double precision u(3),v(3)
11892 cd double precision sc
11900 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11903 crc-------------------------------------------------
11904 SUBROUTINE MATVEC2(A1,V1,V2)
11905 !DIR$ INLINEALWAYS MATVEC2
11907 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11909 implicit real*8 (a-h,o-z)
11910 include 'DIMENSIONS'
11911 DIMENSION A1(2,2),V1(2),V2(2)
11915 c 3 VI=VI+A1(I,K)*V1(K)
11919 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11920 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11925 C---------------------------------------
11926 SUBROUTINE MATMAT2(A1,A2,A3)
11928 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11930 implicit real*8 (a-h,o-z)
11931 include 'DIMENSIONS'
11932 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11933 c DIMENSION AI3(2,2)
11937 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11943 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11944 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11945 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11946 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11954 c-------------------------------------------------------------------------
11955 double precision function scalar2(u,v)
11956 !DIR$ INLINEALWAYS scalar2
11958 double precision u(2),v(2)
11959 double precision sc
11961 scalar2=u(1)*v(1)+u(2)*v(2)
11965 C-----------------------------------------------------------------------------
11967 subroutine transpose2(a,at)
11968 !DIR$ INLINEALWAYS transpose2
11970 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11973 double precision a(2,2),at(2,2)
11980 c--------------------------------------------------------------------------
11981 subroutine transpose(n,a,at)
11984 double precision a(n,n),at(n,n)
11992 C---------------------------------------------------------------------------
11993 subroutine prodmat3(a1,a2,kk,transp,prod)
11994 !DIR$ INLINEALWAYS prodmat3
11996 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12000 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12002 crc double precision auxmat(2,2),prod_(2,2)
12005 crc call transpose2(kk(1,1),auxmat(1,1))
12006 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12007 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12009 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12010 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12011 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12012 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12013 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12014 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12015 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12016 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12019 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12020 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12022 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12023 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12024 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12025 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12026 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12027 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12028 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12029 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12032 c call transpose2(a2(1,1),a2t(1,1))
12035 crc print *,((prod_(i,j),i=1,2),j=1,2)
12036 crc print *,((prod(i,j),i=1,2),j=1,2)
12040 CCC----------------------------------------------
12041 subroutine Eliptransfer(eliptran)
12042 implicit real*8 (a-h,o-z)
12043 include 'DIMENSIONS'
12044 include 'COMMON.GEO'
12045 include 'COMMON.VAR'
12046 include 'COMMON.LOCAL'
12047 include 'COMMON.CHAIN'
12048 include 'COMMON.DERIV'
12049 include 'COMMON.NAMES'
12050 include 'COMMON.INTERACT'
12051 include 'COMMON.IOUNITS'
12052 include 'COMMON.CALC'
12053 include 'COMMON.CONTROL'
12054 include 'COMMON.SPLITELE'
12055 include 'COMMON.SBRIDGE'
12056 C this is done by Adasko
12057 C print *,"wchodze"
12058 C structure of box:
12060 C--bordliptop-- buffore starts
12061 C--bufliptop--- here true lipid starts
12063 C--buflipbot--- lipid ends buffore starts
12064 C--bordlipbot--buffore ends
12067 do i=ilip_start,ilip_end
12069 if (itype(i).eq.ntyp1) cycle
12071 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12072 if (positi.le.0.0) positi=positi+boxzsize
12074 C first for peptide groups
12075 c for each residue check if it is in lipid or lipid water border area
12076 if ((positi.gt.bordlipbot)
12077 &.and.(positi.lt.bordliptop)) then
12078 C the energy transfer exist
12079 if (positi.lt.buflipbot) then
12080 C what fraction I am in
12082 & ((positi-bordlipbot)/lipbufthick)
12083 C lipbufthick is thickenes of lipid buffore
12084 sslip=sscalelip(fracinbuf)
12085 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12086 eliptran=eliptran+sslip*pepliptran
12087 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12088 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12089 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12091 C print *,"doing sccale for lower part"
12092 C print *,i,sslip,fracinbuf,ssgradlip
12093 elseif (positi.gt.bufliptop) then
12094 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12095 sslip=sscalelip(fracinbuf)
12096 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12097 eliptran=eliptran+sslip*pepliptran
12098 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12099 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12100 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12101 C print *, "doing sscalefor top part"
12102 C print *,i,sslip,fracinbuf,ssgradlip
12104 eliptran=eliptran+pepliptran
12105 C print *,"I am in true lipid"
12108 C eliptran=elpitran+0.0 ! I am in water
12111 C print *, "nic nie bylo w lipidzie?"
12112 C now multiply all by the peptide group transfer factor
12113 C eliptran=eliptran*pepliptran
12114 C now the same for side chains
12116 do i=ilip_start,ilip_end
12117 if (itype(i).eq.ntyp1) cycle
12118 positi=(mod(c(3,i+nres),boxzsize))
12119 if (positi.le.0) positi=positi+boxzsize
12120 c write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
12122 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12123 c for each residue check if it is in lipid or lipid water border area
12124 C respos=mod(c(3,i+nres),boxzsize)
12125 C print *,positi,bordlipbot,buflipbot
12126 if ((positi.gt.bordlipbot)
12127 & .and.(positi.lt.bordliptop)) then
12128 C the energy transfer exist
12129 if (positi.lt.buflipbot) then
12131 & ((positi-bordlipbot)/lipbufthick)
12132 c write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
12133 c write (iout,*) "i",i," liptranene",liptranene(itype(i))
12134 C lipbufthick is thickenes of lipid buffore
12135 sslip=sscalelip(fracinbuf)
12136 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12137 eliptran=eliptran+sslip*liptranene(itype(i))
12138 gliptranx(3,i)=gliptranx(3,i)
12139 &+ssgradlip*liptranene(itype(i))
12140 gliptranc(3,i-1)= gliptranc(3,i-1)
12141 &+ssgradlip*liptranene(itype(i))
12142 C print *,"doing sccale for lower part"
12143 elseif (positi.gt.bufliptop) then
12145 &((bordliptop-positi)/lipbufthick)
12146 sslip=sscalelip(fracinbuf)
12147 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12148 eliptran=eliptran+sslip*liptranene(itype(i))
12149 gliptranx(3,i)=gliptranx(3,i)
12150 &+ssgradlip*liptranene(itype(i))
12151 gliptranc(3,i-1)= gliptranc(3,i-1)
12152 &+ssgradlip*liptranene(itype(i))
12153 C print *, "doing sscalefor top part",sslip,fracinbuf
12155 eliptran=eliptran+liptranene(itype(i))
12156 C print *,"I am in true lipid"
12158 endif ! if in lipid or buffor
12160 C eliptran=elpitran+0.0 ! I am in water
12164 C---------------------------------------------------------
12165 C AFM soubroutine for constant force
12166 subroutine AFMforce(Eafmforce)
12167 implicit real*8 (a-h,o-z)
12168 include 'DIMENSIONS'
12169 include 'COMMON.GEO'
12170 include 'COMMON.VAR'
12171 include 'COMMON.LOCAL'
12172 include 'COMMON.CHAIN'
12173 include 'COMMON.DERIV'
12174 include 'COMMON.NAMES'
12175 include 'COMMON.INTERACT'
12176 include 'COMMON.IOUNITS'
12177 include 'COMMON.CALC'
12178 include 'COMMON.CONTROL'
12179 include 'COMMON.SPLITELE'
12180 include 'COMMON.SBRIDGE'
12185 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12186 dist=dist+diffafm(i)**2
12189 Eafmforce=-forceAFMconst*(dist-distafminit)
12191 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12192 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12194 C print *,'AFM',Eafmforce
12197 C---------------------------------------------------------
12198 C AFM subroutine with pseudoconstant velocity
12199 subroutine AFMvel(Eafmforce)
12200 implicit real*8 (a-h,o-z)
12201 include 'DIMENSIONS'
12202 include 'COMMON.GEO'
12203 include 'COMMON.VAR'
12204 include 'COMMON.LOCAL'
12205 include 'COMMON.CHAIN'
12206 include 'COMMON.DERIV'
12207 include 'COMMON.NAMES'
12208 include 'COMMON.INTERACT'
12209 include 'COMMON.IOUNITS'
12210 include 'COMMON.CALC'
12211 include 'COMMON.CONTROL'
12212 include 'COMMON.SPLITELE'
12213 include 'COMMON.SBRIDGE'
12215 C Only for check grad COMMENT if not used for checkgrad
12217 C--------------------------------------------------------
12218 C print *,"wchodze"
12222 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12223 dist=dist+diffafm(i)**2
12226 Eafmforce=0.5d0*forceAFMconst
12227 & *(distafminit+totTafm*velAFMconst-dist)**2
12228 C Eafmforce=-forceAFMconst*(dist-distafminit)
12230 gradafm(i,afmend-1)=-forceAFMconst*
12231 &(distafminit+totTafm*velAFMconst-dist)
12233 gradafm(i,afmbeg-1)=forceAFMconst*
12234 &(distafminit+totTafm*velAFMconst-dist)
12237 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12240 C-----------------------------------------------------------
12241 C first for shielding is setting of function of side-chains
12242 subroutine set_shield_fac
12243 implicit real*8 (a-h,o-z)
12244 include 'DIMENSIONS'
12245 include 'COMMON.CHAIN'
12246 include 'COMMON.DERIV'
12247 include 'COMMON.IOUNITS'
12248 include 'COMMON.SHIELD'
12249 include 'COMMON.INTERACT'
12250 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12251 double precision div77_81/0.974996043d0/,
12252 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12254 C the vector between center of side_chain and peptide group
12255 double precision pep_side(3),long,side_calf(3),
12256 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12257 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12258 C the line belowe needs to be changed for FGPROC>1
12260 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12262 Cif there two consequtive dummy atoms there is no peptide group between them
12263 C the line below has to be changed for FGPROC>1
12266 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12270 C first lets set vector conecting the ithe side-chain with kth side-chain
12271 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12272 C pep_side(j)=2.0d0
12273 C and vector conecting the side-chain with its proper calfa
12274 side_calf(j)=c(j,k+nres)-c(j,k)
12275 C side_calf(j)=2.0d0
12276 pept_group(j)=c(j,i)-c(j,i+1)
12277 C lets have their lenght
12278 dist_pep_side=pep_side(j)**2+dist_pep_side
12279 dist_side_calf=dist_side_calf+side_calf(j)**2
12280 dist_pept_group=dist_pept_group+pept_group(j)**2
12282 dist_pep_side=dsqrt(dist_pep_side)
12283 dist_pept_group=dsqrt(dist_pept_group)
12284 dist_side_calf=dsqrt(dist_side_calf)
12286 pep_side_norm(j)=pep_side(j)/dist_pep_side
12287 side_calf_norm(j)=dist_side_calf
12289 C now sscale fraction
12290 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12291 C print *,buff_shield,"buff"
12293 if (sh_frac_dist.le.0.0) cycle
12294 C If we reach here it means that this side chain reaches the shielding sphere
12295 C Lets add him to the list for gradient
12296 ishield_list(i)=ishield_list(i)+1
12297 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12298 C this list is essential otherwise problem would be O3
12299 shield_list(ishield_list(i),i)=k
12300 C Lets have the sscale value
12301 if (sh_frac_dist.gt.1.0) then
12302 scale_fac_dist=1.0d0
12304 sh_frac_dist_grad(j)=0.0d0
12307 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12308 & *(2.0*sh_frac_dist-3.0d0)
12309 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12310 & /dist_pep_side/buff_shield*0.5
12311 C remember for the final gradient multiply sh_frac_dist_grad(j)
12312 C for side_chain by factor -2 !
12314 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12315 C print *,"jestem",scale_fac_dist,fac_help_scale,
12316 C & sh_frac_dist_grad(j)
12319 C if ((i.eq.3).and.(k.eq.2)) then
12320 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12324 C this is what is now we have the distance scaling now volume...
12325 short=short_r_sidechain(itype(k))
12326 long=long_r_sidechain(itype(k))
12327 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12330 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12331 C costhet_fac=0.0d0
12333 costhet_grad(j)=costhet_fac*pep_side(j)
12335 C remember for the final gradient multiply costhet_grad(j)
12336 C for side_chain by factor -2 !
12337 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12338 C pep_side0pept_group is vector multiplication
12339 pep_side0pept_group=0.0
12341 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12343 cosalfa=(pep_side0pept_group/
12344 & (dist_pep_side*dist_side_calf))
12345 fac_alfa_sin=1.0-cosalfa**2
12346 fac_alfa_sin=dsqrt(fac_alfa_sin)
12347 rkprim=fac_alfa_sin*(long-short)+short
12349 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12350 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12353 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12354 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12355 &*(long-short)/fac_alfa_sin*cosalfa/
12356 &((dist_pep_side*dist_side_calf))*
12357 &((side_calf(j))-cosalfa*
12358 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12360 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12361 &*(long-short)/fac_alfa_sin*cosalfa
12362 &/((dist_pep_side*dist_side_calf))*
12364 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12367 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12370 C now the gradient...
12371 C grad_shield is gradient of Calfa for peptide groups
12372 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12374 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12375 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12377 grad_shield(j,i)=grad_shield(j,i)
12378 C gradient po skalowaniu
12379 & +(sh_frac_dist_grad(j)
12380 C gradient po costhet
12381 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12382 &-scale_fac_dist*(cosphi_grad_long(j))
12383 &/(1.0-cosphi) )*div77_81
12385 C grad_shield_side is Cbeta sidechain gradient
12386 grad_shield_side(j,ishield_list(i),i)=
12387 & (sh_frac_dist_grad(j)*(-2.0d0)
12388 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12389 & +scale_fac_dist*(cosphi_grad_long(j))
12390 & *2.0d0/(1.0-cosphi))
12391 & *div77_81*VofOverlap
12393 grad_shield_loc(j,ishield_list(i),i)=
12394 & scale_fac_dist*cosphi_grad_loc(j)
12395 & *2.0d0/(1.0-cosphi)
12396 & *div77_81*VofOverlap
12398 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12400 fac_shield(i)=VolumeTotal*div77_81+div4_81
12401 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12405 C--------------------------------------------------------------------------
12406 double precision function tschebyshev(m,n,x,y)
12408 include "DIMENSIONS"
12410 double precision x(n),y,yy(0:maxvar),aux
12411 c Tschebyshev polynomial. Note that the first term is omitted
12412 c m=0: the constant term is included
12413 c m=1: the constant term is not included
12417 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12426 C--------------------------------------------------------------------------
12427 double precision function gradtschebyshev(m,n,x,y)
12429 include "DIMENSIONS"
12431 double precision x(n+1),y,yy(0:maxvar),aux
12432 c Tschebyshev polynomial. Note that the first term is omitted
12433 c m=0: the constant term is included
12434 c m=1: the constant term is not included
12438 yy(i)=2*y*yy(i-1)-yy(i-2)
12442 aux=aux+x(i+1)*yy(i)*(i+1)
12443 C print *, x(i+1),yy(i),i
12445 gradtschebyshev=aux
12448 C------------------------------------------------------------------------
12449 C first for shielding is setting of function of side-chains
12450 subroutine set_shield_fac2
12451 implicit real*8 (a-h,o-z)
12452 include 'DIMENSIONS'
12453 include 'COMMON.CHAIN'
12454 include 'COMMON.DERIV'
12455 include 'COMMON.IOUNITS'
12456 include 'COMMON.SHIELD'
12457 include 'COMMON.INTERACT'
12458 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12459 double precision div77_81/0.974996043d0/,
12460 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12462 C the vector between center of side_chain and peptide group
12463 double precision pep_side(3),long,side_calf(3),
12464 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12465 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12466 C the line belowe needs to be changed for FGPROC>1
12468 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12470 Cif there two consequtive dummy atoms there is no peptide group between them
12471 C the line below has to be changed for FGPROC>1
12474 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12478 C first lets set vector conecting the ithe side-chain with kth side-chain
12479 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12480 C pep_side(j)=2.0d0
12481 C and vector conecting the side-chain with its proper calfa
12482 side_calf(j)=c(j,k+nres)-c(j,k)
12483 C side_calf(j)=2.0d0
12484 pept_group(j)=c(j,i)-c(j,i+1)
12485 C lets have their lenght
12486 dist_pep_side=pep_side(j)**2+dist_pep_side
12487 dist_side_calf=dist_side_calf+side_calf(j)**2
12488 dist_pept_group=dist_pept_group+pept_group(j)**2
12490 dist_pep_side=dsqrt(dist_pep_side)
12491 dist_pept_group=dsqrt(dist_pept_group)
12492 dist_side_calf=dsqrt(dist_side_calf)
12494 pep_side_norm(j)=pep_side(j)/dist_pep_side
12495 side_calf_norm(j)=dist_side_calf
12497 C now sscale fraction
12498 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12499 C print *,buff_shield,"buff"
12501 if (sh_frac_dist.le.0.0) cycle
12502 C If we reach here it means that this side chain reaches the shielding sphere
12503 C Lets add him to the list for gradient
12504 ishield_list(i)=ishield_list(i)+1
12505 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12506 C this list is essential otherwise problem would be O3
12507 shield_list(ishield_list(i),i)=k
12508 C Lets have the sscale value
12509 if (sh_frac_dist.gt.1.0) then
12510 scale_fac_dist=1.0d0
12512 sh_frac_dist_grad(j)=0.0d0
12515 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12516 & *(2.0d0*sh_frac_dist-3.0d0)
12517 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12518 & /dist_pep_side/buff_shield*0.5d0
12519 C remember for the final gradient multiply sh_frac_dist_grad(j)
12520 C for side_chain by factor -2 !
12522 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12523 C sh_frac_dist_grad(j)=0.0d0
12524 C scale_fac_dist=1.0d0
12525 C print *,"jestem",scale_fac_dist,fac_help_scale,
12526 C & sh_frac_dist_grad(j)
12529 C this is what is now we have the distance scaling now volume...
12530 short=short_r_sidechain(itype(k))
12531 long=long_r_sidechain(itype(k))
12532 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12533 sinthet=short/dist_pep_side*costhet
12537 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12538 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12539 C & -short/dist_pep_side**2/costhet)
12540 C costhet_fac=0.0d0
12542 costhet_grad(j)=costhet_fac*pep_side(j)
12544 C remember for the final gradient multiply costhet_grad(j)
12545 C for side_chain by factor -2 !
12546 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12547 C pep_side0pept_group is vector multiplication
12548 pep_side0pept_group=0.0d0
12550 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12552 cosalfa=(pep_side0pept_group/
12553 & (dist_pep_side*dist_side_calf))
12554 fac_alfa_sin=1.0d0-cosalfa**2
12555 fac_alfa_sin=dsqrt(fac_alfa_sin)
12556 rkprim=fac_alfa_sin*(long-short)+short
12560 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12562 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12563 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12564 & dist_pep_side**2)
12567 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12568 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12569 &*(long-short)/fac_alfa_sin*cosalfa/
12570 &((dist_pep_side*dist_side_calf))*
12571 &((side_calf(j))-cosalfa*
12572 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12573 C cosphi_grad_long(j)=0.0d0
12574 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12575 &*(long-short)/fac_alfa_sin*cosalfa
12576 &/((dist_pep_side*dist_side_calf))*
12578 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12579 C cosphi_grad_loc(j)=0.0d0
12581 C print *,sinphi,sinthet
12582 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12583 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12584 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12587 C now the gradient...
12589 grad_shield(j,i)=grad_shield(j,i)
12590 C gradient po skalowaniu
12591 & +(sh_frac_dist_grad(j)*VofOverlap
12592 C gradient po costhet
12593 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12594 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12595 & sinphi/sinthet*costhet*costhet_grad(j)
12596 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12598 C grad_shield_side is Cbeta sidechain gradient
12599 grad_shield_side(j,ishield_list(i),i)=
12600 & (sh_frac_dist_grad(j)*(-2.0d0)
12602 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12603 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12604 & sinphi/sinthet*costhet*costhet_grad(j)
12605 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12608 grad_shield_loc(j,ishield_list(i),i)=
12609 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12610 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12611 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12615 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12617 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12619 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12620 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12621 c & " wshield",wshield
12622 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12626 C-----------------------------------------------------------------------
12627 C-----------------------------------------------------------
12628 C This subroutine is to mimic the histone like structure but as well can be
12629 C utilizet to nanostructures (infinit) small modification has to be used to
12630 C make it finite (z gradient at the ends has to be changes as well as the x,y
12631 C gradient has to be modified at the ends
12632 C The energy function is Kihara potential
12633 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12634 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12635 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12636 C simple Kihara potential
12637 subroutine calctube(Etube)
12638 implicit real*8 (a-h,o-z)
12639 include 'DIMENSIONS'
12640 include 'COMMON.GEO'
12641 include 'COMMON.VAR'
12642 include 'COMMON.LOCAL'
12643 include 'COMMON.CHAIN'
12644 include 'COMMON.DERIV'
12645 include 'COMMON.NAMES'
12646 include 'COMMON.INTERACT'
12647 include 'COMMON.IOUNITS'
12648 include 'COMMON.CALC'
12649 include 'COMMON.CONTROL'
12650 include 'COMMON.SPLITELE'
12651 include 'COMMON.SBRIDGE'
12652 double precision tub_r,vectube(3),enetube(maxres*2)
12657 C first we calculate the distance from tube center
12658 C first sugare-phosphate group for NARES this would be peptide group
12661 C lets ommit dummy atoms for now
12662 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12663 C now calculate distance from center of tube and direction vectors
12664 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12665 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12666 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12667 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12668 vectube(1)=vectube(1)-tubecenter(1)
12669 vectube(2)=vectube(2)-tubecenter(2)
12671 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12672 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12674 C as the tube is infinity we do not calculate the Z-vector use of Z
12677 C now calculte the distance
12678 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12679 C now normalize vector
12680 vectube(1)=vectube(1)/tub_r
12681 vectube(2)=vectube(2)/tub_r
12682 C calculte rdiffrence between r and r0
12685 rdiff6=rdiff**6.0d0
12686 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12687 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12688 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12689 C print *,rdiff,rdiff6,pep_aa_tube
12690 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12691 C now we calculate gradient
12692 fac=(-12.0d0*pep_aa_tube/rdiff6+
12693 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12694 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12697 C now direction of gg_tube vector
12699 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12700 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12703 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12705 C Lets not jump over memory as we use many times iti
12707 C lets ommit dummy atoms for now
12709 C in UNRES uncomment the line below as GLY has no side-chain...
12712 vectube(1)=c(1,i+nres)
12713 vectube(1)=mod(vectube(1),boxxsize)
12714 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12715 vectube(2)=c(2,i+nres)
12716 vectube(2)=mod(vectube(2),boxxsize)
12717 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12719 vectube(1)=vectube(1)-tubecenter(1)
12720 vectube(2)=vectube(2)-tubecenter(2)
12722 C as the tube is infinity we do not calculate the Z-vector use of Z
12725 C now calculte the distance
12726 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12727 C now normalize vector
12728 vectube(1)=vectube(1)/tub_r
12729 vectube(2)=vectube(2)/tub_r
12730 C calculte rdiffrence between r and r0
12733 rdiff6=rdiff**6.0d0
12734 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12735 sc_aa_tube=sc_aa_tube_par(iti)
12736 sc_bb_tube=sc_bb_tube_par(iti)
12737 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12738 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12739 C now we calculate gradient
12740 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12741 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12742 C now direction of gg_tube vector
12744 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12745 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12749 Etube=Etube+enetube(i)
12751 C print *,"ETUBE", etube
12754 C TO DO 1) add to total energy
12755 C 2) add to gradient summation
12756 C 3) add reading parameters (AND of course oppening of PARAM file)
12757 C 4) add reading the center of tube
12759 C 6) add to zerograd
12761 C-----------------------------------------------------------------------
12762 C-----------------------------------------------------------
12763 C This subroutine is to mimic the histone like structure but as well can be
12764 C utilizet to nanostructures (infinit) small modification has to be used to
12765 C make it finite (z gradient at the ends has to be changes as well as the x,y
12766 C gradient has to be modified at the ends
12767 C The energy function is Kihara potential
12768 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12769 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12770 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12771 C simple Kihara potential
12772 subroutine calctube2(Etube)
12773 implicit real*8 (a-h,o-z)
12774 include 'DIMENSIONS'
12775 include 'COMMON.GEO'
12776 include 'COMMON.VAR'
12777 include 'COMMON.LOCAL'
12778 include 'COMMON.CHAIN'
12779 include 'COMMON.DERIV'
12780 include 'COMMON.NAMES'
12781 include 'COMMON.INTERACT'
12782 include 'COMMON.IOUNITS'
12783 include 'COMMON.CALC'
12784 include 'COMMON.CONTROL'
12785 include 'COMMON.SPLITELE'
12786 include 'COMMON.SBRIDGE'
12787 double precision tub_r,vectube(3),enetube(maxres*2)
12792 C first we calculate the distance from tube center
12793 C first sugare-phosphate group for NARES this would be peptide group
12796 C lets ommit dummy atoms for now
12797 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12798 C now calculate distance from center of tube and direction vectors
12799 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12800 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12801 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12802 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12803 vectube(1)=vectube(1)-tubecenter(1)
12804 vectube(2)=vectube(2)-tubecenter(2)
12806 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12807 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12809 C as the tube is infinity we do not calculate the Z-vector use of Z
12812 C now calculte the distance
12813 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12814 C now normalize vector
12815 vectube(1)=vectube(1)/tub_r
12816 vectube(2)=vectube(2)/tub_r
12817 C calculte rdiffrence between r and r0
12820 rdiff6=rdiff**6.0d0
12821 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12822 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12823 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12824 C print *,rdiff,rdiff6,pep_aa_tube
12825 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12826 C now we calculate gradient
12827 fac=(-12.0d0*pep_aa_tube/rdiff6+
12828 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12829 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12832 C now direction of gg_tube vector
12834 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12835 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12838 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12840 C Lets not jump over memory as we use many times iti
12842 C lets ommit dummy atoms for now
12844 C in UNRES uncomment the line below as GLY has no side-chain...
12847 vectube(1)=c(1,i+nres)
12848 vectube(1)=mod(vectube(1),boxxsize)
12849 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12850 vectube(2)=c(2,i+nres)
12851 vectube(2)=mod(vectube(2),boxxsize)
12852 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12854 vectube(1)=vectube(1)-tubecenter(1)
12855 vectube(2)=vectube(2)-tubecenter(2)
12856 C THIS FRAGMENT MAKES TUBE FINITE
12857 positi=(mod(c(3,i+nres),boxzsize))
12858 if (positi.le.0) positi=positi+boxzsize
12859 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12860 c for each residue check if it is in lipid or lipid water border area
12861 C respos=mod(c(3,i+nres),boxzsize)
12862 print *,positi,bordtubebot,buftubebot,bordtubetop
12863 if ((positi.gt.bordtubebot)
12864 & .and.(positi.lt.bordtubetop)) then
12865 C the energy transfer exist
12866 if (positi.lt.buftubebot) then
12868 & ((positi-bordtubebot)/tubebufthick)
12869 C lipbufthick is thickenes of lipid buffore
12870 sstube=sscalelip(fracinbuf)
12871 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12872 print *,ssgradtube, sstube,tubetranene(itype(i))
12873 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12874 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12875 &+ssgradtube*tubetranene(itype(i))
12876 gg_tube(3,i-1)= gg_tube(3,i-1)
12877 &+ssgradtube*tubetranene(itype(i))
12878 C print *,"doing sccale for lower part"
12879 elseif (positi.gt.buftubetop) then
12881 &((bordtubetop-positi)/tubebufthick)
12882 sstube=sscalelip(fracinbuf)
12883 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12884 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12885 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12886 C &+ssgradtube*tubetranene(itype(i))
12887 C gg_tube(3,i-1)= gg_tube(3,i-1)
12888 C &+ssgradtube*tubetranene(itype(i))
12889 C print *, "doing sscalefor top part",sslip,fracinbuf
12893 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12894 C print *,"I am in true lipid"
12900 endif ! if in lipid or buffor
12901 CEND OF FINITE FRAGMENT
12902 C as the tube is infinity we do not calculate the Z-vector use of Z
12905 C now calculte the distance
12906 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12907 C now normalize vector
12908 vectube(1)=vectube(1)/tub_r
12909 vectube(2)=vectube(2)/tub_r
12910 C calculte rdiffrence between r and r0
12913 rdiff6=rdiff**6.0d0
12914 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12915 sc_aa_tube=sc_aa_tube_par(iti)
12916 sc_bb_tube=sc_bb_tube_par(iti)
12917 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12918 & *sstube+enetube(i+nres)
12919 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12920 C now we calculate gradient
12921 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12922 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12923 C now direction of gg_tube vector
12925 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12926 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12928 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12929 &+ssgradtube*enetube(i+nres)/sstube
12930 gg_tube(3,i-1)= gg_tube(3,i-1)
12931 &+ssgradtube*enetube(i+nres)/sstube
12935 Etube=Etube+enetube(i)
12937 C print *,"ETUBE", etube
12940 C TO DO 1) add to total energy
12941 C 2) add to gradient summation
12942 C 3) add reading parameters (AND of course oppening of PARAM file)
12943 C 4) add reading the center of tube
12945 C 6) add to zerograd
12946 c----------------------------------------------------------------------------
12947 subroutine e_saxs(Esaxs_constr)
12949 include 'DIMENSIONS'
12952 include "COMMON.SETUP"
12955 include 'COMMON.SBRIDGE'
12956 include 'COMMON.CHAIN'
12957 include 'COMMON.GEO'
12958 include 'COMMON.DERIV'
12959 include 'COMMON.LOCAL'
12960 include 'COMMON.INTERACT'
12961 include 'COMMON.VAR'
12962 include 'COMMON.IOUNITS'
12963 c include 'COMMON.MD'
12966 include 'COMMON.LANGEVIN.lang0.5diag'
12968 include 'COMMON.LANGEVIN.lang0'
12971 include 'COMMON.LANGEVIN'
12973 include 'COMMON.CONTROL'
12974 include 'COMMON.SAXS'
12975 include 'COMMON.NAMES'
12976 include 'COMMON.TIME1'
12977 include 'COMMON.FFIELD'
12979 double precision Esaxs_constr
12980 integer i,iint,j,k,l
12981 double precision PgradC(maxSAXS,3,maxres),
12982 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12984 double precision PgradC_(maxSAXS,3,maxres),
12985 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12987 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12988 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12989 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12990 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12991 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12992 double precision dist,mygauss,mygaussder
12994 integer llicz,lllicz
12995 double precision time01
12996 c SAXS restraint penalty function
12998 write(iout,*) "------- SAXS penalty function start -------"
12999 write (iout,*) "nsaxs",nsaxs
13000 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13001 write (iout,*) "Psaxs"
13003 write (iout,'(i5,e15.5)') i, Psaxs(i)
13009 Esaxs_constr = 0.0d0
13014 PgradC(k,l,j)=0.0d0
13015 PgradX(k,l,j)=0.0d0
13020 do i=iatsc_s,iatsc_e
13021 if (itype(i).eq.ntyp1) cycle
13022 do iint=1,nint_gr(i)
13023 do j=istart(i,iint),iend(i,iint)
13024 if (itype(j).eq.ntyp1) cycle
13027 dijCASC=dist(i,j+nres)
13028 dijSCCA=dist(i+nres,j)
13029 dijSCSC=dist(i+nres,j+nres)
13030 sigma2CACA=2.0d0/(pstok**2)
13031 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13032 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13033 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13036 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13037 if (itype(j).ne.10) then
13038 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13042 if (itype(i).ne.10) then
13043 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13047 if (itype(i).ne.10 .and. itype(j).ne.10) then
13048 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13052 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13054 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13056 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13057 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13058 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13059 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13062 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13063 PgradC(k,l,i) = PgradC(k,l,i)-aux
13064 PgradC(k,l,j) = PgradC(k,l,j)+aux
13066 if (itype(j).ne.10) then
13067 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13068 PgradC(k,l,i) = PgradC(k,l,i)-aux
13069 PgradC(k,l,j) = PgradC(k,l,j)+aux
13070 PgradX(k,l,j) = PgradX(k,l,j)+aux
13073 if (itype(i).ne.10) then
13074 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13075 PgradX(k,l,i) = PgradX(k,l,i)-aux
13076 PgradC(k,l,i) = PgradC(k,l,i)-aux
13077 PgradC(k,l,j) = PgradC(k,l,j)+aux
13080 if (itype(i).ne.10 .and. itype(j).ne.10) then
13081 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13082 PgradC(k,l,i) = PgradC(k,l,i)-aux
13083 PgradC(k,l,j) = PgradC(k,l,j)+aux
13084 PgradX(k,l,i) = PgradX(k,l,i)-aux
13085 PgradX(k,l,j) = PgradX(k,l,j)+aux
13091 sigma2CACA=scal_rad**2*0.25d0/
13092 & (restok(itype(j))**2+restok(itype(i))**2)
13093 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13094 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13096 sigmaCACA=dsqrt(sigma2CACA)
13097 threesig=3.0d0/sigmaCACA
13101 if (dabs(dijCACA-dk).ge.threesig) cycle
13104 aux = sigmaCACA*(dijCACA-dk)
13105 expCACA = mygauss(aux)
13106 c if (expcaca.eq.0.0d0) cycle
13107 Pcalc(k) = Pcalc(k)+expCACA
13108 CACAgrad = -sigmaCACA*mygaussder(aux)
13109 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13111 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13112 PgradC(k,l,i) = PgradC(k,l,i)-aux
13113 PgradC(k,l,j) = PgradC(k,l,j)+aux
13116 c write (iout,*) "i",i," j",j," llicz",llicz
13118 IF (saxs_cutoff.eq.0) THEN
13121 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13122 Pcalc(k) = Pcalc(k)+expCACA
13123 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13125 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13126 PgradC(k,l,i) = PgradC(k,l,i)-aux
13127 PgradC(k,l,j) = PgradC(k,l,j)+aux
13131 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13134 c write (2,*) "ijk",i,j,k
13135 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13136 if (sss2.eq.0.0d0) cycle
13137 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13138 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13139 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13140 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13142 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13143 Pcalc(k) = Pcalc(k)+expCACA
13145 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13147 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13148 & ssgrad2*expCACA/sss2
13151 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13152 PgradC(k,l,i) = PgradC(k,l,i)+aux
13153 PgradC(k,l,j) = PgradC(k,l,j)-aux
13163 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13165 c write (iout,*) "lllicz",lllicz
13167 c time01=MPI_Wtime()
13170 if (nfgtasks.gt.1) then
13171 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13172 & MPI_SUM,FG_COMM,IERR)
13173 c if (fg_rank.eq.king) then
13175 Pcalc(k) = Pcalc_(k)
13178 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13179 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13180 c if (fg_rank.eq.king) then
13184 c PgradC(k,l,i) = PgradC_(k,l,i)
13190 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13191 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13192 c if (fg_rank.eq.king) then
13196 c PgradX(k,l,i) = PgradX_(k,l,i)
13206 Cnorm = Cnorm + Pcalc(k)
13209 if (fg_rank.eq.king) then
13211 Esaxs_constr = dlog(Cnorm)-wsaxs0
13213 if (Pcalc(k).gt.0.0d0)
13214 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13216 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13220 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13235 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13236 auxC1 = auxC1+PgradC(k,l,i)
13238 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13239 auxX1 = auxX1+PgradX(k,l,i)
13242 gsaxsC(l,i) = auxC - auxC1/Cnorm
13244 gsaxsX(l,i) = auxX - auxX1/Cnorm
13246 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13247 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13248 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13249 c * " gradX",wsaxs*gsaxsX(l,i)
13253 time_SAXS=time_SAXS+MPI_Wtime()-time01
13256 write (iout,*) "gsaxsc"
13258 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13266 c----------------------------------------------------------------------------
13267 subroutine e_saxsC(Esaxs_constr)
13269 include 'DIMENSIONS'
13272 include "COMMON.SETUP"
13275 include 'COMMON.SBRIDGE'
13276 include 'COMMON.CHAIN'
13277 include 'COMMON.GEO'
13278 include 'COMMON.DERIV'
13279 include 'COMMON.LOCAL'
13280 include 'COMMON.INTERACT'
13281 include 'COMMON.VAR'
13282 include 'COMMON.IOUNITS'
13283 c include 'COMMON.MD'
13286 include 'COMMON.LANGEVIN.lang0.5diag'
13288 include 'COMMON.LANGEVIN.lang0'
13291 include 'COMMON.LANGEVIN'
13293 include 'COMMON.CONTROL'
13294 include 'COMMON.SAXS'
13295 include 'COMMON.NAMES'
13296 include 'COMMON.TIME1'
13297 include 'COMMON.FFIELD'
13299 double precision Esaxs_constr
13300 integer i,iint,j,k,l
13301 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13303 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13305 double precision dk,dijCASPH,dijSCSPH,
13306 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13307 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13309 c SAXS restraint penalty function
13311 write(iout,*) "------- SAXS penalty function start -------"
13312 write (iout,*) "nsaxs",nsaxs
13315 print *,MyRank,"C",i,(C(j,i),j=1,3)
13318 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13321 Esaxs_constr = 0.0d0
13323 do j=isaxs_start,isaxs_end
13332 if (itype(i).eq.ntyp1) cycle
13336 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13338 if (itype(i).ne.10) then
13340 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13343 sigma2CA=2.0d0/pstok**2
13344 sigma2SC=4.0d0/restok(itype(i))**2
13345 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13346 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13347 Pcalc = Pcalc+expCASPH+expSCSPH
13349 write(*,*) "processor i j Pcalc",
13350 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13352 CASPHgrad = sigma2CA*expCASPH
13353 SCSPHgrad = sigma2SC*expSCSPH
13355 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13356 PgradX(l,i) = PgradX(l,i) + aux
13357 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13362 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13363 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13366 logPtot = logPtot - dlog(Pcalc)
13367 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13368 c & " logPtot",logPtot
13371 if (nfgtasks.gt.1) then
13372 c write (iout,*) "logPtot before reduction",logPtot
13373 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13374 & MPI_SUM,king,FG_COMM,IERR)
13376 c write (iout,*) "logPtot after reduction",logPtot
13377 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13378 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13379 if (fg_rank.eq.king) then
13382 gsaxsC(l,i) = gsaxsC_(l,i)
13386 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13387 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13388 if (fg_rank.eq.king) then
13391 gsaxsX(l,i) = gsaxsX_(l,i)
13397 Esaxs_constr = logPtot
13400 c----------------------------------------------------------------------------
13401 double precision function sscale2(r,r_cut,r0,rlamb)
13403 double precision r,gamm,r_cut,r0,rlamb,rr
13405 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13406 c write (2,*) "rr",rr
13407 if(rr.lt.r_cut-rlamb) then
13409 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13410 gamm=(rr-(r_cut-rlamb))/rlamb
13411 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13417 C-----------------------------------------------------------------------
13418 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13420 double precision r,gamm,r_cut,r0,rlamb,rr
13422 if(rr.lt.r_cut-rlamb) then
13424 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13425 gamm=(rr-(r_cut-rlamb))/rlamb
13427 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13429 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13436 c------------------------------------------------------------------------
13437 double precision function boxshift(x,boxsize)
13439 double precision x,boxsize
13440 double precision xtemp
13441 xtemp=dmod(x,boxsize)
13442 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13443 boxshift=xtemp-boxsize
13444 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13445 boxshift=xtemp+boxsize
13451 c--------------------------------------------------------------------------
13452 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13453 include 'DIMENSIONS'
13454 include 'COMMON.CHAIN'
13455 integer xshift,yshift,zshift,subchap
13456 double precision dist_init,xj_safe,yj_safe,zj_safe,
13457 & xj_temp,yj_temp,zj_temp,dist_temp
13461 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13466 xj=xj_safe+xshift*boxxsize
13467 yj=yj_safe+yshift*boxysize
13468 zj=zj_safe+zshift*boxzsize
13469 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13470 if(dist_temp.lt.dist_init) then
13471 dist_init=dist_temp
13480 if (subchap.eq.1) then
13491 c--------------------------------------------------------------------------
13492 subroutine to_box(xi,yi,zi)
13494 include 'DIMENSIONS'
13495 include 'COMMON.CHAIN'
13496 double precision xi,yi,zi
13497 xi=dmod(xi,boxxsize)
13498 if (xi.lt.0.0d0) xi=xi+boxxsize
13499 yi=dmod(yi,boxysize)
13500 if (yi.lt.0.0d0) yi=yi+boxysize
13501 zi=dmod(zi,boxzsize)
13502 if (zi.lt.0.0d0) zi=zi+boxzsize
13505 c--------------------------------------------------------------------------
13506 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13508 include 'DIMENSIONS'
13509 include 'COMMON.IOUNITS'
13510 include 'COMMON.CHAIN'
13511 double precision xi,yi,zi,sslipi,ssgradlipi
13512 double precision fracinbuf
13513 double precision sscalelip,sscagradlip
13515 write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13516 write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13517 write (iout,*) "xi yi zi",xi,yi,zi
13519 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13520 C the energy transfer exist
13521 if (zi.lt.buflipbot) then
13522 C what fraction I am in
13523 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13524 C lipbufthick is thickenes of lipid buffore
13525 sslipi=sscalelip(fracinbuf)
13526 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13527 elseif (zi.gt.bufliptop) then
13528 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13529 sslipi=sscalelip(fracinbuf)
13530 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13540 write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi