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'
33 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
34 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
35 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
36 & eliptran,Eafmforce,Etube,
37 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
38 integer n_corr,n_corr1
40 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
41 c & " nfgtasks",nfgtasks
42 if (nfgtasks.gt.1) then
44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
45 if (fg_rank.eq.0) then
46 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
47 c print *,"Processor",myrank," BROADCAST iorder"
48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
49 C FG slaves as WEIGHTS array.
72 weights_(28)=wdfa_dist
75 weights_(31)=wdfa_beta
76 C FG Master broadcasts the WEIGHTS_ array
77 call MPI_Bcast(weights_(1),n_ene,
78 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
80 C FG slaves receive the WEIGHTS array
81 call MPI_Bcast(weights(1),n_ene,
82 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
105 wdfa_dist=weights_(28)
106 wdfa_tor=weights_(29)
107 wdfa_nei=weights_(30)
108 wdfa_beta=weights_(31)
110 time_Bcast=time_Bcast+MPI_Wtime()-time00
111 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
112 c call chainbuild_cart
120 c print *,'Processor',myrank,' calling etotal ipot=',ipot
121 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
123 c if (modecalc.eq.12.or.modecalc.eq.14) then
124 c call int_from_cart1(.false.)
131 C Compute the side-chain and electrostatic interaction energy
134 goto (101,102,103,104,105,106) ipot
135 C Lennard-Jones potential.
137 cd print '(a)','Exit ELJ'
139 C Lennard-Jones-Kihara potential (shifted).
142 C Berne-Pechukas potential (dilated LJ, angular dependence).
145 C Gay-Berne potential (shifted LJ, angular dependence).
147 C print *,"bylem w egb"
149 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
152 C Soft-sphere potential
153 106 call e_softsphere(evdw)
155 C Calculate electrostatic (H-bonding) energy of the main chain.
159 C BARTEK for dfa test!
160 if (wdfa_dist.gt.0) then
165 c print*, 'edfad is finished!', edfadis
166 if (wdfa_tor.gt.0) then
171 c print*, 'edfat is finished!', edfator
172 if (wdfa_nei.gt.0) then
177 c print*, 'edfan is finished!', edfanei
178 if (wdfa_beta.gt.0) then
185 cmc Sep-06: egb takes care of dynamic ss bonds too
187 c if (dyn_ss) call dyn_set_nss
189 c print *,"Processor",myrank," computed USCSC"
195 time_vec=time_vec+MPI_Wtime()-time01
197 C Introduction of shielding effect first for each peptide group
198 C the shielding factor is set this factor is describing how each
199 C peptide group is shielded by side-chains
200 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
201 C write (iout,*) "shield_mode",shield_mode
202 if (shield_mode.eq.1) then
204 else if (shield_mode.eq.2) then
207 c print *,"Processor",myrank," left VEC_AND_DERIV"
210 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
211 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
212 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
213 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
215 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
216 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
217 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
218 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
220 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
229 write (iout,*) "Soft-spheer ELEC potential"
230 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
234 c time_enecalc=time_enecalc+MPI_Wtime()-time00
236 c print *,"Processor",myrank," computed UELEC"
238 C Calculate excluded-volume interaction energy between peptide groups
243 call escp(evdw2,evdw2_14)
249 c write (iout,*) "Soft-sphere SCP potential"
250 call escp_soft_sphere(evdw2,evdw2_14)
253 c Calculate the bond-stretching energy
257 C Calculate the disulfide-bridge and other energy and the contributions
258 C from other distance constraints.
259 cd write (iout,*) 'Calling EHPB'
261 cd print *,'EHPB exitted succesfully.'
263 C Calculate the virtual-bond-angle energy.
265 if (wang.gt.0d0) then
266 if (tor_mode.eq.0) then
269 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
277 if (with_theta_constr) call etheta_constr(ethetacnstr)
278 c print *,"Processor",myrank," computed UB"
280 C Calculate the SC local energy.
282 C print *,"TU DOCHODZE?"
284 c print *,"Processor",myrank," computed USC"
286 C Calculate the virtual-bond torsional energy.
288 cd print *,'nterm=',nterm
289 C print *,"tor",tor_mode
290 if (wtor.gt.0.0d0) then
291 if (tor_mode.eq.0) then
294 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
302 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
303 c print *,"Processor",myrank," computed Utor"
304 if (constr_homology.ge.1) then
305 call e_modeller(ehomology_constr)
306 c print *,'iset=',iset,'me=',me,ehomology_constr,
307 c & 'Processor',fg_rank,' CG group',kolor,
308 c & ' absolute rank',MyRank
310 ehomology_constr=0.0d0
313 C 6/23/01 Calculate double-torsional energy
315 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
320 c print *,"Processor",myrank," computed Utord"
322 C 21/5/07 Calculate local sicdechain correlation energy
324 if (wsccor.gt.0.0d0) then
325 call eback_sc_corr(esccor)
330 C print *,"PRZED MULIt"
331 c print *,"Processor",myrank," computed Usccorr"
333 C 12/1/95 Multi-body terms
337 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
338 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
339 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
340 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
341 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
349 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
350 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
353 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
354 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
359 c print *,"Processor",myrank," computed Ucorr"
360 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
361 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
362 call e_saxs(Esaxs_constr)
363 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
364 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
365 call e_saxsC(Esaxs_constr)
366 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
371 C If performing constraint dynamics, call the constraint energy
372 C after the equilibration time
373 c if(usampl.and.totT.gt.eq_time) then
374 c write (iout,*) "usampl",usampl
378 call Econstr_back_qlike
386 C 01/27/2015 added by adasko
387 C the energy component below is energy transfer into lipid environment
388 C based on partition function
389 C print *,"przed lipidami"
390 if (wliptran.gt.0) then
391 call Eliptransfer(eliptran)
395 C print *,"za lipidami"
396 if (AFMlog.gt.0) then
397 call AFMforce(Eafmforce)
398 else if (selfguide.gt.0) then
399 call AFMvel(Eafmforce)
401 if (TUBElog.eq.1) then
402 C print *,"just before call"
404 elseif (TUBElog.eq.2) then
405 call calctube2(Etube)
411 time_enecalc=time_enecalc+MPI_Wtime()-time00
413 c print *,"Processor",myrank," computed Uconstr"
422 energia(2)=evdw2-evdw2_14
439 energia(8)=eello_turn3
440 energia(9)=eello_turn4
447 energia(19)=edihcnstr
449 energia(20)=Uconst+Uconst_back
452 energia(23)=Eafmforce
453 energia(24)=ethetacnstr
455 energia(26)=Esaxs_constr
456 energia(27)=ehomology_constr
461 c write (iout,*) "esaxs_constr",energia(26)
462 c Here are the energies showed per procesor if the are more processors
463 c per molecule then we sum it up in sum_energy subroutine
464 c print *," Processor",myrank," calls SUM_ENERGY"
465 call sum_energy(energia,.true.)
466 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
467 if (dyn_ss) call dyn_set_nss
468 c print *," Processor",myrank," left SUM_ENERGY"
470 time_sumene=time_sumene+MPI_Wtime()-time00
474 c-------------------------------------------------------------------------------
475 subroutine sum_energy(energia,reduce)
481 cMS$ATTRIBUTES C :: proc_proc
487 double precision time00
489 include 'COMMON.SETUP'
490 include 'COMMON.IOUNITS'
491 double precision energia(0:n_ene),enebuff(0:n_ene+1)
492 include 'COMMON.FFIELD'
493 include 'COMMON.DERIV'
494 include 'COMMON.INTERACT'
495 include 'COMMON.SBRIDGE'
496 include 'COMMON.CHAIN'
498 include 'COMMON.CONTROL'
499 include 'COMMON.TIME1'
502 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
503 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
504 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
505 & eliptran,Eafmforce,Etube,
506 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
507 double precision Uconst,etot
509 if (nfgtasks.gt.1 .and. reduce) then
511 write (iout,*) "energies before REDUCE"
512 call enerprint(energia)
516 enebuff(i)=energia(i)
519 call MPI_Barrier(FG_COMM,IERR)
520 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
522 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
523 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
525 write (iout,*) "energies after REDUCE"
526 call enerprint(energia)
529 time_Reduce=time_Reduce+MPI_Wtime()-time00
531 if (fg_rank.eq.0) then
535 evdw2=energia(2)+energia(18)
551 eello_turn3=energia(8)
552 eello_turn4=energia(9)
559 edihcnstr=energia(19)
564 Eafmforce=energia(23)
565 ethetacnstr=energia(24)
567 esaxs_constr=energia(26)
568 ehomology_constr=energia(27)
574 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
575 & +wang*ebe+wtor*etors+wscloc*escloc
576 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
577 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
578 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
579 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
580 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
581 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
584 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
585 & +wang*ebe+wtor*etors+wscloc*escloc
586 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
587 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
588 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
589 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
591 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
592 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
599 if (isnan(etot).ne.0) energia(0)=1.0d+99
601 if (isnan(etot)) energia(0)=1.0d+99
606 idumm=proc_proc(etot,i)
608 call proc_proc(etot,i)
610 if(i.eq.1)energia(0)=1.0d+99
617 c-------------------------------------------------------------------------------
618 subroutine sum_gradient
624 cMS$ATTRIBUTES C :: proc_proc
630 double precision time00,time01
632 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
633 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
634 & ,gloc_scbuf(3,-1:maxres)
635 include 'COMMON.SETUP'
636 include 'COMMON.IOUNITS'
637 include 'COMMON.FFIELD'
638 include 'COMMON.DERIV'
639 include 'COMMON.INTERACT'
640 include 'COMMON.SBRIDGE'
641 include 'COMMON.CHAIN'
643 include 'COMMON.CONTROL'
644 include 'COMMON.TIME1'
645 include 'COMMON.MAXGRAD'
646 include 'COMMON.SCCOR'
647 c include 'COMMON.MD'
648 include 'COMMON.QRESTR'
650 double precision scalar
651 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
652 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
653 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
654 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
655 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
661 write (iout,*) "sum_gradient gvdwc, gvdwx"
663 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
664 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
669 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
671 write (iout,'(i3,3e15.5,5x,3e15.5)')
672 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
677 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
678 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
679 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
682 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
683 C in virtual-bond-vector coordinates
686 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
688 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
689 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
691 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
693 c write (iout,'(i5,3f10.5,2x,f10.5)')
694 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
696 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
698 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
699 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
705 write (iout,*) "gsaxsc"
707 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
714 gradbufc(j,i)=wsc*gvdwc(j,i)+
715 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
716 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
717 & wel_loc*gel_loc_long(j,i)+
718 & wcorr*gradcorr_long(j,i)+
719 & wcorr5*gradcorr5_long(j,i)+
720 & wcorr6*gradcorr6_long(j,i)+
721 & wturn6*gcorr6_turn_long(j,i)+
723 & +wliptran*gliptranc(j,i)
725 & +welec*gshieldc(j,i)
726 & +wcorr*gshieldc_ec(j,i)
727 & +wturn3*gshieldc_t3(j,i)
728 & +wturn4*gshieldc_t4(j,i)
729 & +wel_loc*gshieldc_ll(j,i)
730 & +wtube*gg_tube(j,i)
737 gradbufc(j,i)=wsc*gvdwc(j,i)+
738 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
739 & welec*gelc_long(j,i)+
741 & wel_loc*gel_loc_long(j,i)+
742 & wcorr*gradcorr_long(j,i)+
743 & wcorr5*gradcorr5_long(j,i)+
744 & wcorr6*gradcorr6_long(j,i)+
745 & wturn6*gcorr6_turn_long(j,i)+
747 & +wliptran*gliptranc(j,i)
749 & +welec*gshieldc(j,i)
750 & +wcorr*gshieldc_ec(j,i)
751 & +wturn4*gshieldc_t4(j,i)
752 & +wel_loc*gshieldc_ll(j,i)
753 & +wtube*gg_tube(j,i)
760 gradbufc(j,i)=gradbufc(j,i)+
761 & wdfa_dist*gdfad(j,i)+
762 & wdfa_tor*gdfat(j,i)+
763 & wdfa_nei*gdfan(j,i)+
764 & wdfa_beta*gdfab(j,i)
768 write (iout,*) "gradc from gradbufc"
770 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
775 if (nfgtasks.gt.1) then
778 write (iout,*) "gradbufc before allreduce"
780 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
786 gradbufc_sum(j,i)=gradbufc(j,i)
789 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
790 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
791 c time_reduce=time_reduce+MPI_Wtime()-time00
793 c write (iout,*) "gradbufc_sum after allreduce"
795 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
800 c time_allreduce=time_allreduce+MPI_Wtime()-time00
808 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
809 write (iout,*) (i," jgrad_start",jgrad_start(i),
810 & " jgrad_end ",jgrad_end(i),
811 & i=igrad_start,igrad_end)
814 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
815 c do not parallelize this part.
817 c do i=igrad_start,igrad_end
818 c do j=jgrad_start(i),jgrad_end(i)
820 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
825 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
829 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
833 write (iout,*) "gradbufc after summing"
835 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
842 write (iout,*) "gradbufc"
844 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
850 gradbufc_sum(j,i)=gradbufc(j,i)
855 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
859 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
864 c gradbufc(k,i)=0.0d0
868 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
873 write (iout,*) "gradbufc after summing"
875 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
883 gradbufc(k,nres)=0.0d0
888 C print *,gradbufc(1,13)
889 C print *,welec*gelc(1,13)
890 C print *,wel_loc*gel_loc(1,13)
891 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
892 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
893 C print *,wel_loc*gel_loc_long(1,13)
894 C print *,gradafm(1,13),"AFM"
895 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
896 & wel_loc*gel_loc(j,i)+
897 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
898 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
899 & wel_loc*gel_loc_long(j,i)+
900 & wcorr*gradcorr_long(j,i)+
901 & wcorr5*gradcorr5_long(j,i)+
902 & wcorr6*gradcorr6_long(j,i)+
903 & wturn6*gcorr6_turn_long(j,i))+
905 & wcorr*gradcorr(j,i)+
906 & wturn3*gcorr3_turn(j,i)+
907 & wturn4*gcorr4_turn(j,i)+
908 & wcorr5*gradcorr5(j,i)+
909 & wcorr6*gradcorr6(j,i)+
910 & wturn6*gcorr6_turn(j,i)+
911 & wsccor*gsccorc(j,i)
912 & +wscloc*gscloc(j,i)
913 & +wliptran*gliptranc(j,i)
915 & +welec*gshieldc(j,i)
916 & +welec*gshieldc_loc(j,i)
917 & +wcorr*gshieldc_ec(j,i)
918 & +wcorr*gshieldc_loc_ec(j,i)
919 & +wturn3*gshieldc_t3(j,i)
920 & +wturn3*gshieldc_loc_t3(j,i)
921 & +wturn4*gshieldc_t4(j,i)
922 & +wturn4*gshieldc_loc_t4(j,i)
923 & +wel_loc*gshieldc_ll(j,i)
924 & +wel_loc*gshieldc_loc_ll(j,i)
925 & +wtube*gg_tube(j,i)
928 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
929 & wel_loc*gel_loc(j,i)+
930 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
931 & welec*gelc_long(j,i)+
932 & wel_loc*gel_loc_long(j,i)+
933 & wcorr*gcorr_long(j,i)+
934 & wcorr5*gradcorr5_long(j,i)+
935 & wcorr6*gradcorr6_long(j,i)+
936 & wturn6*gcorr6_turn_long(j,i))+
938 & wcorr*gradcorr(j,i)+
939 & wturn3*gcorr3_turn(j,i)+
940 & wturn4*gcorr4_turn(j,i)+
941 & wcorr5*gradcorr5(j,i)+
942 & wcorr6*gradcorr6(j,i)+
943 & wturn6*gcorr6_turn(j,i)+
944 & wsccor*gsccorc(j,i)
945 & +wscloc*gscloc(j,i)
946 & +wliptran*gliptranc(j,i)
948 & +welec*gshieldc(j,i)
949 & +welec*gshieldc_loc(j,i)
950 & +wcorr*gshieldc_ec(j,i)
951 & +wcorr*gshieldc_loc_ec(j,i)
952 & +wturn3*gshieldc_t3(j,i)
953 & +wturn3*gshieldc_loc_t3(j,i)
954 & +wturn4*gshieldc_t4(j,i)
955 & +wturn4*gshieldc_loc_t4(j,i)
956 & +wel_loc*gshieldc_ll(j,i)
957 & +wel_loc*gshieldc_loc_ll(j,i)
958 & +wtube*gg_tube(j,i)
962 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
964 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
965 & wsccor*gsccorx(j,i)
966 & +wscloc*gsclocx(j,i)
967 & +wliptran*gliptranx(j,i)
968 & +welec*gshieldx(j,i)
969 & +wcorr*gshieldx_ec(j,i)
970 & +wturn3*gshieldx_t3(j,i)
971 & +wturn4*gshieldx_t4(j,i)
972 & +wel_loc*gshieldx_ll(j,i)
973 & +wtube*gg_tube_sc(j,i)
980 if (constr_homology.gt.0) then
983 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
984 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
989 write (iout,*) "gradc gradx gloc after adding"
991 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
992 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
996 write (iout,*) "gloc before adding corr"
998 write (iout,*) i,gloc(i,icg)
1002 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1003 & +wcorr5*g_corr5_loc(i)
1004 & +wcorr6*g_corr6_loc(i)
1005 & +wturn4*gel_loc_turn4(i)
1006 & +wturn3*gel_loc_turn3(i)
1007 & +wturn6*gel_loc_turn6(i)
1008 & +wel_loc*gel_loc_loc(i)
1011 write (iout,*) "gloc after adding corr"
1013 write (iout,*) i,gloc(i,icg)
1017 if (nfgtasks.gt.1) then
1020 gradbufc(j,i)=gradc(j,i,icg)
1021 gradbufx(j,i)=gradx(j,i,icg)
1025 glocbuf(i)=gloc(i,icg)
1029 write (iout,*) "gloc_sc before reduce"
1032 write (iout,*) i,j,gloc_sc(j,i,icg)
1039 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1043 call MPI_Barrier(FG_COMM,IERR)
1044 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1046 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1047 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1048 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1049 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1050 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1051 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1052 time_reduce=time_reduce+MPI_Wtime()-time00
1053 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1054 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1055 time_reduce=time_reduce+MPI_Wtime()-time00
1057 write (iout,*) "gradc after reduce"
1060 write (iout,*) i,j,gradc(j,i,icg)
1065 write (iout,*) "gloc_sc after reduce"
1068 write (iout,*) i,j,gloc_sc(j,i,icg)
1073 write (iout,*) "gloc after reduce"
1075 write (iout,*) i,gloc(i,icg)
1080 if (gnorm_check) then
1082 c Compute the maximum elements of the gradient
1092 gcorr3_turn_max=0.0d0
1093 gcorr4_turn_max=0.0d0
1096 gcorr6_turn_max=0.0d0
1106 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1107 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1108 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1109 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1110 & gvdwc_scp_max=gvdwc_scp_norm
1111 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1112 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1113 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1114 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1115 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1116 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1117 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1118 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1119 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1120 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1121 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1122 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1123 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1124 & gcorr3_turn(1,i)))
1125 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1126 & gcorr3_turn_max=gcorr3_turn_norm
1127 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1128 & gcorr4_turn(1,i)))
1129 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1130 & gcorr4_turn_max=gcorr4_turn_norm
1131 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1132 if (gradcorr5_norm.gt.gradcorr5_max)
1133 & gradcorr5_max=gradcorr5_norm
1134 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1135 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1136 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1137 & gcorr6_turn(1,i)))
1138 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1139 & gcorr6_turn_max=gcorr6_turn_norm
1140 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1141 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1142 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1143 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1144 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1145 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1146 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1147 if (gradx_scp_norm.gt.gradx_scp_max)
1148 & gradx_scp_max=gradx_scp_norm
1149 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1150 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1151 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1152 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1153 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1154 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1155 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1156 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1159 #if (defined AIX || defined CRAY)
1160 open(istat,file=statname,position="append")
1162 open(istat,file=statname,access="append")
1164 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1165 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1166 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1167 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1168 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1169 & gsccorrx_max,gsclocx_max
1171 if (gvdwc_max.gt.1.0d4) then
1172 write (iout,*) "gvdwc gvdwx gradb gradbx"
1174 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1175 & gradb(j,i),gradbx(j,i),j=1,3)
1177 call pdbout(0.0d0,'cipiszcze',iout)
1183 write (iout,*) "gradc gradx gloc"
1185 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1186 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1190 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1194 c-------------------------------------------------------------------------------
1195 subroutine rescale_weights(t_bath)
1201 include 'DIMENSIONS'
1202 include 'COMMON.IOUNITS'
1203 include 'COMMON.FFIELD'
1204 include 'COMMON.SBRIDGE'
1205 include 'COMMON.CONTROL'
1206 double precision t_bath
1207 double precision facT,facT2,facT3,facT4,facT5
1208 double precision kfac /2.4d0/
1209 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1211 c facT=2*temp0/(t_bath+temp0)
1212 if (rescale_mode.eq.0) then
1218 else if (rescale_mode.eq.1) then
1219 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1220 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1221 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1222 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1223 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1224 else if (rescale_mode.eq.2) then
1230 facT=licznik/dlog(dexp(x)+dexp(-x))
1231 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1232 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1233 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1234 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1236 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1237 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1239 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1243 if (shield_mode.gt.0) then
1244 wscp=weights(2)*fact
1246 wvdwpp=weights(16)*fact
1248 welec=weights(3)*fact
1249 wcorr=weights(4)*fact3
1250 wcorr5=weights(5)*fact4
1251 wcorr6=weights(6)*fact5
1252 wel_loc=weights(7)*fact2
1253 wturn3=weights(8)*fact2
1254 wturn4=weights(9)*fact3
1255 wturn6=weights(10)*fact5
1256 wtor=weights(13)*fact
1257 wtor_d=weights(14)*fact2
1258 wsccor=weights(21)*fact
1259 if (scale_umb) wumb=t_bath/temp0
1260 c write (iout,*) "scale_umb",scale_umb
1261 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1265 C------------------------------------------------------------------------
1266 subroutine enerprint(energia)
1268 include 'DIMENSIONS'
1269 include 'COMMON.IOUNITS'
1270 include 'COMMON.FFIELD'
1271 include 'COMMON.SBRIDGE'
1272 include 'COMMON.QRESTR'
1273 double precision energia(0:n_ene)
1274 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1275 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1276 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1278 & eliptran,Eafmforce,Etube,
1279 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1284 evdw2=energia(2)+energia(18)
1296 eello_turn3=energia(8)
1297 eello_turn4=energia(9)
1298 eello_turn6=energia(10)
1304 edihcnstr=energia(19)
1308 eliptran=energia(22)
1309 Eafmforce=energia(23)
1310 ethetacnstr=energia(24)
1313 ehomology_constr=energia(27)
1315 edfadis = energia(28)
1316 edfator = energia(29)
1317 edfanei = energia(30)
1318 edfabet = energia(31)
1320 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1321 & estr,wbond,ebe,wang,
1322 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1325 & ecorr5,wcorr5,ecorr6,wcorr6,
1327 & eel_loc,wel_loc,eello_turn3,wturn3,
1328 & eello_turn4,wturn4,
1330 & eello_turn6,wturn6,
1332 & esccor,wsccor,edihcnstr,
1333 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1334 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1335 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1336 & edfabet,wdfa_beta,
1338 10 format (/'Virtual-chain energies:'//
1339 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1340 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1341 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1342 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1343 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1344 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1345 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1346 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1347 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1348 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1349 & ' (SS bridges & dist. cnstr.)'/
1351 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1352 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1353 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1355 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1356 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1357 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1359 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1361 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1362 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1363 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1364 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1365 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1366 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1367 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1368 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1369 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1370 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1371 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1372 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1373 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1374 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1375 & 'ETOT= ',1pE16.6,' (total)')
1378 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1379 & estr,wbond,ebe,wang,
1380 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1383 & ecorr5,wcorr5,ecorr6,wcorr6,
1385 & eel_loc,wel_loc,eello_turn3,wturn3,
1386 & eello_turn4,wturn4,
1388 & eello_turn6,wturn6,
1390 & esccor,wsccor,edihcnstr,
1391 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1392 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1393 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1394 & edfabet,wdfa_beta,
1396 10 format (/'Virtual-chain energies:'//
1397 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1398 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1399 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1400 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1401 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1402 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1403 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1404 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1405 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1406 & ' (SS bridges & dist. restr.)'/
1408 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1409 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1410 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1412 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1413 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1414 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1416 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1418 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1419 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1420 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1421 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1422 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1423 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1424 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1425 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1426 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1427 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1428 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1429 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1430 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1431 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1432 & 'ETOT= ',1pE16.6,' (total)')
1436 C-----------------------------------------------------------------------
1437 subroutine elj(evdw)
1439 C This subroutine calculates the interaction energy of nonbonded side chains
1440 C assuming the LJ potential of interaction.
1443 double precision accur
1444 include 'DIMENSIONS'
1445 parameter (accur=1.0d-10)
1446 include 'COMMON.GEO'
1447 include 'COMMON.VAR'
1448 include 'COMMON.LOCAL'
1449 include 'COMMON.CHAIN'
1450 include 'COMMON.DERIV'
1451 include 'COMMON.INTERACT'
1452 include 'COMMON.TORSION'
1453 include 'COMMON.SBRIDGE'
1454 include 'COMMON.NAMES'
1455 include 'COMMON.IOUNITS'
1456 include 'COMMON.SPLITELE'
1458 include 'COMMON.CONTACTS'
1459 include 'COMMON.CONTMAT'
1461 double precision gg(3)
1462 double precision evdw,evdwij
1463 integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1464 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1465 & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1466 double precision fcont,fprimcont
1467 double precision sscale,sscagrad
1468 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1470 do i=iatsc_s,iatsc_e
1471 itypi=iabs(itype(i))
1472 if (itypi.eq.ntyp1) cycle
1473 itypi1=iabs(itype(i+1))
1480 C Calculate SC interaction energy.
1482 do iint=1,nint_gr(i)
1483 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1484 cd & 'iend=',iend(i,iint)
1485 do j=istart(i,iint),iend(i,iint)
1486 itypj=iabs(itype(j))
1487 if (itypj.eq.ntyp1) cycle
1491 C Change 12/1/95 to calculate four-body interactions
1492 rij=xj*xj+yj*yj+zj*zj
1495 sss1=sscale(sqrij,r_cut_int)
1496 if (sss1.eq.0.0d0) cycle
1497 sssgrad1=sscagrad(sqrij,r_cut_int)
1499 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1500 eps0ij=eps(itypi,itypj)
1502 C have you changed here?
1506 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1509 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1510 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1511 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1512 evdw=evdw+sss1*evdwij
1514 C Calculate the components of the gradient in DC and X
1516 fac=-rrij*(e1+evdwij)*sss1
1517 & +evdwij*sssgrad1/sqrij/expon
1522 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1523 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1524 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1525 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1529 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1534 C 12/1/95, revised on 5/20/97
1536 C Calculate the contact function. The ith column of the array JCONT will
1537 C contain the numbers of atoms that make contacts with the atom I (of numbers
1538 C greater than I). The arrays FACONT and GACONT will contain the values of
1539 C the contact function and its derivative.
1541 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1542 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1543 C Uncomment next line, if the correlation interactions are contact function only
1544 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1546 sigij=sigma(itypi,itypj)
1547 r0ij=rs0(itypi,itypj)
1549 C Check whether the SC's are not too far to make a contact.
1552 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1553 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1555 if (fcont.gt.0.0D0) then
1556 C If the SC-SC distance if close to sigma, apply spline.
1557 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1558 cAdam & fcont1,fprimcont1)
1559 cAdam fcont1=1.0d0-fcont1
1560 cAdam if (fcont1.gt.0.0d0) then
1561 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1562 cAdam fcont=fcont*fcont1
1564 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1565 cga eps0ij=1.0d0/dsqrt(eps0ij)
1567 cga gg(k)=gg(k)*eps0ij
1569 cga eps0ij=-evdwij*eps0ij
1570 C Uncomment for AL's type of SC correlation interactions.
1571 cadam eps0ij=-evdwij
1572 num_conti=num_conti+1
1573 jcont(num_conti,i)=j
1574 facont(num_conti,i)=fcont*eps0ij
1575 fprimcont=eps0ij*fprimcont/rij
1577 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1578 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1579 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1580 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1581 gacont(1,num_conti,i)=-fprimcont*xj
1582 gacont(2,num_conti,i)=-fprimcont*yj
1583 gacont(3,num_conti,i)=-fprimcont*zj
1584 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1585 cd write (iout,'(2i3,3f10.5)')
1586 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1594 num_cont(i)=num_conti
1599 gvdwc(j,i)=expon*gvdwc(j,i)
1600 gvdwx(j,i)=expon*gvdwx(j,i)
1603 C******************************************************************************
1607 C To save time, the factor of EXPON has been extracted from ALL components
1608 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1611 C******************************************************************************
1614 C-----------------------------------------------------------------------------
1615 subroutine eljk(evdw)
1617 C This subroutine calculates the interaction energy of nonbonded side chains
1618 C assuming the LJK potential of interaction.
1621 include 'DIMENSIONS'
1622 include 'COMMON.GEO'
1623 include 'COMMON.VAR'
1624 include 'COMMON.LOCAL'
1625 include 'COMMON.CHAIN'
1626 include 'COMMON.DERIV'
1627 include 'COMMON.INTERACT'
1628 include 'COMMON.IOUNITS'
1629 include 'COMMON.NAMES'
1630 include 'COMMON.SPLITELE'
1631 double precision gg(3)
1632 double precision evdw,evdwij
1633 integer i,j,k,itypi,itypj,itypi1,iint
1634 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1635 & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1637 double precision sscale,sscagrad
1638 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1640 do i=iatsc_s,iatsc_e
1641 itypi=iabs(itype(i))
1642 if (itypi.eq.ntyp1) cycle
1643 itypi1=iabs(itype(i+1))
1648 C Calculate SC interaction energy.
1650 do iint=1,nint_gr(i)
1651 do j=istart(i,iint),iend(i,iint)
1652 itypj=iabs(itype(j))
1653 if (itypj.eq.ntyp1) cycle
1657 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1658 fac_augm=rrij**expon
1659 e_augm=augm(itypi,itypj)*fac_augm
1660 r_inv_ij=dsqrt(rrij)
1662 sss1=sscale(rij,r_cut_int)
1663 if (sss1.eq.0.0d0) cycle
1664 sssgrad1=sscagrad(rij,r_cut_int)
1665 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1666 fac=r_shift_inv**expon
1667 C have you changed here?
1671 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1672 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1673 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1674 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1675 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1676 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1677 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1678 evdw=evdw+evdwij*sss1
1680 C Calculate the components of the gradient in DC and X
1682 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1683 & +evdwij*sssgrad1*r_inv_ij/expon
1688 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1689 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1690 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1691 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1695 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1703 gvdwc(j,i)=expon*gvdwc(j,i)
1704 gvdwx(j,i)=expon*gvdwx(j,i)
1709 C-----------------------------------------------------------------------------
1710 subroutine ebp(evdw)
1712 C This subroutine calculates the interaction energy of nonbonded side chains
1713 C assuming the Berne-Pechukas potential of interaction.
1716 include 'DIMENSIONS'
1717 include 'COMMON.GEO'
1718 include 'COMMON.VAR'
1719 include 'COMMON.LOCAL'
1720 include 'COMMON.CHAIN'
1721 include 'COMMON.DERIV'
1722 include 'COMMON.NAMES'
1723 include 'COMMON.INTERACT'
1724 include 'COMMON.IOUNITS'
1725 include 'COMMON.CALC'
1726 include 'COMMON.SPLITELE'
1728 common /srutu/ icall
1729 double precision evdw
1730 integer itypi,itypj,itypi1,iint,ind
1731 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1733 double precision sscale,sscagrad
1734 c double precision rrsave(maxdim)
1737 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1739 c if (icall.eq.0) then
1745 do i=iatsc_s,iatsc_e
1746 itypi=iabs(itype(i))
1747 if (itypi.eq.ntyp1) cycle
1748 itypi1=iabs(itype(i+1))
1752 dxi=dc_norm(1,nres+i)
1753 dyi=dc_norm(2,nres+i)
1754 dzi=dc_norm(3,nres+i)
1755 c dsci_inv=dsc_inv(itypi)
1756 dsci_inv=vbld_inv(i+nres)
1758 C Calculate SC interaction energy.
1760 do iint=1,nint_gr(i)
1761 do j=istart(i,iint),iend(i,iint)
1763 itypj=iabs(itype(j))
1764 if (itypj.eq.ntyp1) cycle
1765 c dscj_inv=dsc_inv(itypj)
1766 dscj_inv=vbld_inv(j+nres)
1767 chi1=chi(itypi,itypj)
1768 chi2=chi(itypj,itypi)
1775 alf12=0.5D0*(alf1+alf2)
1776 C For diagnostics only!!!
1789 dxj=dc_norm(1,nres+j)
1790 dyj=dc_norm(2,nres+j)
1791 dzj=dc_norm(3,nres+j)
1792 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1793 cd if (icall.eq.0) then
1799 sss1=sscale(1.0d0/rij,r_cut_int)
1800 if (sss1.eq.0.0d0) cycle
1801 sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1802 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1804 C Calculate whole angle-dependent part of epsilon and contributions
1805 C to its derivatives
1806 C have you changed here?
1807 fac=(rrij*sigsq)**expon2
1810 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1811 eps2der=evdwij*eps3rt
1812 eps3der=evdwij*eps2rt
1813 evdwij=evdwij*eps2rt*eps3rt
1814 evdw=evdw+sss1*evdwij
1816 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1818 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1819 cd & restyp(itypi),i,restyp(itypj),j,
1820 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1821 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1822 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1825 C Calculate gradient components.
1826 e1=e1*eps1*eps2rt**2*eps3rt**2
1827 fac=-expon*(e1+evdwij)
1830 & +evdwij*sssgrad1/sss1*rij
1831 C Calculate radial part of the gradient
1835 C Calculate the angular part of the gradient and sum add the contributions
1836 C to the appropriate components of the Cartesian gradient.
1844 C-----------------------------------------------------------------------------
1845 subroutine egb(evdw)
1847 C This subroutine calculates the interaction energy of nonbonded side chains
1848 C assuming the Gay-Berne potential of interaction.
1851 include 'DIMENSIONS'
1852 include 'COMMON.GEO'
1853 include 'COMMON.VAR'
1854 include 'COMMON.LOCAL'
1855 include 'COMMON.CHAIN'
1856 include 'COMMON.DERIV'
1857 include 'COMMON.NAMES'
1858 include 'COMMON.INTERACT'
1859 include 'COMMON.IOUNITS'
1860 include 'COMMON.CALC'
1861 include 'COMMON.CONTROL'
1862 include 'COMMON.SPLITELE'
1863 include 'COMMON.SBRIDGE'
1865 integer xshift,yshift,zshift,subchap
1866 double precision evdw
1867 integer itypi,itypj,itypi1,iint,ind
1868 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1869 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1870 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1871 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1872 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1874 ccccc energy_dec=.false.
1875 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1878 c if (icall.eq.0) lprn=.false.
1880 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1881 C we have the original box)
1885 do i=iatsc_s,iatsc_e
1886 itypi=iabs(itype(i))
1887 if (itypi.eq.ntyp1) cycle
1888 itypi1=iabs(itype(i+1))
1892 C Return atom into box, boxxsize is size of box in x dimension
1894 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1895 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1896 C Condition for being inside the proper box
1897 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1898 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1902 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1903 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1904 C Condition for being inside the proper box
1905 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1906 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1910 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1911 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1912 C Condition for being inside the proper box
1913 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1914 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1918 if (xi.lt.0) xi=xi+boxxsize
1920 if (yi.lt.0) yi=yi+boxysize
1922 if (zi.lt.0) zi=zi+boxzsize
1923 C define scaling factor for lipids
1925 C if (positi.le.0) positi=positi+boxzsize
1927 C first for peptide groups
1928 c for each residue check if it is in lipid or lipid water border area
1929 if ((zi.gt.bordlipbot)
1930 &.and.(zi.lt.bordliptop)) then
1931 C the energy transfer exist
1932 if (zi.lt.buflipbot) then
1933 C what fraction I am in
1935 & ((zi-bordlipbot)/lipbufthick)
1936 C lipbufthick is thickenes of lipid buffore
1937 sslipi=sscalelip(fracinbuf)
1938 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1939 elseif (zi.gt.bufliptop) then
1940 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1941 sslipi=sscalelip(fracinbuf)
1942 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1952 C xi=xi+xshift*boxxsize
1953 C yi=yi+yshift*boxysize
1954 C zi=zi+zshift*boxzsize
1956 dxi=dc_norm(1,nres+i)
1957 dyi=dc_norm(2,nres+i)
1958 dzi=dc_norm(3,nres+i)
1959 c dsci_inv=dsc_inv(itypi)
1960 dsci_inv=vbld_inv(i+nres)
1961 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1962 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1964 C Calculate SC interaction energy.
1966 do iint=1,nint_gr(i)
1967 do j=istart(i,iint),iend(i,iint)
1968 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1970 c write(iout,*) "PRZED ZWYKLE", evdwij
1971 call dyn_ssbond_ene(i,j,evdwij)
1972 c write(iout,*) "PO ZWYKLE", evdwij
1975 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1976 & 'evdw',i,j,evdwij,' ss'
1977 C triple bond artifac removal
1978 do k=j+1,iend(i,iint)
1979 C search over all next residues
1980 if (dyn_ss_mask(k)) then
1981 C check if they are cysteins
1982 C write(iout,*) 'k=',k
1984 c write(iout,*) "PRZED TRI", evdwij
1985 evdwij_przed_tri=evdwij
1986 call triple_ssbond_ene(i,j,k,evdwij)
1987 c if(evdwij_przed_tri.ne.evdwij) then
1988 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1991 c write(iout,*) "PO TRI", evdwij
1992 C call the energy function that removes the artifical triple disulfide
1993 C bond the soubroutine is located in ssMD.F
1995 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1996 & 'evdw',i,j,evdwij,'tss'
1997 endif!dyn_ss_mask(k)
2001 itypj=iabs(itype(j))
2002 if (itypj.eq.ntyp1) cycle
2003 c dscj_inv=dsc_inv(itypj)
2004 dscj_inv=vbld_inv(j+nres)
2005 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2006 c & 1.0d0/vbld(j+nres)
2007 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2008 sig0ij=sigma(itypi,itypj)
2009 chi1=chi(itypi,itypj)
2010 chi2=chi(itypj,itypi)
2017 alf12=0.5D0*(alf1+alf2)
2018 C For diagnostics only!!!
2031 C Return atom J into box the original box
2033 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2034 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2035 C Condition for being inside the proper box
2036 c if ((xj.gt.((0.5d0)*boxxsize)).or.
2037 c & (xj.lt.((-0.5d0)*boxxsize))) then
2041 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2042 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2043 C Condition for being inside the proper box
2044 c if ((yj.gt.((0.5d0)*boxysize)).or.
2045 c & (yj.lt.((-0.5d0)*boxysize))) then
2049 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2050 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2051 C Condition for being inside the proper box
2052 c if ((zj.gt.((0.5d0)*boxzsize)).or.
2053 c & (zj.lt.((-0.5d0)*boxzsize))) then
2057 if (xj.lt.0) xj=xj+boxxsize
2059 if (yj.lt.0) yj=yj+boxysize
2061 if (zj.lt.0) zj=zj+boxzsize
2062 if ((zj.gt.bordlipbot)
2063 &.and.(zj.lt.bordliptop)) then
2064 C the energy transfer exist
2065 if (zj.lt.buflipbot) then
2066 C what fraction I am in
2068 & ((zj-bordlipbot)/lipbufthick)
2069 C lipbufthick is thickenes of lipid buffore
2070 sslipj=sscalelip(fracinbuf)
2071 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2072 elseif (zj.gt.bufliptop) then
2073 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2074 sslipj=sscalelip(fracinbuf)
2075 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2084 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2085 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2086 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2087 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2088 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2089 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2090 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2091 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2092 C print *,sslipi,sslipj,bordlipbot,zi,zj
2093 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2101 xj=xj_safe+xshift*boxxsize
2102 yj=yj_safe+yshift*boxysize
2103 zj=zj_safe+zshift*boxzsize
2104 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2105 if(dist_temp.lt.dist_init) then
2115 if (subchap.eq.1) then
2124 dxj=dc_norm(1,nres+j)
2125 dyj=dc_norm(2,nres+j)
2126 dzj=dc_norm(3,nres+j)
2130 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2131 c write (iout,*) "j",j," dc_norm",
2132 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2133 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2135 sss=sscale(1.0d0/rij,r_cut_int)
2136 c write (iout,'(a7,4f8.3)')
2137 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2138 if (sss.eq.0.0d0) cycle
2139 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2140 C Calculate angle-dependent terms of energy and contributions to their
2144 sig=sig0ij*dsqrt(sigsq)
2145 rij_shift=1.0D0/rij-sig+sig0ij
2146 c for diagnostics; uncomment
2147 c rij_shift=1.2*sig0ij
2148 C I hate to put IF's in the loops, but here don't have another choice!!!!
2149 if (rij_shift.le.0.0D0) then
2151 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2152 cd & restyp(itypi),i,restyp(itypj),j,
2153 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2157 c---------------------------------------------------------------
2158 rij_shift=1.0D0/rij_shift
2159 fac=rij_shift**expon
2160 C here to start with
2165 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2166 eps2der=evdwij*eps3rt
2167 eps3der=evdwij*eps2rt
2168 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2169 C &((sslipi+sslipj)/2.0d0+
2170 C &(2.0d0-sslipi-sslipj)/2.0d0)
2171 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2172 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2173 evdwij=evdwij*eps2rt*eps3rt
2174 evdw=evdw+evdwij*sss
2176 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2178 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2179 & restyp(itypi),i,restyp(itypj),j,
2180 & epsi,sigm,chi1,chi2,chip1,chip2,
2181 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2182 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2186 if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2187 & 'r sss evdw',i,j,rij,sss,evdwij
2189 C Calculate gradient components.
2190 e1=e1*eps1*eps2rt**2*eps3rt**2
2191 fac=-expon*(e1+evdwij)*rij_shift
2194 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2195 c & evdwij,fac,sigma(itypi,itypj),expon
2196 fac=fac+evdwij*sssgrad/sss*rij
2198 C Calculate the radial part of the gradient
2199 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2200 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2201 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2202 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2203 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2204 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2210 C Calculate angular part of the gradient.
2211 c call sc_grad_scale(sss)
2220 c write (iout,*) "Number of loop steps in EGB:",ind
2221 cccc energy_dec=.false.
2224 C-----------------------------------------------------------------------------
2225 subroutine egbv(evdw)
2227 C This subroutine calculates the interaction energy of nonbonded side chains
2228 C assuming the Gay-Berne-Vorobjev potential of interaction.
2231 include 'DIMENSIONS'
2232 include 'COMMON.GEO'
2233 include 'COMMON.VAR'
2234 include 'COMMON.LOCAL'
2235 include 'COMMON.CHAIN'
2236 include 'COMMON.DERIV'
2237 include 'COMMON.NAMES'
2238 include 'COMMON.INTERACT'
2239 include 'COMMON.IOUNITS'
2240 include 'COMMON.CALC'
2241 include 'COMMON.SPLITELE'
2242 integer xshift,yshift,zshift,subchap
2244 common /srutu/ icall
2246 double precision evdw
2247 integer itypi,itypj,itypi1,iint,ind
2248 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2249 & xi,yi,zi,fac_augm,e_augm
2250 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2251 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2252 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1
2253 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2255 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2258 c if (icall.eq.0) lprn=.true.
2260 do i=iatsc_s,iatsc_e
2261 itypi=iabs(itype(i))
2262 if (itypi.eq.ntyp1) cycle
2263 itypi1=iabs(itype(i+1))
2268 if (xi.lt.0) xi=xi+boxxsize
2270 if (yi.lt.0) yi=yi+boxysize
2272 if (zi.lt.0) zi=zi+boxzsize
2273 C define scaling factor for lipids
2275 C if (positi.le.0) positi=positi+boxzsize
2277 C first for peptide groups
2278 c for each residue check if it is in lipid or lipid water border area
2279 if ((zi.gt.bordlipbot)
2280 &.and.(zi.lt.bordliptop)) then
2281 C the energy transfer exist
2282 if (zi.lt.buflipbot) then
2283 C what fraction I am in
2285 & ((zi-bordlipbot)/lipbufthick)
2286 C lipbufthick is thickenes of lipid buffore
2287 sslipi=sscalelip(fracinbuf)
2288 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2289 elseif (zi.gt.bufliptop) then
2290 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2291 sslipi=sscalelip(fracinbuf)
2292 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2302 dxi=dc_norm(1,nres+i)
2303 dyi=dc_norm(2,nres+i)
2304 dzi=dc_norm(3,nres+i)
2305 c dsci_inv=dsc_inv(itypi)
2306 dsci_inv=vbld_inv(i+nres)
2308 C Calculate SC interaction energy.
2310 do iint=1,nint_gr(i)
2311 do j=istart(i,iint),iend(i,iint)
2313 itypj=iabs(itype(j))
2314 if (itypj.eq.ntyp1) cycle
2315 c dscj_inv=dsc_inv(itypj)
2316 dscj_inv=vbld_inv(j+nres)
2317 sig0ij=sigma(itypi,itypj)
2318 r0ij=r0(itypi,itypj)
2319 chi1=chi(itypi,itypj)
2320 chi2=chi(itypj,itypi)
2327 alf12=0.5D0*(alf1+alf2)
2328 C For diagnostics only!!!
2342 if (xj.lt.0) xj=xj+boxxsize
2344 if (yj.lt.0) yj=yj+boxysize
2346 if (zj.lt.0) zj=zj+boxzsize
2347 if ((zj.gt.bordlipbot)
2348 &.and.(zj.lt.bordliptop)) then
2349 C the energy transfer exist
2350 if (zj.lt.buflipbot) then
2351 C what fraction I am in
2353 & ((zj-bordlipbot)/lipbufthick)
2354 C lipbufthick is thickenes of lipid buffore
2355 sslipj=sscalelip(fracinbuf)
2356 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2357 elseif (zj.gt.bufliptop) then
2358 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2359 sslipj=sscalelip(fracinbuf)
2360 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2369 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2370 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2371 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2372 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2373 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2374 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2375 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2376 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2384 xj=xj_safe+xshift*boxxsize
2385 yj=yj_safe+yshift*boxysize
2386 zj=zj_safe+zshift*boxzsize
2387 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2388 if(dist_temp.lt.dist_init) then
2398 if (subchap.eq.1) then
2407 dxj=dc_norm(1,nres+j)
2408 dyj=dc_norm(2,nres+j)
2409 dzj=dc_norm(3,nres+j)
2410 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2412 sss=sscale(1.0d0/rij,r_cut_int)
2413 if (sss.eq.0.0d0) cycle
2414 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2415 C Calculate angle-dependent terms of energy and contributions to their
2419 sig=sig0ij*dsqrt(sigsq)
2420 rij_shift=1.0D0/rij-sig+r0ij
2421 C I hate to put IF's in the loops, but here don't have another choice!!!!
2422 if (rij_shift.le.0.0D0) then
2427 c---------------------------------------------------------------
2428 rij_shift=1.0D0/rij_shift
2429 fac=rij_shift**expon
2432 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2433 eps2der=evdwij*eps3rt
2434 eps3der=evdwij*eps2rt
2435 fac_augm=rrij**expon
2436 e_augm=augm(itypi,itypj)*fac_augm
2437 evdwij=evdwij*eps2rt*eps3rt
2438 evdw=evdw+evdwij+e_augm
2440 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2442 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2443 & restyp(itypi),i,restyp(itypj),j,
2444 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2445 & chi1,chi2,chip1,chip2,
2446 & eps1,eps2rt**2,eps3rt**2,
2447 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2450 C Calculate gradient components.
2451 e1=e1*eps1*eps2rt**2*eps3rt**2
2452 fac=-expon*(e1+evdwij)*rij_shift
2454 fac=rij*fac-2*expon*rrij*e_augm
2455 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2456 C Calculate the radial part of the gradient
2460 C Calculate angular part of the gradient.
2461 c call sc_grad_scale(sss)
2467 C-----------------------------------------------------------------------------
2468 subroutine sc_angular
2469 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2470 C om12. Called by ebp, egb, and egbv.
2472 include 'COMMON.CALC'
2473 include 'COMMON.IOUNITS'
2477 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2478 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2479 om12=dxi*dxj+dyi*dyj+dzi*dzj
2481 C Calculate eps1(om12) and its derivative in om12
2482 faceps1=1.0D0-om12*chiom12
2483 faceps1_inv=1.0D0/faceps1
2484 eps1=dsqrt(faceps1_inv)
2485 C Following variable is eps1*deps1/dom12
2486 eps1_om12=faceps1_inv*chiom12
2491 c write (iout,*) "om12",om12," eps1",eps1
2492 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2497 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2498 sigsq=1.0D0-facsig*faceps1_inv
2499 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2500 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2501 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2507 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2508 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2510 C Calculate eps2 and its derivatives in om1, om2, and om12.
2513 chipom12=chip12*om12
2514 facp=1.0D0-om12*chipom12
2516 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2517 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2518 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2519 C Following variable is the square root of eps2
2520 eps2rt=1.0D0-facp1*facp_inv
2521 C Following three variables are the derivatives of the square root of eps
2522 C in om1, om2, and om12.
2523 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2524 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2525 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2526 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2527 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2528 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2529 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2530 c & " eps2rt_om12",eps2rt_om12
2531 C Calculate whole angle-dependent part of epsilon and contributions
2532 C to its derivatives
2535 C----------------------------------------------------------------------------
2537 implicit real*8 (a-h,o-z)
2538 include 'DIMENSIONS'
2539 include 'COMMON.CHAIN'
2540 include 'COMMON.DERIV'
2541 include 'COMMON.CALC'
2542 include 'COMMON.IOUNITS'
2543 double precision dcosom1(3),dcosom2(3)
2544 cc print *,'sss=',sss
2545 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2546 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2547 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2548 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2552 c eom12=evdwij*eps1_om12
2554 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2555 c & " sigder",sigder
2556 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2557 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2559 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2560 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2563 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2565 c write (iout,*) "gg",(gg(k),k=1,3)
2567 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2568 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2569 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2570 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2571 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2572 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2573 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2574 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2575 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2576 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2579 C Calculate the components of the gradient in DC and X
2583 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2587 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2588 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2592 C-----------------------------------------------------------------------
2593 subroutine e_softsphere(evdw)
2595 C This subroutine calculates the interaction energy of nonbonded side chains
2596 C assuming the LJ potential of interaction.
2598 implicit real*8 (a-h,o-z)
2599 include 'DIMENSIONS'
2600 parameter (accur=1.0d-10)
2601 include 'COMMON.GEO'
2602 include 'COMMON.VAR'
2603 include 'COMMON.LOCAL'
2604 include 'COMMON.CHAIN'
2605 include 'COMMON.DERIV'
2606 include 'COMMON.INTERACT'
2607 include 'COMMON.TORSION'
2608 include 'COMMON.SBRIDGE'
2609 include 'COMMON.NAMES'
2610 include 'COMMON.IOUNITS'
2611 c include 'COMMON.CONTACTS'
2613 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2615 do i=iatsc_s,iatsc_e
2616 itypi=iabs(itype(i))
2617 if (itypi.eq.ntyp1) cycle
2618 itypi1=iabs(itype(i+1))
2623 C Calculate SC interaction energy.
2625 do iint=1,nint_gr(i)
2626 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2627 cd & 'iend=',iend(i,iint)
2628 do j=istart(i,iint),iend(i,iint)
2629 itypj=iabs(itype(j))
2630 if (itypj.eq.ntyp1) cycle
2634 rij=xj*xj+yj*yj+zj*zj
2635 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2636 r0ij=r0(itypi,itypj)
2638 c print *,i,j,r0ij,dsqrt(rij)
2639 if (rij.lt.r0ijsq) then
2640 evdwij=0.25d0*(rij-r0ijsq)**2
2648 C Calculate the components of the gradient in DC and X
2654 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2655 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2656 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2657 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2661 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2669 C--------------------------------------------------------------------------
2670 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2673 C Soft-sphere potential of p-p interaction
2675 implicit real*8 (a-h,o-z)
2676 include 'DIMENSIONS'
2677 include 'COMMON.CONTROL'
2678 include 'COMMON.IOUNITS'
2679 include 'COMMON.GEO'
2680 include 'COMMON.VAR'
2681 include 'COMMON.LOCAL'
2682 include 'COMMON.CHAIN'
2683 include 'COMMON.DERIV'
2684 include 'COMMON.INTERACT'
2685 c include 'COMMON.CONTACTS'
2686 include 'COMMON.TORSION'
2687 include 'COMMON.VECTORS'
2688 include 'COMMON.FFIELD'
2690 integer xshift,yshift,zshift
2691 C write(iout,*) 'In EELEC_soft_sphere'
2698 do i=iatel_s,iatel_e
2699 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2703 xmedi=c(1,i)+0.5d0*dxi
2704 ymedi=c(2,i)+0.5d0*dyi
2705 zmedi=c(3,i)+0.5d0*dzi
2706 xmedi=mod(xmedi,boxxsize)
2707 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2708 ymedi=mod(ymedi,boxysize)
2709 if (ymedi.lt.0) ymedi=ymedi+boxysize
2710 zmedi=mod(zmedi,boxzsize)
2711 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2713 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2714 do j=ielstart(i),ielend(i)
2715 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2719 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2720 r0ij=rpp(iteli,itelj)
2729 if (xj.lt.0) xj=xj+boxxsize
2731 if (yj.lt.0) yj=yj+boxysize
2733 if (zj.lt.0) zj=zj+boxzsize
2734 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2742 xj=xj_safe+xshift*boxxsize
2743 yj=yj_safe+yshift*boxysize
2744 zj=zj_safe+zshift*boxzsize
2745 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2746 if(dist_temp.lt.dist_init) then
2756 if (isubchap.eq.1) then
2765 rij=xj*xj+yj*yj+zj*zj
2766 sss=sscale(sqrt(rij),r_cut_int)
2767 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2768 if (rij.lt.r0ijsq) then
2769 evdw1ij=0.25d0*(rij-r0ijsq)**2
2775 evdw1=evdw1+evdw1ij*sss
2777 C Calculate contributions to the Cartesian gradient.
2779 ggg(1)=fac*xj*sssgrad
2780 ggg(2)=fac*yj*sssgrad
2781 ggg(3)=fac*zj*sssgrad
2783 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2784 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2787 * Loop over residues i+1 thru j-1.
2791 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2796 cgrad do i=nnt,nct-1
2798 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2800 cgrad do j=i+1,nct-1
2802 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2808 c------------------------------------------------------------------------------
2809 subroutine vec_and_deriv
2810 implicit real*8 (a-h,o-z)
2811 include 'DIMENSIONS'
2815 include 'COMMON.IOUNITS'
2816 include 'COMMON.GEO'
2817 include 'COMMON.VAR'
2818 include 'COMMON.LOCAL'
2819 include 'COMMON.CHAIN'
2820 include 'COMMON.VECTORS'
2821 include 'COMMON.SETUP'
2822 include 'COMMON.TIME1'
2823 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2824 C Compute the local reference systems. For reference system (i), the
2825 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2826 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2828 do i=ivec_start,ivec_end
2832 if (i.eq.nres-1) then
2833 C Case of the last full residue
2834 C Compute the Z-axis
2835 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2836 costh=dcos(pi-theta(nres))
2837 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2841 C Compute the derivatives of uz
2843 uzder(2,1,1)=-dc_norm(3,i-1)
2844 uzder(3,1,1)= dc_norm(2,i-1)
2845 uzder(1,2,1)= dc_norm(3,i-1)
2847 uzder(3,2,1)=-dc_norm(1,i-1)
2848 uzder(1,3,1)=-dc_norm(2,i-1)
2849 uzder(2,3,1)= dc_norm(1,i-1)
2852 uzder(2,1,2)= dc_norm(3,i)
2853 uzder(3,1,2)=-dc_norm(2,i)
2854 uzder(1,2,2)=-dc_norm(3,i)
2856 uzder(3,2,2)= dc_norm(1,i)
2857 uzder(1,3,2)= dc_norm(2,i)
2858 uzder(2,3,2)=-dc_norm(1,i)
2860 C Compute the Y-axis
2863 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2865 C Compute the derivatives of uy
2868 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2869 & -dc_norm(k,i)*dc_norm(j,i-1)
2870 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2872 uyder(j,j,1)=uyder(j,j,1)-costh
2873 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2878 uygrad(l,k,j,i)=uyder(l,k,j)
2879 uzgrad(l,k,j,i)=uzder(l,k,j)
2883 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2884 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2885 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2886 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2889 C Compute the Z-axis
2890 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2891 costh=dcos(pi-theta(i+2))
2892 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2896 C Compute the derivatives of uz
2898 uzder(2,1,1)=-dc_norm(3,i+1)
2899 uzder(3,1,1)= dc_norm(2,i+1)
2900 uzder(1,2,1)= dc_norm(3,i+1)
2902 uzder(3,2,1)=-dc_norm(1,i+1)
2903 uzder(1,3,1)=-dc_norm(2,i+1)
2904 uzder(2,3,1)= dc_norm(1,i+1)
2907 uzder(2,1,2)= dc_norm(3,i)
2908 uzder(3,1,2)=-dc_norm(2,i)
2909 uzder(1,2,2)=-dc_norm(3,i)
2911 uzder(3,2,2)= dc_norm(1,i)
2912 uzder(1,3,2)= dc_norm(2,i)
2913 uzder(2,3,2)=-dc_norm(1,i)
2915 C Compute the Y-axis
2918 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2920 C Compute the derivatives of uy
2923 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2924 & -dc_norm(k,i)*dc_norm(j,i+1)
2925 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2927 uyder(j,j,1)=uyder(j,j,1)-costh
2928 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2933 uygrad(l,k,j,i)=uyder(l,k,j)
2934 uzgrad(l,k,j,i)=uzder(l,k,j)
2938 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2939 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2940 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2941 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2945 vbld_inv_temp(1)=vbld_inv(i+1)
2946 if (i.lt.nres-1) then
2947 vbld_inv_temp(2)=vbld_inv(i+2)
2949 vbld_inv_temp(2)=vbld_inv(i)
2954 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2955 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2960 #if defined(PARVEC) && defined(MPI)
2961 if (nfgtasks1.gt.1) then
2963 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2964 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2965 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2966 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2967 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2969 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2970 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2972 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2973 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2974 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2975 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2976 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2977 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2978 time_gather=time_gather+MPI_Wtime()-time00
2982 if (fg_rank.eq.0) then
2983 write (iout,*) "Arrays UY and UZ"
2985 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2992 C--------------------------------------------------------------------------
2993 subroutine set_matrices
2994 implicit real*8 (a-h,o-z)
2995 include 'DIMENSIONS'
2998 include "COMMON.SETUP"
3000 integer status(MPI_STATUS_SIZE)
3002 include 'COMMON.IOUNITS'
3003 include 'COMMON.GEO'
3004 include 'COMMON.VAR'
3005 include 'COMMON.LOCAL'
3006 include 'COMMON.CHAIN'
3007 include 'COMMON.DERIV'
3008 include 'COMMON.INTERACT'
3009 include 'COMMON.CORRMAT'
3010 include 'COMMON.TORSION'
3011 include 'COMMON.VECTORS'
3012 include 'COMMON.FFIELD'
3013 double precision auxvec(2),auxmat(2,2)
3015 C Compute the virtual-bond-torsional-angle dependent quantities needed
3016 C to calculate the el-loc multibody terms of various order.
3018 c write(iout,*) 'nphi=',nphi,nres
3019 c write(iout,*) "itype2loc",itype2loc
3021 do i=ivec_start+2,ivec_end+2
3026 c write (iout,*) "i",i,i-2," ii",ii
3028 innt=chain_border(1,ii)
3029 inct=chain_border(2,ii)
3030 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3031 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3032 if (i.gt. innt+2 .and. i.lt.inct+2) then
3033 iti = itype2loc(itype(i-2))
3037 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3038 if (i.gt. innt+1 .and. i.lt.inct+1) then
3039 iti1 = itype2loc(itype(i-1))
3043 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3044 c & " iti1",itype(i-1),iti1
3046 cost1=dcos(theta(i-1))
3047 sint1=dsin(theta(i-1))
3049 sint1cub=sint1sq*sint1
3050 sint1cost1=2*sint1*cost1
3051 c write (iout,*) "bnew1",i,iti
3052 c write (iout,*) (bnew1(k,1,iti),k=1,3)
3053 c write (iout,*) (bnew1(k,2,iti),k=1,3)
3054 c write (iout,*) "bnew2",i,iti
3055 c write (iout,*) (bnew2(k,1,iti),k=1,3)
3056 c write (iout,*) (bnew2(k,2,iti),k=1,3)
3058 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3060 gtb1(k,i-2)=cost1*b1k-sint1sq*
3061 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3062 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3064 gtb2(k,i-2)=cost1*b2k-sint1sq*
3065 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3068 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3069 cc(1,k,i-2)=sint1sq*aux
3070 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3071 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3072 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3073 dd(1,k,i-2)=sint1sq*aux
3074 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3075 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3077 cc(2,1,i-2)=cc(1,2,i-2)
3078 cc(2,2,i-2)=-cc(1,1,i-2)
3079 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3080 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3081 dd(2,1,i-2)=dd(1,2,i-2)
3082 dd(2,2,i-2)=-dd(1,1,i-2)
3083 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3084 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3087 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3088 EE(l,k,i-2)=sint1sq*aux
3089 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3092 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3093 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3094 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3095 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3096 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3097 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3098 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3099 c b1tilde(1,i-2)=b1(1,i-2)
3100 c b1tilde(2,i-2)=-b1(2,i-2)
3101 c b2tilde(1,i-2)=b2(1,i-2)
3102 c b2tilde(2,i-2)=-b2(2,i-2)
3104 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3105 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3106 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3107 write (iout,*) 'theta=', theta(i-1)
3110 if (i.gt. innt+2 .and. i.lt.inct+2) then
3111 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3112 iti = itype2loc(itype(i-2))
3116 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3117 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3118 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3119 iti1 = itype2loc(itype(i-1))
3129 CC(k,l,i-2)=ccold(k,l,iti)
3130 DD(k,l,i-2)=ddold(k,l,iti)
3131 EE(k,l,i-2)=eeold(k,l,iti)
3136 b1tilde(1,i-2)= b1(1,i-2)
3137 b1tilde(2,i-2)=-b1(2,i-2)
3138 b2tilde(1,i-2)= b2(1,i-2)
3139 b2tilde(2,i-2)=-b2(2,i-2)
3141 Ctilde(1,1,i-2)= CC(1,1,i-2)
3142 Ctilde(1,2,i-2)= CC(1,2,i-2)
3143 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3144 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3146 Dtilde(1,1,i-2)= DD(1,1,i-2)
3147 Dtilde(1,2,i-2)= DD(1,2,i-2)
3148 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3149 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3151 write(iout,*) "i",i," iti",iti
3152 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3153 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3158 do i=ivec_start+2,ivec_end+2
3162 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3163 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3201 obrot_der(1,i-2)=-sin1
3202 obrot_der(2,i-2)= cos1
3203 Ugder(1,1,i-2)= sin1
3204 Ugder(1,2,i-2)=-cos1
3205 Ugder(2,1,i-2)=-cos1
3206 Ugder(2,2,i-2)=-sin1
3209 obrot2_der(1,i-2)=-dwasin2
3210 obrot2_der(2,i-2)= dwacos2
3211 Ug2der(1,1,i-2)= dwasin2
3212 Ug2der(1,2,i-2)=-dwacos2
3213 Ug2der(2,1,i-2)=-dwacos2
3214 Ug2der(2,2,i-2)=-dwasin2
3216 obrot_der(1,i-2)=0.0d0
3217 obrot_der(2,i-2)=0.0d0
3218 Ugder(1,1,i-2)=0.0d0
3219 Ugder(1,2,i-2)=0.0d0
3220 Ugder(2,1,i-2)=0.0d0
3221 Ugder(2,2,i-2)=0.0d0
3222 obrot2_der(1,i-2)=0.0d0
3223 obrot2_der(2,i-2)=0.0d0
3224 Ug2der(1,1,i-2)=0.0d0
3225 Ug2der(1,2,i-2)=0.0d0
3226 Ug2der(2,1,i-2)=0.0d0
3227 Ug2der(2,2,i-2)=0.0d0
3229 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3230 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3231 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3232 iti = itype2loc(itype(i-2))
3236 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3237 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3238 iti1 = itype2loc(itype(i-1))
3242 cd write (iout,*) '*******i',i,' iti1',iti
3243 cd write (iout,*) 'b1',b1(:,iti)
3244 cd write (iout,*) 'b2',b2(:,iti)
3245 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3246 c if (i .gt. iatel_s+2) then
3247 if (i .gt. nnt+2) then
3248 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3250 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3251 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3253 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3254 c & EE(1,2,iti),EE(2,2,i)
3255 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3256 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3257 c write(iout,*) "Macierz EUG",
3258 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3261 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3263 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3264 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3265 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3266 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3267 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3279 DtUg2(l,k,i-2)=0.0d0
3283 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3284 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3286 muder(k,i-2)=Ub2der(k,i-2)
3288 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3289 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3290 if (itype(i-1).le.ntyp) then
3291 iti1 = itype2loc(itype(i-1))
3299 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3300 c mu(k,i-2)=b1(k,i-1)
3301 c mu(k,i-2)=Ub2(k,i-2)
3304 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3305 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3306 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3307 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3308 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3309 & ((ee(l,k,i-2),l=1,2),k=1,2)
3311 cd write (iout,*) 'mu1',mu1(:,i-2)
3312 cd write (iout,*) 'mu2',mu2(:,i-2)
3313 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3315 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3317 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3318 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3319 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3320 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3321 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3322 C Vectors and matrices dependent on a single virtual-bond dihedral.
3323 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3324 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3325 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3326 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3327 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3328 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3329 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3330 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3331 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3336 C Matrices dependent on two consecutive virtual-bond dihedrals.
3337 C The order of matrices is from left to right.
3338 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3340 c do i=max0(ivec_start,2),ivec_end
3342 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3343 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3344 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3345 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3346 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3347 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3348 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3349 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3353 #if defined(MPI) && defined(PARMAT)
3355 c if (fg_rank.eq.0) then
3356 write (iout,*) "Arrays UG and UGDER before GATHER"
3358 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3359 & ((ug(l,k,i),l=1,2),k=1,2),
3360 & ((ugder(l,k,i),l=1,2),k=1,2)
3362 write (iout,*) "Arrays UG2 and UG2DER"
3364 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3365 & ((ug2(l,k,i),l=1,2),k=1,2),
3366 & ((ug2der(l,k,i),l=1,2),k=1,2)
3368 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3370 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3371 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3372 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3374 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3376 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3377 & costab(i),sintab(i),costab2(i),sintab2(i)
3379 write (iout,*) "Array MUDER"
3381 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3385 if (nfgtasks.gt.1) then
3387 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3388 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3389 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3391 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3392 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3394 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3395 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3397 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3398 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3400 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3401 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3403 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3404 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3406 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3407 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3409 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3410 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3411 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3412 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3413 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3414 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3415 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3416 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3417 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3418 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3419 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3420 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3422 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3424 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3425 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3427 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3428 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3430 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3431 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3433 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3434 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3436 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3437 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3439 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3440 & ivec_count(fg_rank1),
3441 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3443 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3444 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3446 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3447 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3449 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3450 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3452 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3453 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3455 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3456 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3458 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3459 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3461 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3462 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3464 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3465 & ivec_count(fg_rank1),
3466 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3468 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3469 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3471 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3472 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3474 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3475 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3477 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3478 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3480 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3481 & ivec_count(fg_rank1),
3482 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3484 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3485 & ivec_count(fg_rank1),
3486 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3488 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3489 & ivec_count(fg_rank1),
3490 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3491 & MPI_MAT2,FG_COMM1,IERR)
3492 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3493 & ivec_count(fg_rank1),
3494 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3495 & MPI_MAT2,FG_COMM1,IERR)
3499 c Passes matrix info through the ring
3502 if (irecv.lt.0) irecv=nfgtasks1-1
3505 if (inext.ge.nfgtasks1) inext=0
3507 c write (iout,*) "isend",isend," irecv",irecv
3509 lensend=lentyp(isend)
3510 lenrecv=lentyp(irecv)
3511 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3512 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3513 c & MPI_ROTAT1(lensend),inext,2200+isend,
3514 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3515 c & iprev,2200+irecv,FG_COMM,status,IERR)
3516 c write (iout,*) "Gather ROTAT1"
3518 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3519 c & MPI_ROTAT2(lensend),inext,3300+isend,
3520 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3521 c & iprev,3300+irecv,FG_COMM,status,IERR)
3522 c write (iout,*) "Gather ROTAT2"
3524 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3525 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3526 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3527 & iprev,4400+irecv,FG_COMM,status,IERR)
3528 c write (iout,*) "Gather ROTAT_OLD"
3530 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3531 & MPI_PRECOMP11(lensend),inext,5500+isend,
3532 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3533 & iprev,5500+irecv,FG_COMM,status,IERR)
3534 c write (iout,*) "Gather PRECOMP11"
3536 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3537 & MPI_PRECOMP12(lensend),inext,6600+isend,
3538 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3539 & iprev,6600+irecv,FG_COMM,status,IERR)
3540 c write (iout,*) "Gather PRECOMP12"
3543 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3545 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3546 & MPI_ROTAT2(lensend),inext,7700+isend,
3547 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3548 & iprev,7700+irecv,FG_COMM,status,IERR)
3549 c write (iout,*) "Gather PRECOMP21"
3551 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3552 & MPI_PRECOMP22(lensend),inext,8800+isend,
3553 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3554 & iprev,8800+irecv,FG_COMM,status,IERR)
3555 c write (iout,*) "Gather PRECOMP22"
3557 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3558 & MPI_PRECOMP23(lensend),inext,9900+isend,
3559 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3560 & MPI_PRECOMP23(lenrecv),
3561 & iprev,9900+irecv,FG_COMM,status,IERR)
3563 c write (iout,*) "Gather PRECOMP23"
3568 if (irecv.lt.0) irecv=nfgtasks1-1
3571 time_gather=time_gather+MPI_Wtime()-time00
3574 c if (fg_rank.eq.0) then
3575 write (iout,*) "Arrays UG and UGDER"
3577 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3578 & ((ug(l,k,i),l=1,2),k=1,2),
3579 & ((ugder(l,k,i),l=1,2),k=1,2)
3581 write (iout,*) "Arrays UG2 and UG2DER"
3583 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3584 & ((ug2(l,k,i),l=1,2),k=1,2),
3585 & ((ug2der(l,k,i),l=1,2),k=1,2)
3587 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3589 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3590 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3591 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3593 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3595 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3596 & costab(i),sintab(i),costab2(i),sintab2(i)
3598 write (iout,*) "Array MUDER"
3600 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3606 cd iti = itype2loc(itype(i))
3609 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3610 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3615 C-----------------------------------------------------------------------------
3616 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3618 C This subroutine calculates the average interaction energy and its gradient
3619 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3620 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3621 C The potential depends both on the distance of peptide-group centers and on
3622 C the orientation of the CA-CA virtual bonds.
3624 implicit real*8 (a-h,o-z)
3628 include 'DIMENSIONS'
3629 include 'COMMON.CONTROL'
3630 include 'COMMON.SETUP'
3631 include 'COMMON.IOUNITS'
3632 include 'COMMON.GEO'
3633 include 'COMMON.VAR'
3634 include 'COMMON.LOCAL'
3635 include 'COMMON.CHAIN'
3636 include 'COMMON.DERIV'
3637 include 'COMMON.INTERACT'
3639 include 'COMMON.CONTACTS'
3640 include 'COMMON.CONTMAT'
3642 include 'COMMON.CORRMAT'
3643 include 'COMMON.TORSION'
3644 include 'COMMON.VECTORS'
3645 include 'COMMON.FFIELD'
3646 include 'COMMON.TIME1'
3647 include 'COMMON.SPLITELE'
3648 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3649 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3650 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3651 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3652 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3653 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3655 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3657 double precision scal_el /1.0d0/
3659 double precision scal_el /0.5d0/
3662 C 13-go grudnia roku pamietnego...
3663 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3664 & 0.0d0,1.0d0,0.0d0,
3665 & 0.0d0,0.0d0,1.0d0/
3666 cd write(iout,*) 'In EELEC'
3668 cd write(iout,*) 'Type',i
3669 cd write(iout,*) 'B1',B1(:,i)
3670 cd write(iout,*) 'B2',B2(:,i)
3671 cd write(iout,*) 'CC',CC(:,:,i)
3672 cd write(iout,*) 'DD',DD(:,:,i)
3673 cd write(iout,*) 'EE',EE(:,:,i)
3675 cd call check_vecgrad
3677 if (icheckgrad.eq.1) then
3679 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3681 dc_norm(k,i)=dc(k,i)*fac
3683 c write (iout,*) 'i',i,' fac',fac
3686 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3687 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3688 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3689 c call vec_and_deriv
3695 time_mat=time_mat+MPI_Wtime()-time01
3699 cd write (iout,*) 'i=',i
3701 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3704 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3705 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3720 cd print '(a)','Enter EELEC'
3721 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3723 gel_loc_loc(i)=0.0d0
3728 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3730 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3732 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3733 do i=iturn3_start,iturn3_end
3735 C write(iout,*) "tu jest i",i
3736 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3737 C changes suggested by Ana to avoid out of bounds
3738 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3739 c & .or.((i+4).gt.nres)
3740 c & .or.((i-1).le.0)
3741 C end of changes by Ana
3742 & .or. itype(i+2).eq.ntyp1
3743 & .or. itype(i+3).eq.ntyp1) cycle
3744 C Adam: Instructions below will switch off existing interactions
3746 c if(itype(i-1).eq.ntyp1)cycle
3748 c if(i.LT.nres-3)then
3749 c if (itype(i+4).eq.ntyp1) cycle
3754 dx_normi=dc_norm(1,i)
3755 dy_normi=dc_norm(2,i)
3756 dz_normi=dc_norm(3,i)
3757 xmedi=c(1,i)+0.5d0*dxi
3758 ymedi=c(2,i)+0.5d0*dyi
3759 zmedi=c(3,i)+0.5d0*dzi
3760 xmedi=mod(xmedi,boxxsize)
3761 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3762 ymedi=mod(ymedi,boxysize)
3763 if (ymedi.lt.0) ymedi=ymedi+boxysize
3764 zmedi=mod(zmedi,boxzsize)
3765 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3767 call eelecij(i,i+2,ees,evdw1,eel_loc)
3768 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3770 num_cont_hb(i)=num_conti
3773 do i=iturn4_start,iturn4_end
3775 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3776 C changes suggested by Ana to avoid out of bounds
3777 c & .or.((i+5).gt.nres)
3778 c & .or.((i-1).le.0)
3779 C end of changes suggested by Ana
3780 & .or. itype(i+3).eq.ntyp1
3781 & .or. itype(i+4).eq.ntyp1
3782 c & .or. itype(i+5).eq.ntyp1
3783 c & .or. itype(i).eq.ntyp1
3784 c & .or. itype(i-1).eq.ntyp1
3789 dx_normi=dc_norm(1,i)
3790 dy_normi=dc_norm(2,i)
3791 dz_normi=dc_norm(3,i)
3792 xmedi=c(1,i)+0.5d0*dxi
3793 ymedi=c(2,i)+0.5d0*dyi
3794 zmedi=c(3,i)+0.5d0*dzi
3795 C Return atom into box, boxxsize is size of box in x dimension
3797 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3798 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3799 C Condition for being inside the proper box
3800 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3801 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3805 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3806 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3807 C Condition for being inside the proper box
3808 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3809 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3813 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3814 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3815 C Condition for being inside the proper box
3816 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3817 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3820 xmedi=mod(xmedi,boxxsize)
3821 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3822 ymedi=mod(ymedi,boxysize)
3823 if (ymedi.lt.0) ymedi=ymedi+boxysize
3824 zmedi=mod(zmedi,boxzsize)
3825 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3828 num_conti=num_cont_hb(i)
3830 c write(iout,*) "JESTEM W PETLI"
3831 call eelecij(i,i+3,ees,evdw1,eel_loc)
3832 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3833 & call eturn4(i,eello_turn4)
3835 num_cont_hb(i)=num_conti
3838 C Loop over all neighbouring boxes
3843 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3846 do i=iatel_s,iatel_e
3849 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3850 C changes suggested by Ana to avoid out of bounds
3851 c & .or.((i+2).gt.nres)
3852 c & .or.((i-1).le.0)
3853 C end of changes by Ana
3854 c & .or. itype(i+2).eq.ntyp1
3855 c & .or. itype(i-1).eq.ntyp1
3860 dx_normi=dc_norm(1,i)
3861 dy_normi=dc_norm(2,i)
3862 dz_normi=dc_norm(3,i)
3863 xmedi=c(1,i)+0.5d0*dxi
3864 ymedi=c(2,i)+0.5d0*dyi
3865 zmedi=c(3,i)+0.5d0*dzi
3866 xmedi=mod(xmedi,boxxsize)
3867 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3868 ymedi=mod(ymedi,boxysize)
3869 if (ymedi.lt.0) ymedi=ymedi+boxysize
3870 zmedi=mod(zmedi,boxzsize)
3871 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3872 C xmedi=xmedi+xshift*boxxsize
3873 C ymedi=ymedi+yshift*boxysize
3874 C zmedi=zmedi+zshift*boxzsize
3876 C Return tom into box, boxxsize is size of box in x dimension
3878 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3879 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3880 C Condition for being inside the proper box
3881 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3882 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3886 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3887 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3888 C Condition for being inside the proper box
3889 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3890 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3894 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3895 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3896 cC Condition for being inside the proper box
3897 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3898 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3902 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3904 num_conti=num_cont_hb(i)
3907 do j=ielstart(i),ielend(i)
3909 C write (iout,*) i,j
3911 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3912 C changes suggested by Ana to avoid out of bounds
3913 c & .or.((j+2).gt.nres)
3914 c & .or.((j-1).le.0)
3915 C end of changes by Ana
3916 c & .or.itype(j+2).eq.ntyp1
3917 c & .or.itype(j-1).eq.ntyp1
3919 call eelecij(i,j,ees,evdw1,eel_loc)
3922 num_cont_hb(i)=num_conti
3929 c write (iout,*) "Number of loop steps in EELEC:",ind
3931 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3932 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3934 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3935 ccc eel_loc=eel_loc+eello_turn3
3936 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3939 C-------------------------------------------------------------------------------
3940 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3942 include 'DIMENSIONS'
3946 include 'COMMON.CONTROL'
3947 include 'COMMON.IOUNITS'
3948 include 'COMMON.GEO'
3949 include 'COMMON.VAR'
3950 include 'COMMON.LOCAL'
3951 include 'COMMON.CHAIN'
3952 include 'COMMON.DERIV'
3953 include 'COMMON.INTERACT'
3955 include 'COMMON.CONTACTS'
3956 include 'COMMON.CONTMAT'
3958 include 'COMMON.CORRMAT'
3959 include 'COMMON.TORSION'
3960 include 'COMMON.VECTORS'
3961 include 'COMMON.FFIELD'
3962 include 'COMMON.TIME1'
3963 include 'COMMON.SPLITELE'
3964 include 'COMMON.SHIELD'
3965 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3966 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3967 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3968 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3969 & gmuij2(4),gmuji2(4)
3970 double precision dxi,dyi,dzi
3971 double precision dx_normi,dy_normi,dz_normi,aux
3972 integer j1,j2,lll,num_conti
3973 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3974 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3976 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3977 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3978 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3979 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3980 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3981 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3982 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3983 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3984 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3985 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3986 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3987 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3988 double precision dist_init,xj_safe,yj_safe,zj_safe,
3989 & xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi
3990 double precision sscale,sscagrad,scalar
3992 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3994 double precision scal_el /1.0d0/
3996 double precision scal_el /0.5d0/
3999 C 13-go grudnia roku pamietnego...
4000 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4001 & 0.0d0,1.0d0,0.0d0,
4002 & 0.0d0,0.0d0,1.0d0/
4003 integer xshift,yshift,zshift
4004 c time00=MPI_Wtime()
4005 cd write (iout,*) "eelecij",i,j
4009 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4010 aaa=app(iteli,itelj)
4011 bbb=bpp(iteli,itelj)
4012 ael6i=ael6(iteli,itelj)
4013 ael3i=ael3(iteli,itelj)
4017 dx_normj=dc_norm(1,j)
4018 dy_normj=dc_norm(2,j)
4019 dz_normj=dc_norm(3,j)
4020 C xj=c(1,j)+0.5D0*dxj-xmedi
4021 C yj=c(2,j)+0.5D0*dyj-ymedi
4022 C zj=c(3,j)+0.5D0*dzj-zmedi
4027 if (xj.lt.0) xj=xj+boxxsize
4029 if (yj.lt.0) yj=yj+boxysize
4031 if (zj.lt.0) zj=zj+boxzsize
4032 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4033 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4041 xj=xj_safe+xshift*boxxsize
4042 yj=yj_safe+yshift*boxysize
4043 zj=zj_safe+zshift*boxzsize
4044 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
4045 if(dist_temp.lt.dist_init) then
4055 if (isubchap.eq.1) then
4064 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4066 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4067 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4068 C Condition for being inside the proper box
4069 c if ((xj.gt.((0.5d0)*boxxsize)).or.
4070 c & (xj.lt.((-0.5d0)*boxxsize))) then
4074 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4075 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4076 C Condition for being inside the proper box
4077 c if ((yj.gt.((0.5d0)*boxysize)).or.
4078 c & (yj.lt.((-0.5d0)*boxysize))) then
4082 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4083 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4084 C Condition for being inside the proper box
4085 c if ((zj.gt.((0.5d0)*boxzsize)).or.
4086 c & (zj.lt.((-0.5d0)*boxzsize))) then
4089 C endif !endPBC condintion
4093 rij=xj*xj+yj*yj+zj*zj
4095 sss=sscale(dsqrt(rij),r_cut_int)
4096 if (sss.eq.0.0d0) return
4097 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
4098 c if (sss.gt.0.0d0) then
4104 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4105 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4106 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4107 fac=cosa-3.0D0*cosb*cosg
4109 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4110 if (j.eq.i+2) ev1=scal_el*ev1
4115 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4120 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4121 if (shield_mode.gt.0) then
4124 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4125 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4134 evdw1=evdw1+evdwij*sss
4135 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4136 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4137 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4138 cd & xmedi,ymedi,zmedi,xj,yj,zj
4140 if (energy_dec) then
4141 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4142 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4143 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4144 & fac_shield(i),fac_shield(j)
4148 C Calculate contributions to the Cartesian gradient.
4151 facvdw=-6*rrmij*(ev1+evdwij)*sss
4152 facel=-3*rrmij*(el1+eesij)
4159 * Radial derivatives. First process both termini of the fragment (i,j)
4161 aux=facel*sss+rmij*sssgrad*eesij
4165 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4166 & (shield_mode.gt.0)) then
4168 do ilist=1,ishield_list(i)
4169 iresshield=shield_list(ilist,i)
4171 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4173 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4175 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4176 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4177 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4178 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4179 C if (iresshield.gt.i) then
4180 C do ishi=i+1,iresshield-1
4181 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4182 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4186 C do ishi=iresshield,i
4187 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4188 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4194 do ilist=1,ishield_list(j)
4195 iresshield=shield_list(ilist,j)
4197 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4199 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4201 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4202 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4204 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4205 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4206 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4207 C if (iresshield.gt.j) then
4208 C do ishi=j+1,iresshield-1
4209 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4210 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4214 C do ishi=iresshield,j
4215 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4216 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4223 gshieldc(k,i)=gshieldc(k,i)+
4224 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4225 gshieldc(k,j)=gshieldc(k,j)+
4226 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4227 gshieldc(k,i-1)=gshieldc(k,i-1)+
4228 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4229 gshieldc(k,j-1)=gshieldc(k,j-1)+
4230 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4235 c ghalf=0.5D0*ggg(k)
4236 c gelc(k,i)=gelc(k,i)+ghalf
4237 c gelc(k,j)=gelc(k,j)+ghalf
4239 c 9/28/08 AL Gradient compotents will be summed only at the end
4240 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4242 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4243 C & +grad_shield(k,j)*eesij/fac_shield(j)
4244 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4245 C & +grad_shield(k,i)*eesij/fac_shield(i)
4246 C gelc_long(k,i-1)=gelc_long(k,i-1)
4247 C & +grad_shield(k,i)*eesij/fac_shield(i)
4248 C gelc_long(k,j-1)=gelc_long(k,j-1)
4249 C & +grad_shield(k,j)*eesij/fac_shield(j)
4251 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4254 * Loop over residues i+1 thru j-1.
4258 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4261 facvdw=facvdw+sssgrad*rmij*evdwij
4266 c ghalf=0.5D0*ggg(k)
4267 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4268 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4270 c 9/28/08 AL Gradient compotents will be summed only at the end
4272 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4273 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4276 * Loop over residues i+1 thru j-1.
4280 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4288 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4289 & +(evdwij+eesij)*sssgrad*rrmij
4294 * Radial derivatives. First process both termini of the fragment (i,j)
4297 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4299 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4301 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4303 c ghalf=0.5D0*ggg(k)
4304 c gelc(k,i)=gelc(k,i)+ghalf
4305 c gelc(k,j)=gelc(k,j)+ghalf
4307 c 9/28/08 AL Gradient compotents will be summed only at the end
4309 gelc_long(k,j)=gelc(k,j)+ggg(k)
4310 gelc_long(k,i)=gelc(k,i)-ggg(k)
4313 * Loop over residues i+1 thru j-1.
4317 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4320 c 9/28/08 AL Gradient compotents will be summed only at the end
4321 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4322 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4323 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4325 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4326 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4332 ecosa=2.0D0*fac3*fac1+fac4
4335 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4336 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4338 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4339 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4341 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4342 cd & (dcosg(k),k=1,3)
4344 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4345 & fac_shield(i)**2*fac_shield(j)**2*sss
4348 c ghalf=0.5D0*ggg(k)
4349 c gelc(k,i)=gelc(k,i)+ghalf
4350 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4351 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4352 c gelc(k,j)=gelc(k,j)+ghalf
4353 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4354 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4358 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4361 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4364 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4365 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4366 & *fac_shield(i)**2*fac_shield(j)**2
4368 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4369 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4370 & *fac_shield(i)**2*fac_shield(j)**2
4371 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4372 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4374 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4378 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4379 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4380 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4382 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4383 C energy of a peptide unit is assumed in the form of a second-order
4384 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4385 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4386 C are computed for EVERY pair of non-contiguous peptide groups.
4389 if (j.lt.nres-1) then
4401 muij(kkk)=mu(k,i)*mu(l,j)
4402 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4404 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4405 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4406 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4407 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4408 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4409 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4414 write (iout,*) 'EELEC: i',i,' j',j
4415 write (iout,*) 'j',j,' j1',j1,' j2',j2
4416 write(iout,*) 'muij',muij
4418 ury=scalar(uy(1,i),erij)
4419 urz=scalar(uz(1,i),erij)
4420 vry=scalar(uy(1,j),erij)
4421 vrz=scalar(uz(1,j),erij)
4422 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4423 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4424 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4425 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4426 fac=dsqrt(-ael6i)*r3ij
4428 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4429 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4430 & "uyvz",scalar(uy(1,i),uz(1,j)),
4431 & "uzvy",scalar(uz(1,i),uy(1,j)),
4432 & "uzvz",scalar(uz(1,i),uz(1,j))
4433 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4434 write (iout,*) "fac",fac
4441 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4444 cd write (iout,'(4i5,4f10.5)')
4445 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4446 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4447 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4448 cd & uy(:,j),uz(:,j)
4449 cd write (iout,'(4f10.5)')
4450 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4451 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4452 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4453 cd write (iout,'(9f10.5/)')
4454 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4455 C Derivatives of the elements of A in virtual-bond vectors
4456 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4458 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4459 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4460 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4461 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4462 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4463 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4464 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4465 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4466 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4467 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4468 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4469 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4471 C Compute radial contributions to the gradient
4489 C Add the contributions coming from er
4492 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4493 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4494 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4495 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4498 C Derivatives in DC(i)
4499 cgrad ghalf1=0.5d0*agg(k,1)
4500 cgrad ghalf2=0.5d0*agg(k,2)
4501 cgrad ghalf3=0.5d0*agg(k,3)
4502 cgrad ghalf4=0.5d0*agg(k,4)
4503 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4504 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4505 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4506 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4507 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4508 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4509 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4510 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4511 C Derivatives in DC(i+1)
4512 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4513 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4514 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4515 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4516 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4517 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4518 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4519 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4520 C Derivatives in DC(j)
4521 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4522 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4523 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4524 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4525 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4526 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4527 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4528 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4529 C Derivatives in DC(j+1) or DC(nres-1)
4530 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4531 & -3.0d0*vryg(k,3)*ury)
4532 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4533 & -3.0d0*vrzg(k,3)*ury)
4534 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4535 & -3.0d0*vryg(k,3)*urz)
4536 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4537 & -3.0d0*vrzg(k,3)*urz)
4538 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4540 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4553 aggi(k,l)=-aggi(k,l)
4554 aggi1(k,l)=-aggi1(k,l)
4555 aggj(k,l)=-aggj(k,l)
4556 aggj1(k,l)=-aggj1(k,l)
4559 if (j.lt.nres-1) then
4565 aggi(k,l)=-aggi(k,l)
4566 aggi1(k,l)=-aggi1(k,l)
4567 aggj(k,l)=-aggj(k,l)
4568 aggj1(k,l)=-aggj1(k,l)
4579 aggi(k,l)=-aggi(k,l)
4580 aggi1(k,l)=-aggi1(k,l)
4581 aggj(k,l)=-aggj(k,l)
4582 aggj1(k,l)=-aggj1(k,l)
4587 IF (wel_loc.gt.0.0d0) THEN
4588 C Contribution to the local-electrostatic energy coming from the i-j pair
4589 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4592 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4594 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4595 & " wel_loc",wel_loc
4597 if (shield_mode.eq.0) then
4604 eel_loc_ij=eel_loc_ij
4605 & *fac_shield(i)*fac_shield(j)*sss
4606 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4607 c & 'eelloc',i,j,eel_loc_ij
4608 C Now derivative over eel_loc
4609 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4610 & (shield_mode.gt.0)) then
4613 do ilist=1,ishield_list(i)
4614 iresshield=shield_list(ilist,i)
4616 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4619 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4621 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4622 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4626 do ilist=1,ishield_list(j)
4627 iresshield=shield_list(ilist,j)
4629 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4632 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4634 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4635 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4642 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4643 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4644 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4645 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4646 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4647 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4648 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4649 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4654 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4655 c & ' eel_loc_ij',eel_loc_ij
4656 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4657 C Calculate patrial derivative for theta angle
4659 geel_loc_ij=(a22*gmuij1(1)
4663 & *fac_shield(i)*fac_shield(j)*sss
4664 c write(iout,*) "derivative over thatai"
4665 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4667 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4668 & geel_loc_ij*wel_loc
4669 c write(iout,*) "derivative over thatai-1"
4670 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4677 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4678 & geel_loc_ij*wel_loc
4679 & *fac_shield(i)*fac_shield(j)*sss
4681 c Derivative over j residue
4682 geel_loc_ji=a22*gmuji1(1)
4686 c write(iout,*) "derivative over thataj"
4687 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4690 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4691 & geel_loc_ji*wel_loc
4692 & *fac_shield(i)*fac_shield(j)*sss
4699 c write(iout,*) "derivative over thataj-1"
4700 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4702 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4703 & geel_loc_ji*wel_loc
4704 & *fac_shield(i)*fac_shield(j)*sss
4706 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4708 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4709 & 'eelloc',i,j,eel_loc_ij
4710 c if (eel_loc_ij.ne.0)
4711 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4712 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4714 eel_loc=eel_loc+eel_loc_ij
4715 C Partial derivatives in virtual-bond dihedral angles gamma
4717 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4718 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4719 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4720 & *fac_shield(i)*fac_shield(j)*sss
4722 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4723 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4724 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4725 & *fac_shield(i)*fac_shield(j)*sss
4726 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4727 aux=eel_loc_ij/sss*sssgrad*rmij
4732 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4733 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4734 & *fac_shield(i)*fac_shield(j)*sss
4735 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4736 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4737 cgrad ghalf=0.5d0*ggg(l)
4738 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4739 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4743 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4746 C Remaining derivatives of eello
4748 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4749 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4750 & *fac_shield(i)*fac_shield(j)*sss
4752 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4753 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4754 & *fac_shield(i)*fac_shield(j)*sss
4756 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4757 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4758 & *fac_shield(i)*fac_shield(j)*sss
4760 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4761 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4762 & *fac_shield(i)*fac_shield(j)*sss
4766 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4767 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4769 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4770 & .and. num_conti.le.maxconts) then
4771 c write (iout,*) i,j," entered corr"
4773 C Calculate the contact function. The ith column of the array JCONT will
4774 C contain the numbers of atoms that make contacts with the atom I (of numbers
4775 C greater than I). The arrays FACONT and GACONT will contain the values of
4776 C the contact function and its derivative.
4777 c r0ij=1.02D0*rpp(iteli,itelj)
4778 c r0ij=1.11D0*rpp(iteli,itelj)
4779 r0ij=2.20D0*rpp(iteli,itelj)
4780 c r0ij=1.55D0*rpp(iteli,itelj)
4781 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4782 if (fcont.gt.0.0D0) then
4783 num_conti=num_conti+1
4784 if (num_conti.gt.maxconts) then
4785 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4786 & ' will skip next contacts for this conf.'
4788 jcont_hb(num_conti,i)=j
4789 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4790 cd & " jcont_hb",jcont_hb(num_conti,i)
4791 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4792 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4793 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4795 d_cont(num_conti,i)=rij
4796 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4797 C --- Electrostatic-interaction matrix ---
4798 a_chuj(1,1,num_conti,i)=a22
4799 a_chuj(1,2,num_conti,i)=a23
4800 a_chuj(2,1,num_conti,i)=a32
4801 a_chuj(2,2,num_conti,i)=a33
4802 C --- Gradient of rij
4804 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4811 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4812 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4813 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4814 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4815 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4820 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4821 C Calculate contact energies
4823 wij=cosa-3.0D0*cosb*cosg
4826 c fac3=dsqrt(-ael6i)/r0ij**3
4827 fac3=dsqrt(-ael6i)*r3ij
4828 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4829 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4830 if (ees0tmp.gt.0) then
4831 ees0pij=dsqrt(ees0tmp)
4835 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4836 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4837 if (ees0tmp.gt.0) then
4838 ees0mij=dsqrt(ees0tmp)
4843 if (shield_mode.eq.0) then
4847 ees0plist(num_conti,i)=j
4848 C fac_shield(i)=0.4d0
4849 C fac_shield(j)=0.6d0
4851 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4852 & *fac_shield(i)*fac_shield(j)*sss
4853 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4854 & *fac_shield(i)*fac_shield(j)*sss
4855 C Diagnostics. Comment out or remove after debugging!
4856 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4857 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4858 c ees0m(num_conti,i)=0.0D0
4860 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4861 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4862 C Angular derivatives of the contact function
4863 ees0pij1=fac3/ees0pij
4864 ees0mij1=fac3/ees0mij
4865 fac3p=-3.0D0*fac3*rrmij
4866 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4867 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4869 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4870 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4871 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4872 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4873 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4874 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4875 ecosap=ecosa1+ecosa2
4876 ecosbp=ecosb1+ecosb2
4877 ecosgp=ecosg1+ecosg2
4878 ecosam=ecosa1-ecosa2
4879 ecosbm=ecosb1-ecosb2
4880 ecosgm=ecosg1-ecosg2
4889 facont_hb(num_conti,i)=fcont
4890 fprimcont=fprimcont/rij
4891 cd facont_hb(num_conti,i)=1.0D0
4892 C Following line is for diagnostics.
4895 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4896 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4899 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4900 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4902 gggp(1)=gggp(1)+ees0pijp*xj
4903 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4904 gggp(2)=gggp(2)+ees0pijp*yj
4905 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4906 gggp(3)=gggp(3)+ees0pijp*zj
4907 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4908 gggm(1)=gggm(1)+ees0mijp*xj
4909 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4910 gggm(2)=gggm(2)+ees0mijp*yj
4911 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4912 gggm(3)=gggm(3)+ees0mijp*zj
4913 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4914 C Derivatives due to the contact function
4915 gacont_hbr(1,num_conti,i)=fprimcont*xj
4916 gacont_hbr(2,num_conti,i)=fprimcont*yj
4917 gacont_hbr(3,num_conti,i)=fprimcont*zj
4920 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4921 c following the change of gradient-summation algorithm.
4923 cgrad ghalfp=0.5D0*gggp(k)
4924 cgrad ghalfm=0.5D0*gggm(k)
4925 gacontp_hb1(k,num_conti,i)=!ghalfp
4926 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4927 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4928 & *fac_shield(i)*fac_shield(j)*sss
4930 gacontp_hb2(k,num_conti,i)=!ghalfp
4931 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4932 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4933 & *fac_shield(i)*fac_shield(j)*sss
4935 gacontp_hb3(k,num_conti,i)=gggp(k)
4936 & *fac_shield(i)*fac_shield(j)*sss
4938 gacontm_hb1(k,num_conti,i)=!ghalfm
4939 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4940 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4941 & *fac_shield(i)*fac_shield(j)*sss
4943 gacontm_hb2(k,num_conti,i)=!ghalfm
4944 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4945 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4946 & *fac_shield(i)*fac_shield(j)*sss
4948 gacontm_hb3(k,num_conti,i)=gggm(k)
4949 & *fac_shield(i)*fac_shield(j)*sss
4952 C Diagnostics. Comment out or remove after debugging!
4954 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4955 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4956 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4957 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4958 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4959 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4962 endif ! num_conti.le.maxconts
4966 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4969 ghalf=0.5d0*agg(l,k)
4970 aggi(l,k)=aggi(l,k)+ghalf
4971 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4972 aggj(l,k)=aggj(l,k)+ghalf
4975 if (j.eq.nres-1 .and. i.lt.j-2) then
4978 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4983 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4986 C-----------------------------------------------------------------------------
4987 subroutine eturn3(i,eello_turn3)
4988 C Third- and fourth-order contributions from turns
4989 implicit real*8 (a-h,o-z)
4990 include 'DIMENSIONS'
4991 include 'COMMON.IOUNITS'
4992 include 'COMMON.GEO'
4993 include 'COMMON.VAR'
4994 include 'COMMON.LOCAL'
4995 include 'COMMON.CHAIN'
4996 include 'COMMON.DERIV'
4997 include 'COMMON.INTERACT'
4998 include 'COMMON.CORRMAT'
4999 include 'COMMON.TORSION'
5000 include 'COMMON.VECTORS'
5001 include 'COMMON.FFIELD'
5002 include 'COMMON.CONTROL'
5003 include 'COMMON.SHIELD'
5005 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5006 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5007 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
5008 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
5009 & auxgmat2(2,2),auxgmatt2(2,2)
5010 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5011 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5012 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5013 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5016 c write (iout,*) "eturn3",i,j,j1,j2
5021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5023 C Third-order contributions
5030 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5031 cd call checkint_turn3(i,a_temp,eello_turn3_num)
5032 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5033 c auxalary matices for theta gradient
5034 c auxalary matrix for i+1 and constant i+2
5035 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5036 c auxalary matrix for i+2 and constant i+1
5037 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5038 call transpose2(auxmat(1,1),auxmat1(1,1))
5039 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5040 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5041 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5042 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5043 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5044 if (shield_mode.eq.0) then
5051 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5052 & *fac_shield(i)*fac_shield(j)
5053 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
5054 & *fac_shield(i)*fac_shield(j)
5055 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5058 C Derivatives in theta
5059 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5060 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5061 & *fac_shield(i)*fac_shield(j)
5062 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5063 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5064 & *fac_shield(i)*fac_shield(j)
5067 C Derivatives in shield mode
5068 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5069 & (shield_mode.gt.0)) then
5072 do ilist=1,ishield_list(i)
5073 iresshield=shield_list(ilist,i)
5075 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5077 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5079 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5080 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5084 do ilist=1,ishield_list(j)
5085 iresshield=shield_list(ilist,j)
5087 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5089 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5091 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5092 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5099 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5100 & grad_shield(k,i)*eello_t3/fac_shield(i)
5101 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5102 & grad_shield(k,j)*eello_t3/fac_shield(j)
5103 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5104 & grad_shield(k,i)*eello_t3/fac_shield(i)
5105 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5106 & grad_shield(k,j)*eello_t3/fac_shield(j)
5110 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5111 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5112 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5113 cd & ' eello_turn3_num',4*eello_turn3_num
5114 C Derivatives in gamma(i)
5115 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5116 call transpose2(auxmat2(1,1),auxmat3(1,1))
5117 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5118 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5119 & *fac_shield(i)*fac_shield(j)
5120 C Derivatives in gamma(i+1)
5121 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5122 call transpose2(auxmat2(1,1),auxmat3(1,1))
5123 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5124 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5125 & +0.5d0*(pizda(1,1)+pizda(2,2))
5126 & *fac_shield(i)*fac_shield(j)
5127 C Cartesian derivatives
5129 c ghalf1=0.5d0*agg(l,1)
5130 c ghalf2=0.5d0*agg(l,2)
5131 c ghalf3=0.5d0*agg(l,3)
5132 c ghalf4=0.5d0*agg(l,4)
5133 a_temp(1,1)=aggi(l,1)!+ghalf1
5134 a_temp(1,2)=aggi(l,2)!+ghalf2
5135 a_temp(2,1)=aggi(l,3)!+ghalf3
5136 a_temp(2,2)=aggi(l,4)!+ghalf4
5137 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5138 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5139 & +0.5d0*(pizda(1,1)+pizda(2,2))
5140 & *fac_shield(i)*fac_shield(j)
5142 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5143 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5144 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5145 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5146 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5147 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5148 & +0.5d0*(pizda(1,1)+pizda(2,2))
5149 & *fac_shield(i)*fac_shield(j)
5150 a_temp(1,1)=aggj(l,1)!+ghalf1
5151 a_temp(1,2)=aggj(l,2)!+ghalf2
5152 a_temp(2,1)=aggj(l,3)!+ghalf3
5153 a_temp(2,2)=aggj(l,4)!+ghalf4
5154 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5155 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5156 & +0.5d0*(pizda(1,1)+pizda(2,2))
5157 & *fac_shield(i)*fac_shield(j)
5158 a_temp(1,1)=aggj1(l,1)
5159 a_temp(1,2)=aggj1(l,2)
5160 a_temp(2,1)=aggj1(l,3)
5161 a_temp(2,2)=aggj1(l,4)
5162 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5163 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5164 & +0.5d0*(pizda(1,1)+pizda(2,2))
5165 & *fac_shield(i)*fac_shield(j)
5169 C-------------------------------------------------------------------------------
5170 subroutine eturn4(i,eello_turn4)
5171 C Third- and fourth-order contributions from turns
5172 implicit real*8 (a-h,o-z)
5173 include 'DIMENSIONS'
5174 include 'COMMON.IOUNITS'
5175 include 'COMMON.GEO'
5176 include 'COMMON.VAR'
5177 include 'COMMON.LOCAL'
5178 include 'COMMON.CHAIN'
5179 include 'COMMON.DERIV'
5180 include 'COMMON.INTERACT'
5181 include 'COMMON.CORRMAT'
5182 include 'COMMON.TORSION'
5183 include 'COMMON.VECTORS'
5184 include 'COMMON.FFIELD'
5185 include 'COMMON.CONTROL'
5186 include 'COMMON.SHIELD'
5188 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5189 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5190 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5191 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5192 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5193 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5194 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5195 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5196 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5197 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5198 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5203 C Fourth-order contributions
5211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5212 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5213 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5214 c write(iout,*)"WCHODZE W PROGRAM"
5219 iti1=itype2loc(itype(i+1))
5220 iti2=itype2loc(itype(i+2))
5221 iti3=itype2loc(itype(i+3))
5222 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5223 call transpose2(EUg(1,1,i+1),e1t(1,1))
5224 call transpose2(Eug(1,1,i+2),e2t(1,1))
5225 call transpose2(Eug(1,1,i+3),e3t(1,1))
5226 C Ematrix derivative in theta
5227 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5228 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5229 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5230 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5231 c eta1 in derivative theta
5232 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5233 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234 c auxgvec is derivative of Ub2 so i+3 theta
5235 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5236 c auxalary matrix of E i+1
5237 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5240 s1=scalar2(b1(1,i+2),auxvec(1))
5241 c derivative of theta i+2 with constant i+3
5242 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5243 c derivative of theta i+2 with constant i+2
5244 gs32=scalar2(b1(1,i+2),auxgvec(1))
5245 c derivative of E matix in theta of i+1
5246 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5248 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5249 c ea31 in derivative theta
5250 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5251 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5252 c auxilary matrix auxgvec of Ub2 with constant E matirx
5253 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5254 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5255 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5259 s2=scalar2(b1(1,i+1),auxvec(1))
5260 c derivative of theta i+1 with constant i+3
5261 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5262 c derivative of theta i+2 with constant i+1
5263 gs21=scalar2(b1(1,i+1),auxgvec(1))
5264 c derivative of theta i+3 with constant i+1
5265 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5266 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5268 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5269 c two derivatives over diffetent matrices
5270 c gtae3e2 is derivative over i+3
5271 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5272 c ae3gte2 is derivative over i+2
5273 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5274 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5275 c three possible derivative over theta E matices
5277 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5279 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5281 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5282 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5284 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5285 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5286 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5287 if (shield_mode.eq.0) then
5294 eello_turn4=eello_turn4-(s1+s2+s3)
5295 & *fac_shield(i)*fac_shield(j)
5296 eello_t4=-(s1+s2+s3)
5297 & *fac_shield(i)*fac_shield(j)
5298 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5299 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5300 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5301 C Now derivative over shield:
5302 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5303 & (shield_mode.gt.0)) then
5306 do ilist=1,ishield_list(i)
5307 iresshield=shield_list(ilist,i)
5309 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5311 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5313 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5314 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5318 do ilist=1,ishield_list(j)
5319 iresshield=shield_list(ilist,j)
5321 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5323 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5325 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5326 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5333 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5334 & grad_shield(k,i)*eello_t4/fac_shield(i)
5335 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5336 & grad_shield(k,j)*eello_t4/fac_shield(j)
5337 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5338 & grad_shield(k,i)*eello_t4/fac_shield(i)
5339 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5340 & grad_shield(k,j)*eello_t4/fac_shield(j)
5349 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5350 cd & ' eello_turn4_num',8*eello_turn4_num
5352 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5353 & -(gs13+gsE13+gsEE1)*wturn4
5354 & *fac_shield(i)*fac_shield(j)
5355 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5356 & -(gs23+gs21+gsEE2)*wturn4
5357 & *fac_shield(i)*fac_shield(j)
5359 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5360 & -(gs32+gsE31+gsEE3)*wturn4
5361 & *fac_shield(i)*fac_shield(j)
5363 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5366 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5367 & 'eturn4',i,j,-(s1+s2+s3)
5368 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5369 c & ' eello_turn4_num',8*eello_turn4_num
5370 C Derivatives in gamma(i)
5371 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5372 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5373 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5374 s1=scalar2(b1(1,i+2),auxvec(1))
5375 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5376 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5377 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5378 & *fac_shield(i)*fac_shield(j)
5379 C Derivatives in gamma(i+1)
5380 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5381 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5382 s2=scalar2(b1(1,i+1),auxvec(1))
5383 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5384 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5385 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5386 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5387 & *fac_shield(i)*fac_shield(j)
5388 C Derivatives in gamma(i+2)
5389 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5390 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5391 s1=scalar2(b1(1,i+2),auxvec(1))
5392 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5393 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5394 s2=scalar2(b1(1,i+1),auxvec(1))
5395 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5396 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5397 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5398 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5399 & *fac_shield(i)*fac_shield(j)
5400 C Cartesian derivatives
5401 C Derivatives of this turn contributions in DC(i+2)
5402 if (j.lt.nres-1) then
5404 a_temp(1,1)=agg(l,1)
5405 a_temp(1,2)=agg(l,2)
5406 a_temp(2,1)=agg(l,3)
5407 a_temp(2,2)=agg(l,4)
5408 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5409 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5410 s1=scalar2(b1(1,i+2),auxvec(1))
5411 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5412 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5413 s2=scalar2(b1(1,i+1),auxvec(1))
5414 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5415 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5416 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5418 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5419 & *fac_shield(i)*fac_shield(j)
5422 C Remaining derivatives of this turn contribution
5424 a_temp(1,1)=aggi(l,1)
5425 a_temp(1,2)=aggi(l,2)
5426 a_temp(2,1)=aggi(l,3)
5427 a_temp(2,2)=aggi(l,4)
5428 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5429 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5430 s1=scalar2(b1(1,i+2),auxvec(1))
5431 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5432 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5433 s2=scalar2(b1(1,i+1),auxvec(1))
5434 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5435 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5436 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5437 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5438 & *fac_shield(i)*fac_shield(j)
5439 a_temp(1,1)=aggi1(l,1)
5440 a_temp(1,2)=aggi1(l,2)
5441 a_temp(2,1)=aggi1(l,3)
5442 a_temp(2,2)=aggi1(l,4)
5443 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5444 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5445 s1=scalar2(b1(1,i+2),auxvec(1))
5446 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5447 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5448 s2=scalar2(b1(1,i+1),auxvec(1))
5449 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5450 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5451 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5452 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5453 & *fac_shield(i)*fac_shield(j)
5454 a_temp(1,1)=aggj(l,1)
5455 a_temp(1,2)=aggj(l,2)
5456 a_temp(2,1)=aggj(l,3)
5457 a_temp(2,2)=aggj(l,4)
5458 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5459 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5460 s1=scalar2(b1(1,i+2),auxvec(1))
5461 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5462 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5463 s2=scalar2(b1(1,i+1),auxvec(1))
5464 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5465 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5466 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5467 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5468 & *fac_shield(i)*fac_shield(j)
5469 a_temp(1,1)=aggj1(l,1)
5470 a_temp(1,2)=aggj1(l,2)
5471 a_temp(2,1)=aggj1(l,3)
5472 a_temp(2,2)=aggj1(l,4)
5473 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5474 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5475 s1=scalar2(b1(1,i+2),auxvec(1))
5476 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5477 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5478 s2=scalar2(b1(1,i+1),auxvec(1))
5479 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5480 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5481 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5482 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5483 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5484 & *fac_shield(i)*fac_shield(j)
5488 C-----------------------------------------------------------------------------
5489 subroutine vecpr(u,v,w)
5490 implicit real*8(a-h,o-z)
5491 dimension u(3),v(3),w(3)
5492 w(1)=u(2)*v(3)-u(3)*v(2)
5493 w(2)=-u(1)*v(3)+u(3)*v(1)
5494 w(3)=u(1)*v(2)-u(2)*v(1)
5497 C-----------------------------------------------------------------------------
5498 subroutine unormderiv(u,ugrad,unorm,ungrad)
5499 C This subroutine computes the derivatives of a normalized vector u, given
5500 C the derivatives computed without normalization conditions, ugrad. Returns
5503 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5504 double precision vec(3)
5505 double precision scalar
5507 c write (2,*) 'ugrad',ugrad
5510 vec(i)=scalar(ugrad(1,i),u(1))
5512 c write (2,*) 'vec',vec
5515 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5518 c write (2,*) 'ungrad',ungrad
5521 C-----------------------------------------------------------------------------
5522 subroutine escp_soft_sphere(evdw2,evdw2_14)
5524 C This subroutine calculates the excluded-volume interaction energy between
5525 C peptide-group centers and side chains and its gradient in virtual-bond and
5526 C side-chain vectors.
5528 implicit real*8 (a-h,o-z)
5529 include 'DIMENSIONS'
5530 include 'COMMON.GEO'
5531 include 'COMMON.VAR'
5532 include 'COMMON.LOCAL'
5533 include 'COMMON.CHAIN'
5534 include 'COMMON.DERIV'
5535 include 'COMMON.INTERACT'
5536 include 'COMMON.FFIELD'
5537 include 'COMMON.IOUNITS'
5538 include 'COMMON.CONTROL'
5540 integer xshift,yshift,zshift
5544 cd print '(a)','Enter ESCP'
5545 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5549 do i=iatscp_s,iatscp_e
5550 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5552 xi=0.5D0*(c(1,i)+c(1,i+1))
5553 yi=0.5D0*(c(2,i)+c(2,i+1))
5554 zi=0.5D0*(c(3,i)+c(3,i+1))
5555 C Return atom into box, boxxsize is size of box in x dimension
5557 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5558 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5559 C Condition for being inside the proper box
5560 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5561 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5565 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5566 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5567 C Condition for being inside the proper box
5568 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5569 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5573 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5574 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5575 cC Condition for being inside the proper box
5576 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5577 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5581 if (xi.lt.0) xi=xi+boxxsize
5583 if (yi.lt.0) yi=yi+boxysize
5585 if (zi.lt.0) zi=zi+boxzsize
5586 C xi=xi+xshift*boxxsize
5587 C yi=yi+yshift*boxysize
5588 C zi=zi+zshift*boxzsize
5589 do iint=1,nscp_gr(i)
5591 do j=iscpstart(i,iint),iscpend(i,iint)
5592 if (itype(j).eq.ntyp1) cycle
5593 itypj=iabs(itype(j))
5594 C Uncomment following three lines for SC-p interactions
5598 C Uncomment following three lines for Ca-p interactions
5603 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5604 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5605 C Condition for being inside the proper box
5606 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5607 c & (xj.lt.((-0.5d0)*boxxsize))) then
5611 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5612 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5613 cC Condition for being inside the proper box
5614 c if ((yj.gt.((0.5d0)*boxysize)).or.
5615 c & (yj.lt.((-0.5d0)*boxysize))) then
5619 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5620 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5621 C Condition for being inside the proper box
5622 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5623 c & (zj.lt.((-0.5d0)*boxzsize))) then
5626 if (xj.lt.0) xj=xj+boxxsize
5628 if (yj.lt.0) yj=yj+boxysize
5630 if (zj.lt.0) zj=zj+boxzsize
5631 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5639 xj=xj_safe+xshift*boxxsize
5640 yj=yj_safe+yshift*boxysize
5641 zj=zj_safe+zshift*boxzsize
5642 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5643 if(dist_temp.lt.dist_init) then
5653 if (subchap.eq.1) then
5666 rij=xj*xj+yj*yj+zj*zj
5670 if (rij.lt.r0ijsq) then
5671 evdwij=0.25d0*(rij-r0ijsq)**2
5679 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5684 cgrad if (j.lt.i) then
5685 cd write (iout,*) 'j<i'
5686 C Uncomment following three lines for SC-p interactions
5688 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5691 cd write (iout,*) 'j>i'
5693 cgrad ggg(k)=-ggg(k)
5694 C Uncomment following line for SC-p interactions
5695 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5699 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5701 cgrad kstart=min0(i+1,j)
5702 cgrad kend=max0(i-1,j-1)
5703 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5704 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5705 cgrad do k=kstart,kend
5707 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5711 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5712 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5723 C-----------------------------------------------------------------------------
5724 subroutine escp(evdw2,evdw2_14)
5726 C This subroutine calculates the excluded-volume interaction energy between
5727 C peptide-group centers and side chains and its gradient in virtual-bond and
5728 C side-chain vectors.
5731 include 'DIMENSIONS'
5732 include 'COMMON.GEO'
5733 include 'COMMON.VAR'
5734 include 'COMMON.LOCAL'
5735 include 'COMMON.CHAIN'
5736 include 'COMMON.DERIV'
5737 include 'COMMON.INTERACT'
5738 include 'COMMON.FFIELD'
5739 include 'COMMON.IOUNITS'
5740 include 'COMMON.CONTROL'
5741 include 'COMMON.SPLITELE'
5742 integer xshift,yshift,zshift
5743 double precision ggg(3)
5744 integer i,iint,j,k,iteli,itypj,subchap
5745 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5747 double precision evdw2,evdw2_14,evdwij
5748 double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,
5749 & dist_temp, dist_init
5750 double precision sscale,sscagrad
5753 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5754 cd print '(a)','Enter ESCP'
5755 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5759 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5760 do i=iatscp_s,iatscp_e
5761 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5763 xi=0.5D0*(c(1,i)+c(1,i+1))
5764 yi=0.5D0*(c(2,i)+c(2,i+1))
5765 zi=0.5D0*(c(3,i)+c(3,i+1))
5767 if (xi.lt.0) xi=xi+boxxsize
5769 if (yi.lt.0) yi=yi+boxysize
5771 if (zi.lt.0) zi=zi+boxzsize
5772 c xi=xi+xshift*boxxsize
5773 c yi=yi+yshift*boxysize
5774 c zi=zi+zshift*boxzsize
5775 c print *,xi,yi,zi,'polozenie i'
5776 C Return atom into box, boxxsize is size of box in x dimension
5778 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5779 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5780 C Condition for being inside the proper box
5781 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5782 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5786 c print *,xi,boxxsize,"pierwszy"
5788 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5789 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5790 C Condition for being inside the proper box
5791 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5792 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5796 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5797 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5798 C Condition for being inside the proper box
5799 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5800 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5803 do iint=1,nscp_gr(i)
5805 do j=iscpstart(i,iint),iscpend(i,iint)
5806 itypj=iabs(itype(j))
5807 if (itypj.eq.ntyp1) cycle
5808 C Uncomment following three lines for SC-p interactions
5812 C Uncomment following three lines for Ca-p interactions
5817 if (xj.lt.0) xj=xj+boxxsize
5819 if (yj.lt.0) yj=yj+boxysize
5821 if (zj.lt.0) zj=zj+boxzsize
5823 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5824 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5825 C Condition for being inside the proper box
5826 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5827 c & (xj.lt.((-0.5d0)*boxxsize))) then
5831 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5832 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5833 cC Condition for being inside the proper box
5834 c if ((yj.gt.((0.5d0)*boxysize)).or.
5835 c & (yj.lt.((-0.5d0)*boxysize))) then
5839 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5840 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5841 C Condition for being inside the proper box
5842 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5843 c & (zj.lt.((-0.5d0)*boxzsize))) then
5846 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5847 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5855 xj=xj_safe+xshift*boxxsize
5856 yj=yj_safe+yshift*boxysize
5857 zj=zj_safe+zshift*boxzsize
5858 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5859 if(dist_temp.lt.dist_init) then
5869 if (subchap.eq.1) then
5878 c print *,xj,yj,zj,'polozenie j'
5879 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5881 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5882 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5883 c if (sss.eq.0) print *,'czasem jest OK'
5884 if (sss.le.0.0d0) cycle
5885 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5887 e1=fac*fac*aad(itypj,iteli)
5888 e2=fac*bad(itypj,iteli)
5889 if (iabs(j-i) .le. 2) then
5892 evdw2_14=evdw2_14+(e1+e2)*sss
5895 evdw2=evdw2+evdwij*sss
5896 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5897 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5898 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5901 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5903 fac=-(evdwij+e1)*rrij*sss
5904 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5908 cgrad if (j.lt.i) then
5909 cd write (iout,*) 'j<i'
5910 C Uncomment following three lines for SC-p interactions
5912 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5915 cd write (iout,*) 'j>i'
5917 cgrad ggg(k)=-ggg(k)
5918 C Uncomment following line for SC-p interactions
5919 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5920 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5924 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5926 cgrad kstart=min0(i+1,j)
5927 cgrad kend=max0(i-1,j-1)
5928 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5929 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5930 cgrad do k=kstart,kend
5932 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5936 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5937 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5939 c endif !endif for sscale cutoff
5949 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5950 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5951 gradx_scp(j,i)=expon*gradx_scp(j,i)
5954 C******************************************************************************
5958 C To save time the factor EXPON has been extracted from ALL components
5959 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5962 C******************************************************************************
5965 C--------------------------------------------------------------------------
5966 subroutine edis(ehpb)
5968 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5970 implicit real*8 (a-h,o-z)
5971 include 'DIMENSIONS'
5972 include 'COMMON.SBRIDGE'
5973 include 'COMMON.CHAIN'
5974 include 'COMMON.DERIV'
5975 include 'COMMON.VAR'
5976 include 'COMMON.INTERACT'
5977 include 'COMMON.IOUNITS'
5978 include 'COMMON.CONTROL'
5979 dimension ggg(3),ggg_peak(3,1000)
5984 c 8/21/18 AL: added explicit restraints on reference coords
5985 c write (iout,*) "restr_on_coord",restr_on_coord
5986 if (restr_on_coord) then
5990 if (itype(i).eq.ntyp1) cycle
5992 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5993 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5995 if (itype(i).ne.10) then
5997 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5998 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
6001 if (energy_dec) write (iout,*)
6002 & "i",i," bfac",bfac(i)," ecoor",ecoor
6003 ehpb=ehpb+0.5d0*bfac(i)*ecoor
6007 C write (iout,*) ,"link_end",link_end,constr_dist
6008 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6009 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
6010 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
6011 c & " link_end_peak",link_end_peak
6012 if (link_end.eq.0.and.link_end_peak.eq.0) return
6013 do i=link_start_peak,link_end_peak
6015 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
6016 c & ipeak(1,i),ipeak(2,i)
6017 do ip=ipeak(1,i),ipeak(2,i)
6022 C iii and jjj point to the residues for which the distance is assigned.
6023 c if (ii.gt.nres) then
6030 if (ii.gt.nres) then
6035 if (jj.gt.nres) then
6040 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
6041 aux=dexp(-scal_peak*aux)
6042 ehpb_peak=ehpb_peak+aux
6043 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
6044 & forcon_peak(ip))*aux/dd
6046 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
6048 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
6049 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
6050 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
6052 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
6053 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
6054 do ip=ipeak(1,i),ipeak(2,i)
6057 ggg(j)=ggg_peak(j,iip)/ehpb_peak
6061 C iii and jjj point to the residues for which the distance is assigned.
6062 c if (ii.gt.nres) then
6069 if (ii.gt.nres) then
6074 if (jj.gt.nres) then
6081 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6086 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6090 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6091 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6095 do i=link_start,link_end
6096 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6097 C CA-CA distance used in regularization of structure.
6100 C iii and jjj point to the residues for which the distance is assigned.
6101 if (ii.gt.nres) then
6106 if (jj.gt.nres) then
6111 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6112 c & dhpb(i),dhpb1(i),forcon(i)
6113 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6114 C distance and angle dependent SS bond potential.
6115 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6116 C & iabs(itype(jjj)).eq.1) then
6117 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6118 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6119 if (.not.dyn_ss .and. i.le.nss) then
6120 C 15/02/13 CC dynamic SSbond - additional check
6121 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6122 & iabs(itype(jjj)).eq.1) then
6123 call ssbond_ene(iii,jjj,eij)
6126 cd write (iout,*) "eij",eij
6127 cd & ' waga=',waga,' fac=',fac
6128 ! else if (ii.gt.nres .and. jj.gt.nres) then
6130 C Calculate the distance between the two points and its difference from the
6133 if (irestr_type(i).eq.11) then
6134 ehpb=ehpb+fordepth(i)!**4.0d0
6135 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6136 fac=fordepth(i)!**4.0d0
6137 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6138 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6139 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6140 & ehpb,irestr_type(i)
6141 else if (irestr_type(i).eq.10) then
6142 c AL 6//19/2018 cross-link restraints
6143 xdis = 0.5d0*(dd/forcon(i))**2
6144 expdis = dexp(-xdis)
6145 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6146 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6147 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6148 c & " wboltzd",wboltzd
6149 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6150 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6151 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6152 & *expdis/(aux*forcon(i)**2)
6153 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6154 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6155 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6156 else if (irestr_type(i).eq.2) then
6157 c Quartic restraints
6158 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6159 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6160 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6161 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6162 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6164 c Quadratic restraints
6166 C Get the force constant corresponding to this distance.
6168 C Calculate the contribution to energy.
6169 ehpb=ehpb+0.5d0*waga*rdis*rdis
6170 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6171 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6172 & 0.5d0*waga*rdis*rdis,irestr_type(i)
6174 C Evaluate gradient.
6178 c Calculate Cartesian gradient
6180 ggg(j)=fac*(c(j,jj)-c(j,ii))
6182 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6183 C If this is a SC-SC distance, we need to calculate the contributions to the
6184 C Cartesian gradient in the SC vectors (ghpbx).
6187 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6192 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6196 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6197 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6203 C--------------------------------------------------------------------------
6204 subroutine ssbond_ene(i,j,eij)
6206 C Calculate the distance and angle dependent SS-bond potential energy
6207 C using a free-energy function derived based on RHF/6-31G** ab initio
6208 C calculations of diethyl disulfide.
6210 C A. Liwo and U. Kozlowska, 11/24/03
6212 implicit real*8 (a-h,o-z)
6213 include 'DIMENSIONS'
6214 include 'COMMON.SBRIDGE'
6215 include 'COMMON.CHAIN'
6216 include 'COMMON.DERIV'
6217 include 'COMMON.LOCAL'
6218 include 'COMMON.INTERACT'
6219 include 'COMMON.VAR'
6220 include 'COMMON.IOUNITS'
6221 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6222 itypi=iabs(itype(i))
6226 dxi=dc_norm(1,nres+i)
6227 dyi=dc_norm(2,nres+i)
6228 dzi=dc_norm(3,nres+i)
6229 c dsci_inv=dsc_inv(itypi)
6230 dsci_inv=vbld_inv(nres+i)
6231 itypj=iabs(itype(j))
6232 c dscj_inv=dsc_inv(itypj)
6233 dscj_inv=vbld_inv(nres+j)
6237 dxj=dc_norm(1,nres+j)
6238 dyj=dc_norm(2,nres+j)
6239 dzj=dc_norm(3,nres+j)
6240 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6245 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6246 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6247 om12=dxi*dxj+dyi*dyj+dzi*dzj
6249 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6250 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6256 deltat12=om2-om1+2.0d0
6258 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6259 & +akct*deltad*deltat12
6260 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6261 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6262 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6263 c & " deltat12",deltat12," eij",eij
6264 ed=2*akcm*deltad+akct*deltat12
6266 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6267 eom1=-2*akth*deltat1-pom1-om2*pom2
6268 eom2= 2*akth*deltat2+pom1-om1*pom2
6271 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6272 ghpbx(k,i)=ghpbx(k,i)-ggk
6273 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6274 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6275 ghpbx(k,j)=ghpbx(k,j)+ggk
6276 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6277 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6278 ghpbc(k,i)=ghpbc(k,i)-ggk
6279 ghpbc(k,j)=ghpbc(k,j)+ggk
6282 C Calculate the components of the gradient in DC and X
6286 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6291 C--------------------------------------------------------------------------
6292 subroutine ebond(estr)
6294 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6296 implicit real*8 (a-h,o-z)
6297 include 'DIMENSIONS'
6298 include 'COMMON.LOCAL'
6299 include 'COMMON.GEO'
6300 include 'COMMON.INTERACT'
6301 include 'COMMON.DERIV'
6302 include 'COMMON.VAR'
6303 include 'COMMON.CHAIN'
6304 include 'COMMON.IOUNITS'
6305 include 'COMMON.NAMES'
6306 include 'COMMON.FFIELD'
6307 include 'COMMON.CONTROL'
6308 include 'COMMON.SETUP'
6309 double precision u(3),ud(3)
6312 do i=ibondp_start,ibondp_end
6313 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6316 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6317 diff = vbld(i)-vbldp0
6319 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6320 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6322 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6323 c & *dc(j,i-1)/vbld(i)
6325 c if (energy_dec) write(iout,*)
6326 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6328 C Checking if it involves dummy (NH3+ or COO-) group
6329 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6330 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6331 diff = vbld(i)-vbldpDUM
6332 if (energy_dec) write(iout,*) "dum_bond",i,diff
6334 C NO vbldp0 is the equlibrium length of spring for peptide group
6335 diff = vbld(i)-vbldp0
6338 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6339 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6342 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6344 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6348 estr=0.5d0*AKP*estr+estr1
6350 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6352 do i=ibond_start,ibond_end
6354 if (iti.ne.10 .and. iti.ne.ntyp1) then
6357 diff=vbld(i+nres)-vbldsc0(1,iti)
6358 if (energy_dec) write (iout,*)
6359 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6360 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6361 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6363 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6367 diff=vbld(i+nres)-vbldsc0(j,iti)
6368 ud(j)=aksc(j,iti)*diff
6369 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6383 uprod2=uprod2*u(k)*u(k)
6387 usumsqder=usumsqder+ud(j)*uprod2
6389 estr=estr+uprod/usum
6391 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6399 C--------------------------------------------------------------------------
6400 subroutine ebend(etheta)
6402 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6403 C angles gamma and its derivatives in consecutive thetas and gammas.
6405 implicit real*8 (a-h,o-z)
6406 include 'DIMENSIONS'
6407 include 'COMMON.LOCAL'
6408 include 'COMMON.GEO'
6409 include 'COMMON.INTERACT'
6410 include 'COMMON.DERIV'
6411 include 'COMMON.VAR'
6412 include 'COMMON.CHAIN'
6413 include 'COMMON.IOUNITS'
6414 include 'COMMON.NAMES'
6415 include 'COMMON.FFIELD'
6416 include 'COMMON.CONTROL'
6417 include 'COMMON.TORCNSTR'
6418 common /calcthet/ term1,term2,termm,diffak,ratak,
6419 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6420 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6421 double precision y(2),z(2)
6423 c time11=dexp(-2*time)
6426 c write (*,'(a,i2)') 'EBEND ICG=',icg
6427 do i=ithet_start,ithet_end
6428 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6429 & .or.itype(i).eq.ntyp1) cycle
6430 C Zero the energy function and its derivative at 0 or pi.
6431 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6433 ichir1=isign(1,itype(i-2))
6434 ichir2=isign(1,itype(i))
6435 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6436 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6437 if (itype(i-1).eq.10) then
6438 itype1=isign(10,itype(i-2))
6439 ichir11=isign(1,itype(i-2))
6440 ichir12=isign(1,itype(i-2))
6441 itype2=isign(10,itype(i))
6442 ichir21=isign(1,itype(i))
6443 ichir22=isign(1,itype(i))
6446 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6449 if (phii.ne.phii) phii=150.0
6459 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6462 if (phii1.ne.phii1) phii1=150.0
6474 C Calculate the "mean" value of theta from the part of the distribution
6475 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6476 C In following comments this theta will be referred to as t_c.
6477 thet_pred_mean=0.0d0
6479 athetk=athet(k,it,ichir1,ichir2)
6480 bthetk=bthet(k,it,ichir1,ichir2)
6482 athetk=athet(k,itype1,ichir11,ichir12)
6483 bthetk=bthet(k,itype2,ichir21,ichir22)
6485 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6486 c write(iout,*) 'chuj tu', y(k),z(k)
6488 dthett=thet_pred_mean*ssd
6489 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6490 C Derivatives of the "mean" values in gamma1 and gamma2.
6491 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6492 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6493 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6494 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6496 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6497 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6498 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6499 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6501 if (theta(i).gt.pi-delta) then
6502 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6504 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6505 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6506 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6508 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6510 else if (theta(i).lt.delta) then
6511 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6512 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6513 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6515 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6516 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6519 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6522 etheta=etheta+ethetai
6523 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6524 & 'ebend',i,ethetai,theta(i),itype(i)
6525 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6526 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6527 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6530 C Ufff.... We've done all this!!!
6533 C---------------------------------------------------------------------------
6534 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6536 implicit real*8 (a-h,o-z)
6537 include 'DIMENSIONS'
6538 include 'COMMON.LOCAL'
6539 include 'COMMON.IOUNITS'
6540 common /calcthet/ term1,term2,termm,diffak,ratak,
6541 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6542 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6543 C Calculate the contributions to both Gaussian lobes.
6544 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6545 C The "polynomial part" of the "standard deviation" of this part of
6546 C the distributioni.
6547 ccc write (iout,*) thetai,thet_pred_mean
6550 sig=sig*thet_pred_mean+polthet(j,it)
6552 C Derivative of the "interior part" of the "standard deviation of the"
6553 C gamma-dependent Gaussian lobe in t_c.
6554 sigtc=3*polthet(3,it)
6556 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6559 C Set the parameters of both Gaussian lobes of the distribution.
6560 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6561 fac=sig*sig+sigc0(it)
6564 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6565 sigsqtc=-4.0D0*sigcsq*sigtc
6566 c print *,i,sig,sigtc,sigsqtc
6567 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6568 sigtc=-sigtc/(fac*fac)
6569 C Following variable is sigma(t_c)**(-2)
6570 sigcsq=sigcsq*sigcsq
6572 sig0inv=1.0D0/sig0i**2
6573 delthec=thetai-thet_pred_mean
6574 delthe0=thetai-theta0i
6575 term1=-0.5D0*sigcsq*delthec*delthec
6576 term2=-0.5D0*sig0inv*delthe0*delthe0
6577 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6578 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6579 C NaNs in taking the logarithm. We extract the largest exponent which is added
6580 C to the energy (this being the log of the distribution) at the end of energy
6581 C term evaluation for this virtual-bond angle.
6582 if (term1.gt.term2) then
6584 term2=dexp(term2-termm)
6588 term1=dexp(term1-termm)
6591 C The ratio between the gamma-independent and gamma-dependent lobes of
6592 C the distribution is a Gaussian function of thet_pred_mean too.
6593 diffak=gthet(2,it)-thet_pred_mean
6594 ratak=diffak/gthet(3,it)**2
6595 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6596 C Let's differentiate it in thet_pred_mean NOW.
6598 C Now put together the distribution terms to make complete distribution.
6599 termexp=term1+ak*term2
6600 termpre=sigc+ak*sig0i
6601 C Contribution of the bending energy from this theta is just the -log of
6602 C the sum of the contributions from the two lobes and the pre-exponential
6603 C factor. Simple enough, isn't it?
6604 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6605 C write (iout,*) 'termexp',termexp,termm,termpre,i
6606 C NOW the derivatives!!!
6607 C 6/6/97 Take into account the deformation.
6608 E_theta=(delthec*sigcsq*term1
6609 & +ak*delthe0*sig0inv*term2)/termexp
6610 E_tc=((sigtc+aktc*sig0i)/termpre
6611 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6612 & aktc*term2)/termexp)
6615 c-----------------------------------------------------------------------------
6616 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6617 implicit real*8 (a-h,o-z)
6618 include 'DIMENSIONS'
6619 include 'COMMON.LOCAL'
6620 include 'COMMON.IOUNITS'
6621 common /calcthet/ term1,term2,termm,diffak,ratak,
6622 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6623 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6624 delthec=thetai-thet_pred_mean
6625 delthe0=thetai-theta0i
6626 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6627 t3 = thetai-thet_pred_mean
6631 t14 = t12+t6*sigsqtc
6633 t21 = thetai-theta0i
6639 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6640 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6641 & *(-t12*t9-ak*sig0inv*t27)
6645 C--------------------------------------------------------------------------
6646 subroutine ebend(etheta)
6648 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6649 C angles gamma and its derivatives in consecutive thetas and gammas.
6650 C ab initio-derived potentials from
6651 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6653 implicit real*8 (a-h,o-z)
6654 include 'DIMENSIONS'
6655 include 'COMMON.LOCAL'
6656 include 'COMMON.GEO'
6657 include 'COMMON.INTERACT'
6658 include 'COMMON.DERIV'
6659 include 'COMMON.VAR'
6660 include 'COMMON.CHAIN'
6661 include 'COMMON.IOUNITS'
6662 include 'COMMON.NAMES'
6663 include 'COMMON.FFIELD'
6664 include 'COMMON.CONTROL'
6665 include 'COMMON.TORCNSTR'
6666 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6667 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6668 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6669 & sinph1ph2(maxdouble,maxdouble)
6670 logical lprn /.false./, lprn1 /.false./
6672 do i=ithet_start,ithet_end
6673 c print *,i,itype(i-1),itype(i),itype(i-2)
6674 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6675 & .or.itype(i).eq.ntyp1) cycle
6676 C print *,i,theta(i)
6677 if (iabs(itype(i+1)).eq.20) iblock=2
6678 if (iabs(itype(i+1)).ne.20) iblock=1
6682 theti2=0.5d0*theta(i)
6683 ityp2=ithetyp((itype(i-1)))
6685 coskt(k)=dcos(k*theti2)
6686 sinkt(k)=dsin(k*theti2)
6689 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6692 if (phii.ne.phii) phii=150.0
6696 ityp1=ithetyp((itype(i-2)))
6697 C propagation of chirality for glycine type
6699 cosph1(k)=dcos(k*phii)
6700 sinph1(k)=dsin(k*phii)
6705 ityp1=ithetyp((itype(i-2)))
6710 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6713 if (phii1.ne.phii1) phii1=150.0
6718 ityp3=ithetyp((itype(i)))
6720 cosph2(k)=dcos(k*phii1)
6721 sinph2(k)=dsin(k*phii1)
6725 ityp3=ithetyp((itype(i)))
6731 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6734 ccl=cosph1(l)*cosph2(k-l)
6735 ssl=sinph1(l)*sinph2(k-l)
6736 scl=sinph1(l)*cosph2(k-l)
6737 csl=cosph1(l)*sinph2(k-l)
6738 cosph1ph2(l,k)=ccl-ssl
6739 cosph1ph2(k,l)=ccl+ssl
6740 sinph1ph2(l,k)=scl+csl
6741 sinph1ph2(k,l)=scl-csl
6745 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6746 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6747 write (iout,*) "coskt and sinkt"
6749 write (iout,*) k,coskt(k),sinkt(k)
6753 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6754 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6757 & write (iout,*) "k",k,"
6758 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6759 & " ethetai",ethetai
6762 write (iout,*) "cosph and sinph"
6764 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6766 write (iout,*) "cosph1ph2 and sinph2ph2"
6769 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6770 & sinph1ph2(l,k),sinph1ph2(k,l)
6773 write(iout,*) "ethetai",ethetai
6778 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6779 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6780 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6781 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6782 ethetai=ethetai+sinkt(m)*aux
6783 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6784 dephii=dephii+k*sinkt(m)*(
6785 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6786 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6787 dephii1=dephii1+k*sinkt(m)*(
6788 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6789 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6791 & write (iout,*) "m",m," k",k," bbthet",
6792 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6793 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6794 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6795 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6796 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6799 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6800 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6801 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6802 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6804 & write(iout,*) "ethetai",ethetai
6805 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6809 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6810 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6811 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6812 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6813 ethetai=ethetai+sinkt(m)*aux
6814 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6815 dephii=dephii+l*sinkt(m)*(
6816 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6817 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6818 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6819 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6820 dephii1=dephii1+(k-l)*sinkt(m)*(
6821 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6822 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6823 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6824 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6826 write (iout,*) "m",m," k",k," l",l," ffthet",
6827 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6828 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6829 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6830 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6831 & " ethetai",ethetai
6832 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6833 & cosph1ph2(k,l)*sinkt(m),
6834 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6843 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6844 & i,theta(i)*rad2deg,phii*rad2deg,
6845 & phii1*rad2deg,ethetai
6847 etheta=etheta+ethetai
6848 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6849 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6850 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6857 c-----------------------------------------------------------------------------
6858 subroutine esc(escloc)
6859 C Calculate the local energy of a side chain and its derivatives in the
6860 C corresponding virtual-bond valence angles THETA and the spherical angles
6862 implicit real*8 (a-h,o-z)
6863 include 'DIMENSIONS'
6864 include 'COMMON.GEO'
6865 include 'COMMON.LOCAL'
6866 include 'COMMON.VAR'
6867 include 'COMMON.INTERACT'
6868 include 'COMMON.DERIV'
6869 include 'COMMON.CHAIN'
6870 include 'COMMON.IOUNITS'
6871 include 'COMMON.NAMES'
6872 include 'COMMON.FFIELD'
6873 include 'COMMON.CONTROL'
6874 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6875 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6876 common /sccalc/ time11,time12,time112,theti,it,nlobit
6879 c write (iout,'(a)') 'ESC'
6880 do i=loc_start,loc_end
6882 if (it.eq.ntyp1) cycle
6883 if (it.eq.10) goto 1
6884 nlobit=nlob(iabs(it))
6885 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6886 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6887 theti=theta(i+1)-pipol
6892 if (x(2).gt.pi-delta) then
6896 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6898 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6899 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6901 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6902 & ddersc0(1),dersc(1))
6903 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6904 & ddersc0(3),dersc(3))
6906 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6908 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6909 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6910 & dersc0(2),esclocbi,dersc02)
6911 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6913 call splinthet(x(2),0.5d0*delta,ss,ssd)
6918 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6920 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6921 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6923 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6925 c write (iout,*) escloci
6926 else if (x(2).lt.delta) then
6930 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6932 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6933 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6935 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6936 & ddersc0(1),dersc(1))
6937 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6938 & ddersc0(3),dersc(3))
6940 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6942 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6943 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6944 & dersc0(2),esclocbi,dersc02)
6945 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6950 call splinthet(x(2),0.5d0*delta,ss,ssd)
6952 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6954 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6955 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6957 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6958 c write (iout,*) escloci
6960 call enesc(x,escloci,dersc,ddummy,.false.)
6963 escloc=escloc+escloci
6964 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6965 & 'escloc',i,escloci
6966 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6968 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6970 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6971 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6976 C---------------------------------------------------------------------------
6977 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6978 implicit real*8 (a-h,o-z)
6979 include 'DIMENSIONS'
6980 include 'COMMON.GEO'
6981 include 'COMMON.LOCAL'
6982 include 'COMMON.IOUNITS'
6983 common /sccalc/ time11,time12,time112,theti,it,nlobit
6984 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6985 double precision contr(maxlob,-1:1)
6987 c write (iout,*) 'it=',it,' nlobit=',nlobit
6991 if (mixed) ddersc(j)=0.0d0
6995 C Because of periodicity of the dependence of the SC energy in omega we have
6996 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6997 C To avoid underflows, first compute & store the exponents.
7005 z(k)=x(k)-censc(k,j,it)
7010 Axk=Axk+gaussc(l,k,j,it)*z(l)
7016 expfac=expfac+Ax(k,j,iii)*z(k)
7024 C As in the case of ebend, we want to avoid underflows in exponentiation and
7025 C subsequent NaNs and INFs in energy calculation.
7026 C Find the largest exponent
7030 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7034 cd print *,'it=',it,' emin=',emin
7036 C Compute the contribution to SC energy and derivatives
7041 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7042 if(adexp.ne.adexp) adexp=1.0
7045 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7047 cd print *,'j=',j,' expfac=',expfac
7048 escloc_i=escloc_i+expfac
7050 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7054 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7055 & +gaussc(k,2,j,it))*expfac
7062 dersc(1)=dersc(1)/cos(theti)**2
7063 ddersc(1)=ddersc(1)/cos(theti)**2
7066 escloci=-(dlog(escloc_i)-emin)
7068 dersc(j)=dersc(j)/escloc_i
7072 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7077 C------------------------------------------------------------------------------
7078 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7079 implicit real*8 (a-h,o-z)
7080 include 'DIMENSIONS'
7081 include 'COMMON.GEO'
7082 include 'COMMON.LOCAL'
7083 include 'COMMON.IOUNITS'
7084 common /sccalc/ time11,time12,time112,theti,it,nlobit
7085 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7086 double precision contr(maxlob)
7097 z(k)=x(k)-censc(k,j,it)
7103 Axk=Axk+gaussc(l,k,j,it)*z(l)
7109 expfac=expfac+Ax(k,j)*z(k)
7114 C As in the case of ebend, we want to avoid underflows in exponentiation and
7115 C subsequent NaNs and INFs in energy calculation.
7116 C Find the largest exponent
7119 if (emin.gt.contr(j)) emin=contr(j)
7123 C Compute the contribution to SC energy and derivatives
7127 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7128 escloc_i=escloc_i+expfac
7130 dersc(k)=dersc(k)+Ax(k,j)*expfac
7132 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7133 & +gaussc(1,2,j,it))*expfac
7137 dersc(1)=dersc(1)/cos(theti)**2
7138 dersc12=dersc12/cos(theti)**2
7139 escloci=-(dlog(escloc_i)-emin)
7141 dersc(j)=dersc(j)/escloc_i
7143 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7147 c----------------------------------------------------------------------------------
7148 subroutine esc(escloc)
7149 C Calculate the local energy of a side chain and its derivatives in the
7150 C corresponding virtual-bond valence angles THETA and the spherical angles
7151 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7152 C added by Urszula Kozlowska. 07/11/2007
7154 implicit real*8 (a-h,o-z)
7155 include 'DIMENSIONS'
7156 include 'COMMON.GEO'
7157 include 'COMMON.LOCAL'
7158 include 'COMMON.VAR'
7159 include 'COMMON.SCROT'
7160 include 'COMMON.INTERACT'
7161 include 'COMMON.DERIV'
7162 include 'COMMON.CHAIN'
7163 include 'COMMON.IOUNITS'
7164 include 'COMMON.NAMES'
7165 include 'COMMON.FFIELD'
7166 include 'COMMON.CONTROL'
7167 include 'COMMON.VECTORS'
7168 double precision x_prime(3),y_prime(3),z_prime(3)
7169 & , sumene,dsc_i,dp2_i,x(65),
7170 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7171 & de_dxx,de_dyy,de_dzz,de_dt
7172 double precision s1_t,s1_6_t,s2_t,s2_6_t
7174 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7175 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7176 & dt_dCi(3),dt_dCi1(3)
7177 common /sccalc/ time11,time12,time112,theti,it,nlobit
7180 do i=loc_start,loc_end
7181 if (itype(i).eq.ntyp1) cycle
7182 costtab(i+1) =dcos(theta(i+1))
7183 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7184 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7185 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7186 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7187 cosfac=dsqrt(cosfac2)
7188 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7189 sinfac=dsqrt(sinfac2)
7191 if (it.eq.10) goto 1
7193 C Compute the axes of tghe local cartesian coordinates system; store in
7194 c x_prime, y_prime and z_prime
7201 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7202 C & dc_norm(3,i+nres)
7204 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7205 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7208 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7211 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7212 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7213 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7214 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7215 c & " xy",scalar(x_prime(1),y_prime(1)),
7216 c & " xz",scalar(x_prime(1),z_prime(1)),
7217 c & " yy",scalar(y_prime(1),y_prime(1)),
7218 c & " yz",scalar(y_prime(1),z_prime(1)),
7219 c & " zz",scalar(z_prime(1),z_prime(1))
7221 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7222 C to local coordinate system. Store in xx, yy, zz.
7228 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7229 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7230 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7237 C Compute the energy of the ith side cbain
7239 c write (2,*) "xx",xx," yy",yy," zz",zz
7242 x(j) = sc_parmin(j,it)
7245 Cc diagnostics - remove later
7247 yy1 = dsin(alph(2))*dcos(omeg(2))
7248 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7249 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7250 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7252 C," --- ", xx_w,yy_w,zz_w
7255 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7256 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7258 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7259 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7261 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7262 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7263 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7264 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7265 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7267 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7268 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7269 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7270 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7271 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7273 dsc_i = 0.743d0+x(61)
7275 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7276 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7277 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7278 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7279 s1=(1+x(63))/(0.1d0 + dscp1)
7280 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7281 s2=(1+x(65))/(0.1d0 + dscp2)
7282 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7283 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7284 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7285 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7287 c & dscp1,dscp2,sumene
7288 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7289 escloc = escloc + sumene
7290 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7291 & " escloc",sumene,escloc,it,itype(i)
7296 C This section to check the numerical derivatives of the energy of ith side
7297 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7298 C #define DEBUG in the code to turn it on.
7300 write (2,*) "sumene =",sumene
7304 write (2,*) xx,yy,zz
7305 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7306 de_dxx_num=(sumenep-sumene)/aincr
7308 write (2,*) "xx+ sumene from enesc=",sumenep
7311 write (2,*) xx,yy,zz
7312 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7313 de_dyy_num=(sumenep-sumene)/aincr
7315 write (2,*) "yy+ sumene from enesc=",sumenep
7318 write (2,*) xx,yy,zz
7319 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7320 de_dzz_num=(sumenep-sumene)/aincr
7322 write (2,*) "zz+ sumene from enesc=",sumenep
7323 costsave=cost2tab(i+1)
7324 sintsave=sint2tab(i+1)
7325 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7326 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7327 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7328 de_dt_num=(sumenep-sumene)/aincr
7329 write (2,*) " t+ sumene from enesc=",sumenep
7330 cost2tab(i+1)=costsave
7331 sint2tab(i+1)=sintsave
7332 C End of diagnostics section.
7335 C Compute the gradient of esc
7337 c zz=zz*dsign(1.0,dfloat(itype(i)))
7338 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7339 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7340 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7341 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7342 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7343 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7344 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7345 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7346 pom1=(sumene3*sint2tab(i+1)+sumene1)
7347 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7348 pom2=(sumene4*cost2tab(i+1)+sumene2)
7349 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7350 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7351 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7352 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7354 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7355 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7356 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7358 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7359 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7360 & +(pom1+pom2)*pom_dx
7362 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7365 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7366 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7367 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7369 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7370 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7371 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7372 & +x(59)*zz**2 +x(60)*xx*zz
7373 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7374 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7375 & +(pom1-pom2)*pom_dy
7377 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7380 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7381 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7382 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7383 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7384 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7385 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7386 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7387 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7389 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7392 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7393 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7394 & +pom1*pom_dt1+pom2*pom_dt2
7396 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7401 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7402 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7403 cosfac2xx=cosfac2*xx
7404 sinfac2yy=sinfac2*yy
7406 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7408 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7410 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7411 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7412 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7413 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7414 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7415 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7416 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7417 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7418 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7419 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7423 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7424 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7425 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7426 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7429 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7430 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7431 dZZ_XYZ(k)=vbld_inv(i+nres)*
7432 & (z_prime(k)-zz*dC_norm(k,i+nres))
7434 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7435 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7439 dXX_Ctab(k,i)=dXX_Ci(k)
7440 dXX_C1tab(k,i)=dXX_Ci1(k)
7441 dYY_Ctab(k,i)=dYY_Ci(k)
7442 dYY_C1tab(k,i)=dYY_Ci1(k)
7443 dZZ_Ctab(k,i)=dZZ_Ci(k)
7444 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7445 dXX_XYZtab(k,i)=dXX_XYZ(k)
7446 dYY_XYZtab(k,i)=dYY_XYZ(k)
7447 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7451 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7452 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7453 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7454 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7455 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7457 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7458 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7459 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7460 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7461 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7462 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7463 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7464 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7466 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7467 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7469 C to check gradient call subroutine check_grad
7475 c------------------------------------------------------------------------------
7476 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7478 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7479 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7480 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7481 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7483 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7484 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7486 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7487 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7488 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7489 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7490 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7492 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7493 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7494 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7495 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7496 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7498 dsc_i = 0.743d0+x(61)
7500 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7501 & *(xx*cost2+yy*sint2))
7502 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7503 & *(xx*cost2-yy*sint2))
7504 s1=(1+x(63))/(0.1d0 + dscp1)
7505 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7506 s2=(1+x(65))/(0.1d0 + dscp2)
7507 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7508 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7509 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7514 c------------------------------------------------------------------------------
7515 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7517 C This procedure calculates two-body contact function g(rij) and its derivative:
7520 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7523 C where x=(rij-r0ij)/delta
7525 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7528 double precision rij,r0ij,eps0ij,fcont,fprimcont
7529 double precision x,x2,x4,delta
7533 if (x.lt.-1.0D0) then
7536 else if (x.le.1.0D0) then
7539 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7540 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7547 c------------------------------------------------------------------------------
7548 subroutine splinthet(theti,delta,ss,ssder)
7549 implicit real*8 (a-h,o-z)
7550 include 'DIMENSIONS'
7551 include 'COMMON.VAR'
7552 include 'COMMON.GEO'
7555 if (theti.gt.pipol) then
7556 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7558 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7563 c------------------------------------------------------------------------------
7564 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7566 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7567 double precision ksi,ksi2,ksi3,a1,a2,a3
7568 a1=fprim0*delta/(f1-f0)
7574 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7575 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7578 c------------------------------------------------------------------------------
7579 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7581 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7582 double precision ksi,ksi2,ksi3,a1,a2,a3
7587 a2=3*(f1x-f0x)-2*fprim0x*delta
7588 a3=fprim0x*delta-2*(f1x-f0x)
7589 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7592 C-----------------------------------------------------------------------------
7594 C-----------------------------------------------------------------------------
7595 subroutine etor(etors)
7596 implicit real*8 (a-h,o-z)
7597 include 'DIMENSIONS'
7598 include 'COMMON.VAR'
7599 include 'COMMON.GEO'
7600 include 'COMMON.LOCAL'
7601 include 'COMMON.TORSION'
7602 include 'COMMON.INTERACT'
7603 include 'COMMON.DERIV'
7604 include 'COMMON.CHAIN'
7605 include 'COMMON.NAMES'
7606 include 'COMMON.IOUNITS'
7607 include 'COMMON.FFIELD'
7608 include 'COMMON.TORCNSTR'
7609 include 'COMMON.CONTROL'
7611 C Set lprn=.true. for debugging
7615 do i=iphi_start,iphi_end
7617 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7618 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7619 itori=itortyp(itype(i-2))
7620 itori1=itortyp(itype(i-1))
7623 C Proline-Proline pair is a special case...
7624 if (itori.eq.3 .and. itori1.eq.3) then
7625 if (phii.gt.-dwapi3) then
7627 fac=1.0D0/(1.0D0-cosphi)
7628 etorsi=v1(1,3,3)*fac
7629 etorsi=etorsi+etorsi
7630 etors=etors+etorsi-v1(1,3,3)
7631 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7632 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7635 v1ij=v1(j+1,itori,itori1)
7636 v2ij=v2(j+1,itori,itori1)
7639 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7640 if (energy_dec) etors_ii=etors_ii+
7641 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7642 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7646 v1ij=v1(j,itori,itori1)
7647 v2ij=v2(j,itori,itori1)
7650 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7651 if (energy_dec) etors_ii=etors_ii+
7652 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7653 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7656 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7659 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7660 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7661 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7662 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7663 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7667 c------------------------------------------------------------------------------
7668 subroutine etor_d(etors_d)
7672 c----------------------------------------------------------------------------
7673 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7674 subroutine e_modeller(ehomology_constr)
7675 ehomology_constr=0.0d0
7676 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7679 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7681 c------------------------------------------------------------------------------
7682 subroutine etor_d(etors_d)
7686 c----------------------------------------------------------------------------
7688 subroutine etor(etors)
7689 implicit real*8 (a-h,o-z)
7690 include 'DIMENSIONS'
7691 include 'COMMON.VAR'
7692 include 'COMMON.GEO'
7693 include 'COMMON.LOCAL'
7694 include 'COMMON.TORSION'
7695 include 'COMMON.INTERACT'
7696 include 'COMMON.DERIV'
7697 include 'COMMON.CHAIN'
7698 include 'COMMON.NAMES'
7699 include 'COMMON.IOUNITS'
7700 include 'COMMON.FFIELD'
7701 include 'COMMON.TORCNSTR'
7702 include 'COMMON.CONTROL'
7704 C Set lprn=.true. for debugging
7708 do i=iphi_start,iphi_end
7709 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7710 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7711 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7712 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7713 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7714 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7715 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7716 C For introducing the NH3+ and COO- group please check the etor_d for reference
7719 if (iabs(itype(i)).eq.20) then
7724 itori=itortyp(itype(i-2))
7725 itori1=itortyp(itype(i-1))
7728 C Regular cosine and sine terms
7729 do j=1,nterm(itori,itori1,iblock)
7730 v1ij=v1(j,itori,itori1,iblock)
7731 v2ij=v2(j,itori,itori1,iblock)
7734 etors=etors+v1ij*cosphi+v2ij*sinphi
7735 if (energy_dec) etors_ii=etors_ii+
7736 & v1ij*cosphi+v2ij*sinphi
7737 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7741 C E = SUM ----------------------------------- - v1
7742 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7744 cosphi=dcos(0.5d0*phii)
7745 sinphi=dsin(0.5d0*phii)
7746 do j=1,nlor(itori,itori1,iblock)
7747 vl1ij=vlor1(j,itori,itori1)
7748 vl2ij=vlor2(j,itori,itori1)
7749 vl3ij=vlor3(j,itori,itori1)
7750 pom=vl2ij*cosphi+vl3ij*sinphi
7751 pom1=1.0d0/(pom*pom+1.0d0)
7752 etors=etors+vl1ij*pom1
7753 if (energy_dec) etors_ii=etors_ii+
7756 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7758 C Subtract the constant term
7759 etors=etors-v0(itori,itori1,iblock)
7760 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7761 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7763 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7764 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7765 & (v1(j,itori,itori1,iblock),j=1,6),
7766 & (v2(j,itori,itori1,iblock),j=1,6)
7767 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7768 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7772 c----------------------------------------------------------------------------
7773 subroutine etor_d(etors_d)
7774 C 6/23/01 Compute double torsional energy
7775 implicit real*8 (a-h,o-z)
7776 include 'DIMENSIONS'
7777 include 'COMMON.VAR'
7778 include 'COMMON.GEO'
7779 include 'COMMON.LOCAL'
7780 include 'COMMON.TORSION'
7781 include 'COMMON.INTERACT'
7782 include 'COMMON.DERIV'
7783 include 'COMMON.CHAIN'
7784 include 'COMMON.NAMES'
7785 include 'COMMON.IOUNITS'
7786 include 'COMMON.FFIELD'
7787 include 'COMMON.TORCNSTR'
7789 C Set lprn=.true. for debugging
7793 c write(iout,*) "a tu??"
7794 do i=iphid_start,iphid_end
7795 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7796 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7797 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7798 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7799 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7800 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7801 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7802 & (itype(i+1).eq.ntyp1)) cycle
7803 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7804 itori=itortyp(itype(i-2))
7805 itori1=itortyp(itype(i-1))
7806 itori2=itortyp(itype(i))
7812 if (iabs(itype(i+1)).eq.20) iblock=2
7813 C Iblock=2 Proline type
7814 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7815 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7816 C if (itype(i+1).eq.ntyp1) iblock=3
7817 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7818 C IS or IS NOT need for this
7819 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7820 C is (itype(i-3).eq.ntyp1) ntblock=2
7821 C ntblock is N-terminal blocking group
7823 C Regular cosine and sine terms
7824 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7825 C Example of changes for NH3+ blocking group
7826 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7827 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7828 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7829 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7830 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7831 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7832 cosphi1=dcos(j*phii)
7833 sinphi1=dsin(j*phii)
7834 cosphi2=dcos(j*phii1)
7835 sinphi2=dsin(j*phii1)
7836 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7837 & v2cij*cosphi2+v2sij*sinphi2
7838 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7839 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7841 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7843 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7844 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7845 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7846 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7847 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7848 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7849 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7850 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7851 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7852 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7853 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7854 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7855 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7856 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7859 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7860 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7865 C----------------------------------------------------------------------------------
7866 C The rigorous attempt to derive energy function
7867 subroutine etor_kcc(etors)
7868 implicit real*8 (a-h,o-z)
7869 include 'DIMENSIONS'
7870 include 'COMMON.VAR'
7871 include 'COMMON.GEO'
7872 include 'COMMON.LOCAL'
7873 include 'COMMON.TORSION'
7874 include 'COMMON.INTERACT'
7875 include 'COMMON.DERIV'
7876 include 'COMMON.CHAIN'
7877 include 'COMMON.NAMES'
7878 include 'COMMON.IOUNITS'
7879 include 'COMMON.FFIELD'
7880 include 'COMMON.TORCNSTR'
7881 include 'COMMON.CONTROL'
7882 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7884 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7885 C Set lprn=.true. for debugging
7888 C print *,"wchodze kcc"
7889 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7891 do i=iphi_start,iphi_end
7892 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7893 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7894 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7895 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7896 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7897 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7898 itori=itortyp(itype(i-2))
7899 itori1=itortyp(itype(i-1))
7904 C to avoid multiple devision by 2
7905 c theti22=0.5d0*theta(i)
7906 C theta 12 is the theta_1 /2
7907 C theta 22 is theta_2 /2
7908 c theti12=0.5d0*theta(i-1)
7909 C and appropriate sinus function
7910 sinthet1=dsin(theta(i-1))
7911 sinthet2=dsin(theta(i))
7912 costhet1=dcos(theta(i-1))
7913 costhet2=dcos(theta(i))
7914 C to speed up lets store its mutliplication
7915 sint1t2=sinthet2*sinthet1
7917 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7918 C +d_n*sin(n*gamma)) *
7919 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7920 C we have two sum 1) Non-Chebyshev which is with n and gamma
7921 nval=nterm_kcc_Tb(itori,itori1)
7927 c1(j)=c1(j-1)*costhet1
7928 c2(j)=c2(j-1)*costhet2
7931 do j=1,nterm_kcc(itori,itori1)
7935 sint1t2n=sint1t2n*sint1t2
7941 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7942 gradvalct1=gradvalct1+
7943 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7944 gradvalct2=gradvalct2+
7945 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7948 gradvalct1=-gradvalct1*sinthet1
7949 gradvalct2=-gradvalct2*sinthet2
7955 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7956 gradvalst1=gradvalst1+
7957 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7958 gradvalst2=gradvalst2+
7959 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7962 gradvalst1=-gradvalst1*sinthet1
7963 gradvalst2=-gradvalst2*sinthet2
7964 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7965 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7966 C glocig is the gradient local i site in gamma
7967 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7968 C now gradient over theta_1
7969 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7970 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7971 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7972 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7975 C derivative over gamma
7976 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7977 C derivative over theta1
7978 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7979 C now derivative over theta2
7980 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7982 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7983 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7984 write (iout,*) "c1",(c1(k),k=0,nval),
7985 & " c2",(c2(k),k=0,nval)
7990 c---------------------------------------------------------------------------------------------
7991 subroutine etor_constr(edihcnstr)
7992 implicit real*8 (a-h,o-z)
7993 include 'DIMENSIONS'
7994 include 'COMMON.VAR'
7995 include 'COMMON.GEO'
7996 include 'COMMON.LOCAL'
7997 include 'COMMON.TORSION'
7998 include 'COMMON.INTERACT'
7999 include 'COMMON.DERIV'
8000 include 'COMMON.CHAIN'
8001 include 'COMMON.NAMES'
8002 include 'COMMON.IOUNITS'
8003 include 'COMMON.FFIELD'
8004 include 'COMMON.TORCNSTR'
8005 include 'COMMON.BOUNDS'
8006 include 'COMMON.CONTROL'
8007 ! 6/20/98 - dihedral angle constraints
8009 c do i=1,ndih_constr
8010 if (raw_psipred) then
8011 do i=idihconstr_start,idihconstr_end
8012 itori=idih_constr(i)
8014 gaudih_i=vpsipred(1,i)
8018 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
8019 dexpcos_i=dexp(-cos_i*cos_i)
8020 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
8021 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
8022 & *cos_i*dexpcos_i/s**2
8024 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
8025 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
8027 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
8028 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
8029 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
8030 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
8031 & -wdihc*dlog(gaudih_i)
8035 do i=idihconstr_start,idihconstr_end
8036 itori=idih_constr(i)
8038 difi=pinorm(phii-phi0(i))
8039 if (difi.gt.drange(i)) then
8041 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8042 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8043 else if (difi.lt.-drange(i)) then
8045 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8046 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8056 c----------------------------------------------------------------------------
8057 c MODELLER restraint function
8058 subroutine e_modeller(ehomology_constr)
8060 include 'DIMENSIONS'
8062 double precision ehomology_constr
8063 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8064 integer katy, odleglosci, test7
8065 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8067 real*8 distance(max_template),distancek(max_template),
8068 & min_odl,godl(max_template),dih_diff(max_template)
8071 c FP - 30/10/2014 Temporary specifications for homology restraints
8073 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8075 double precision, dimension (maxres) :: guscdiff,usc_diff
8076 double precision, dimension (max_template) ::
8077 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8079 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8080 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8081 & betai,sum_sgodl,dij
8082 double precision dist,pinorm
8084 include 'COMMON.SBRIDGE'
8085 include 'COMMON.CHAIN'
8086 include 'COMMON.GEO'
8087 include 'COMMON.DERIV'
8088 include 'COMMON.LOCAL'
8089 include 'COMMON.INTERACT'
8090 include 'COMMON.VAR'
8091 include 'COMMON.IOUNITS'
8092 c include 'COMMON.MD'
8093 include 'COMMON.CONTROL'
8094 include 'COMMON.HOMOLOGY'
8095 include 'COMMON.QRESTR'
8097 c From subroutine Econstr_back
8099 include 'COMMON.NAMES'
8100 include 'COMMON.TIME1'
8105 distancek(i)=9999999.9
8111 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8113 C AL 5/2/14 - Introduce list of restraints
8114 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8116 write(iout,*) "------- dist restrs start -------"
8118 do ii = link_start_homo,link_end_homo
8122 c write (iout,*) "dij(",i,j,") =",dij
8124 do k=1,constr_homology
8125 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8126 if(.not.l_homo(k,ii)) then
8130 distance(k)=odl(k,ii)-dij
8131 c write (iout,*) "distance(",k,") =",distance(k)
8133 c For Gaussian-type Urestr
8135 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8136 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8137 c write (iout,*) "distancek(",k,") =",distancek(k)
8138 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8140 c For Lorentzian-type Urestr
8142 if (waga_dist.lt.0.0d0) then
8143 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8144 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8145 & (distance(k)**2+sigma_odlir(k,ii)**2))
8149 c min_odl=minval(distancek)
8150 do kk=1,constr_homology
8151 if(l_homo(kk,ii)) then
8152 min_odl=distancek(kk)
8156 do kk=1,constr_homology
8157 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8158 & min_odl=distancek(kk)
8161 c write (iout,* )"min_odl",min_odl
8163 write (iout,*) "ij dij",i,j,dij
8164 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8165 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8166 write (iout,* )"min_odl",min_odl
8171 if (waga_dist.ge.0.0d0) then
8177 do k=1,constr_homology
8178 c Nie wiem po co to liczycie jeszcze raz!
8179 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8180 c & (2*(sigma_odl(i,j,k))**2))
8181 if(.not.l_homo(k,ii)) cycle
8182 if (waga_dist.ge.0.0d0) then
8184 c For Gaussian-type Urestr
8186 godl(k)=dexp(-distancek(k)+min_odl)
8187 odleg2=odleg2+godl(k)
8189 c For Lorentzian-type Urestr
8192 odleg2=odleg2+distancek(k)
8195 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8196 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8197 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8198 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8201 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8202 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8204 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8205 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8207 if (waga_dist.ge.0.0d0) then
8209 c For Gaussian-type Urestr
8211 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8213 c For Lorentzian-type Urestr
8216 odleg=odleg+odleg2/constr_homology
8219 c write (iout,*) "odleg",odleg ! sum of -ln-s
8222 c For Gaussian-type Urestr
8224 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8226 do k=1,constr_homology
8227 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8228 c & *waga_dist)+min_odl
8229 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8231 if(.not.l_homo(k,ii)) cycle
8232 if (waga_dist.ge.0.0d0) then
8233 c For Gaussian-type Urestr
8235 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8237 c For Lorentzian-type Urestr
8240 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8241 & sigma_odlir(k,ii)**2)**2)
8243 sum_sgodl=sum_sgodl+sgodl
8245 c sgodl2=sgodl2+sgodl
8246 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8247 c write(iout,*) "constr_homology=",constr_homology
8248 c write(iout,*) i, j, k, "TEST K"
8250 if (waga_dist.ge.0.0d0) then
8252 c For Gaussian-type Urestr
8254 grad_odl3=waga_homology(iset)*waga_dist
8255 & *sum_sgodl/(sum_godl*dij)
8257 c For Lorentzian-type Urestr
8260 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8261 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8262 grad_odl3=-waga_homology(iset)*waga_dist*
8263 & sum_sgodl/(constr_homology*dij)
8266 c grad_odl3=sum_sgodl/(sum_godl*dij)
8269 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8270 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8271 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8273 ccc write(iout,*) godl, sgodl, grad_odl3
8275 c grad_odl=grad_odl+grad_odl3
8278 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8279 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8280 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8281 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8282 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8283 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8284 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8285 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8286 c if (i.eq.25.and.j.eq.27) then
8287 c write(iout,*) "jik",jik,"i",i,"j",j
8288 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8289 c write(iout,*) "grad_odl3",grad_odl3
8290 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8291 c write(iout,*) "ggodl",ggodl
8292 c write(iout,*) "ghpbc(",jik,i,")",
8293 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8297 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8298 ccc & dLOG(odleg2),"-odleg=", -odleg
8300 enddo ! ii-loop for dist
8302 write(iout,*) "------- dist restrs end -------"
8303 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8304 c & waga_d.eq.1.0d0) call sum_gradient
8306 c Pseudo-energy and gradient from dihedral-angle restraints from
8307 c homology templates
8308 c write (iout,*) "End of distance loop"
8311 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8313 write(iout,*) "------- dih restrs start -------"
8314 do i=idihconstr_start_homo,idihconstr_end_homo
8315 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8318 do i=idihconstr_start_homo,idihconstr_end_homo
8320 c betai=beta(i,i+1,i+2,i+3)
8322 c write (iout,*) "betai =",betai
8323 do k=1,constr_homology
8324 dih_diff(k)=pinorm(dih(k,i)-betai)
8325 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8326 cd & ,sigma_dih(k,i)
8327 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8328 c & -(6.28318-dih_diff(i,k))
8329 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8330 c & 6.28318+dih_diff(i,k)
8332 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8334 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8336 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8339 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8342 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8343 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8345 write (iout,*) "i",i," betai",betai," kat2",kat2
8346 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8348 if (kat2.le.1.0d-14) cycle
8349 kat=kat-dLOG(kat2/constr_homology)
8350 c write (iout,*) "kat",kat ! sum of -ln-s
8352 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8353 ccc & dLOG(kat2), "-kat=", -kat
8355 c ----------------------------------------------------------------------
8357 c ----------------------------------------------------------------------
8361 do k=1,constr_homology
8363 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8365 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8367 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8368 sum_sgdih=sum_sgdih+sgdih
8370 c grad_dih3=sum_sgdih/sum_gdih
8371 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8373 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8374 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8375 ccc & gloc(nphi+i-3,icg)
8376 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8378 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8380 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8381 ccc & gloc(nphi+i-3,icg)
8383 enddo ! i-loop for dih
8385 write(iout,*) "------- dih restrs end -------"
8388 c Pseudo-energy and gradient for theta angle restraints from
8389 c homology templates
8390 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8394 c For constr_homology reference structures (FP)
8396 c Uconst_back_tot=0.0d0
8399 c Econstr_back legacy
8401 c do i=ithet_start,ithet_end
8404 c do i=loc_start,loc_end
8407 duscdiffx(j,i)=0.0d0
8412 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8413 c write (iout,*) "waga_theta",waga_theta
8414 if (waga_theta.gt.0.0d0) then
8416 write (iout,*) "usampl",usampl
8417 write(iout,*) "------- theta restrs start -------"
8418 c do i=ithet_start,ithet_end
8419 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8422 c write (iout,*) "maxres",maxres,"nres",nres
8424 do i=ithet_start,ithet_end
8427 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8429 c Deviation of theta angles wrt constr_homology ref structures
8431 utheta_i=0.0d0 ! argument of Gaussian for single k
8432 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8433 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8434 c over residues in a fragment
8435 c write (iout,*) "theta(",i,")=",theta(i)
8436 do k=1,constr_homology
8438 c dtheta_i=theta(j)-thetaref(j,iref)
8439 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8440 theta_diff(k)=thetatpl(k,i)-theta(i)
8441 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8442 cd & ,sigma_theta(k,i)
8445 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8446 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8447 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8448 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8449 c Gradient for single Gaussian restraint in subr Econstr_back
8450 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8453 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8454 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8457 c Gradient for multiple Gaussian restraint
8458 sum_gtheta=gutheta_i
8460 do k=1,constr_homology
8461 c New generalized expr for multiple Gaussian from Econstr_back
8462 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8464 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8465 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8467 c Final value of gradient using same var as in Econstr_back
8468 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8469 & +sum_sgtheta/sum_gtheta*waga_theta
8470 & *waga_homology(iset)
8471 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8472 c & *waga_homology(iset)
8473 c dutheta(i)=sum_sgtheta/sum_gtheta
8475 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8476 Eval=Eval-dLOG(gutheta_i/constr_homology)
8477 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8478 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8479 c Uconst_back=Uconst_back+utheta(i)
8480 enddo ! (i-loop for theta)
8482 write(iout,*) "------- theta restrs end -------"
8486 c Deviation of local SC geometry
8488 c Separation of two i-loops (instructed by AL - 11/3/2014)
8490 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8491 c write (iout,*) "waga_d",waga_d
8494 write(iout,*) "------- SC restrs start -------"
8495 write (iout,*) "Initial duscdiff,duscdiffx"
8496 do i=loc_start,loc_end
8497 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8498 & (duscdiffx(jik,i),jik=1,3)
8501 do i=loc_start,loc_end
8502 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8503 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8504 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8505 c write(iout,*) "xxtab, yytab, zztab"
8506 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8507 do k=1,constr_homology
8509 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8510 c Original sign inverted for calc of gradients (s. Econstr_back)
8511 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8512 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8513 c write(iout,*) "dxx, dyy, dzz"
8514 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8516 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8517 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8518 c uscdiffk(k)=usc_diff(i)
8519 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8520 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8521 c & " guscdiff2",guscdiff2(k)
8522 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8523 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8524 c & xxref(j),yyref(j),zzref(j)
8529 c Generalized expression for multiple Gaussian acc to that for a single
8530 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8532 c Original implementation
8533 c sum_guscdiff=guscdiff(i)
8535 c sum_sguscdiff=0.0d0
8536 c do k=1,constr_homology
8537 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8538 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8539 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8542 c Implementation of new expressions for gradient (Jan. 2015)
8544 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8545 do k=1,constr_homology
8547 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8548 c before. Now the drivatives should be correct
8550 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8551 c Original sign inverted for calc of gradients (s. Econstr_back)
8552 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8553 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8555 c New implementation
8557 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8558 & sigma_d(k,i) ! for the grad wrt r'
8559 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8562 c New implementation
8563 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8565 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8566 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8567 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8568 duscdiff(jik,i)=duscdiff(jik,i)+
8569 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8570 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8571 duscdiffx(jik,i)=duscdiffx(jik,i)+
8572 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8573 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8576 write(iout,*) "jik",jik,"i",i
8577 write(iout,*) "dxx, dyy, dzz"
8578 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8579 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8580 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8581 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8582 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8583 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8584 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8585 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8586 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8587 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8588 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8589 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8590 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8591 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8592 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8598 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8599 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8601 c write (iout,*) i," uscdiff",uscdiff(i)
8603 c Put together deviations from local geometry
8605 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8606 c & wfrag_back(3,i,iset)*uscdiff(i)
8607 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8608 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8609 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8610 c Uconst_back=Uconst_back+usc_diff(i)
8612 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8614 c New implment: multiplied by sum_sguscdiff
8617 enddo ! (i-loop for dscdiff)
8622 write(iout,*) "------- SC restrs end -------"
8623 write (iout,*) "------ After SC loop in e_modeller ------"
8624 do i=loc_start,loc_end
8625 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8626 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8628 if (waga_theta.eq.1.0d0) then
8629 write (iout,*) "in e_modeller after SC restr end: dutheta"
8630 do i=ithet_start,ithet_end
8631 write (iout,*) i,dutheta(i)
8634 if (waga_d.eq.1.0d0) then
8635 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8637 write (iout,*) i,(duscdiff(j,i),j=1,3)
8638 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8643 c Total energy from homology restraints
8645 write (iout,*) "odleg",odleg," kat",kat
8648 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8650 c ehomology_constr=odleg+kat
8652 c For Lorentzian-type Urestr
8655 if (waga_dist.ge.0.0d0) then
8657 c For Gaussian-type Urestr
8659 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8660 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8661 c write (iout,*) "ehomology_constr=",ehomology_constr
8664 c For Lorentzian-type Urestr
8666 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8667 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8668 c write (iout,*) "ehomology_constr=",ehomology_constr
8671 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8672 & "Eval",waga_theta,eval,
8673 & "Erot",waga_d,Erot
8674 write (iout,*) "ehomology_constr",ehomology_constr
8680 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8681 747 format(a12,i4,i4,i4,f8.3,f8.3)
8682 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8683 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8684 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8685 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8687 c----------------------------------------------------------------------------
8688 C The rigorous attempt to derive energy function
8689 subroutine ebend_kcc(etheta)
8691 implicit real*8 (a-h,o-z)
8692 include 'DIMENSIONS'
8693 include 'COMMON.VAR'
8694 include 'COMMON.GEO'
8695 include 'COMMON.LOCAL'
8696 include 'COMMON.TORSION'
8697 include 'COMMON.INTERACT'
8698 include 'COMMON.DERIV'
8699 include 'COMMON.CHAIN'
8700 include 'COMMON.NAMES'
8701 include 'COMMON.IOUNITS'
8702 include 'COMMON.FFIELD'
8703 include 'COMMON.TORCNSTR'
8704 include 'COMMON.CONTROL'
8706 double precision thybt1(maxang_kcc)
8707 C Set lprn=.true. for debugging
8710 C print *,"wchodze kcc"
8711 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8713 do i=ithet_start,ithet_end
8714 c print *,i,itype(i-1),itype(i),itype(i-2)
8715 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8716 & .or.itype(i).eq.ntyp1) cycle
8717 iti=iabs(itortyp(itype(i-1)))
8718 sinthet=dsin(theta(i))
8719 costhet=dcos(theta(i))
8720 do j=1,nbend_kcc_Tb(iti)
8721 thybt1(j)=v1bend_chyb(j,iti)
8723 sumth1thyb=v1bend_chyb(0,iti)+
8724 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8725 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8727 ihelp=nbend_kcc_Tb(iti)-1
8728 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8729 etheta=etheta+sumth1thyb
8730 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8731 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8735 c-------------------------------------------------------------------------------------
8736 subroutine etheta_constr(ethetacnstr)
8738 implicit real*8 (a-h,o-z)
8739 include 'DIMENSIONS'
8740 include 'COMMON.VAR'
8741 include 'COMMON.GEO'
8742 include 'COMMON.LOCAL'
8743 include 'COMMON.TORSION'
8744 include 'COMMON.INTERACT'
8745 include 'COMMON.DERIV'
8746 include 'COMMON.CHAIN'
8747 include 'COMMON.NAMES'
8748 include 'COMMON.IOUNITS'
8749 include 'COMMON.FFIELD'
8750 include 'COMMON.TORCNSTR'
8751 include 'COMMON.CONTROL'
8753 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8754 do i=ithetaconstr_start,ithetaconstr_end
8755 itheta=itheta_constr(i)
8756 thetiii=theta(itheta)
8757 difi=pinorm(thetiii-theta_constr0(i))
8758 if (difi.gt.theta_drange(i)) then
8759 difi=difi-theta_drange(i)
8760 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8761 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8762 & +for_thet_constr(i)*difi**3
8763 else if (difi.lt.-drange(i)) then
8765 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8766 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8767 & +for_thet_constr(i)*difi**3
8771 if (energy_dec) then
8772 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8773 & i,itheta,rad2deg*thetiii,
8774 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8775 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8776 & gloc(itheta+nphi-2,icg)
8781 c------------------------------------------------------------------------------
8782 subroutine eback_sc_corr(esccor)
8783 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8784 c conformational states; temporarily implemented as differences
8785 c between UNRES torsional potentials (dependent on three types of
8786 c residues) and the torsional potentials dependent on all 20 types
8787 c of residues computed from AM1 energy surfaces of terminally-blocked
8788 c amino-acid residues.
8789 implicit real*8 (a-h,o-z)
8790 include 'DIMENSIONS'
8791 include 'COMMON.VAR'
8792 include 'COMMON.GEO'
8793 include 'COMMON.LOCAL'
8794 include 'COMMON.TORSION'
8795 include 'COMMON.SCCOR'
8796 include 'COMMON.INTERACT'
8797 include 'COMMON.DERIV'
8798 include 'COMMON.CHAIN'
8799 include 'COMMON.NAMES'
8800 include 'COMMON.IOUNITS'
8801 include 'COMMON.FFIELD'
8802 include 'COMMON.CONTROL'
8804 C Set lprn=.true. for debugging
8807 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8809 do i=itau_start,itau_end
8810 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8812 isccori=isccortyp(itype(i-2))
8813 isccori1=isccortyp(itype(i-1))
8814 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8816 do intertyp=1,3 !intertyp
8817 cc Added 09 May 2012 (Adasko)
8818 cc Intertyp means interaction type of backbone mainchain correlation:
8819 c 1 = SC...Ca...Ca...Ca
8820 c 2 = Ca...Ca...Ca...SC
8821 c 3 = SC...Ca...Ca...SCi
8823 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8824 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8825 & (itype(i-1).eq.ntyp1)))
8826 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8827 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8828 & .or.(itype(i).eq.ntyp1)))
8829 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8830 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8831 & (itype(i-3).eq.ntyp1)))) cycle
8832 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8833 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8835 do j=1,nterm_sccor(isccori,isccori1)
8836 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8837 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8838 cosphi=dcos(j*tauangle(intertyp,i))
8839 sinphi=dsin(j*tauangle(intertyp,i))
8840 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8841 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8843 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8844 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8846 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8847 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8848 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8849 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8850 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8857 c----------------------------------------------------------------------------
8858 subroutine multibody(ecorr)
8859 C This subroutine calculates multi-body contributions to energy following
8860 C the idea of Skolnick et al. If side chains I and J make a contact and
8861 C at the same time side chains I+1 and J+1 make a contact, an extra
8862 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8863 implicit real*8 (a-h,o-z)
8864 include 'DIMENSIONS'
8865 include 'COMMON.IOUNITS'
8866 include 'COMMON.DERIV'
8867 include 'COMMON.INTERACT'
8868 include 'COMMON.CONTACTS'
8869 include 'COMMON.CONTMAT'
8870 include 'COMMON.CORRMAT'
8871 double precision gx(3),gx1(3)
8874 C Set lprn=.true. for debugging
8878 write (iout,'(a)') 'Contact function values:'
8880 write (iout,'(i2,20(1x,i2,f10.5))')
8881 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8896 num_conti=num_cont(i)
8897 num_conti1=num_cont(i1)
8902 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8903 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8904 cd & ' ishift=',ishift
8905 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8906 C The system gains extra energy.
8907 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8908 endif ! j1==j+-ishift
8917 c------------------------------------------------------------------------------
8918 double precision function esccorr(i,j,k,l,jj,kk)
8919 implicit real*8 (a-h,o-z)
8920 include 'DIMENSIONS'
8921 include 'COMMON.IOUNITS'
8922 include 'COMMON.DERIV'
8923 include 'COMMON.INTERACT'
8924 include 'COMMON.CONTACTS'
8925 include 'COMMON.CONTMAT'
8926 include 'COMMON.CORRMAT'
8927 include 'COMMON.SHIELD'
8928 double precision gx(3),gx1(3)
8933 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8934 C Calculate the multi-body contribution to energy.
8935 C Calculate multi-body contributions to the gradient.
8936 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8937 cd & k,l,(gacont(m,kk,k),m=1,3)
8939 gx(m) =ekl*gacont(m,jj,i)
8940 gx1(m)=eij*gacont(m,kk,k)
8941 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8942 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8943 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8944 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8948 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8953 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8959 c------------------------------------------------------------------------------
8960 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8961 C This subroutine calculates multi-body contributions to hydrogen-bonding
8962 implicit real*8 (a-h,o-z)
8963 include 'DIMENSIONS'
8964 include 'COMMON.IOUNITS'
8967 parameter (max_cont=maxconts)
8968 parameter (max_dim=26)
8969 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8970 double precision zapas(max_dim,maxconts,max_fg_procs),
8971 & zapas_recv(max_dim,maxconts,max_fg_procs)
8972 common /przechowalnia/ zapas
8973 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8974 & status_array(MPI_STATUS_SIZE,maxconts*2)
8976 include 'COMMON.SETUP'
8977 include 'COMMON.FFIELD'
8978 include 'COMMON.DERIV'
8979 include 'COMMON.INTERACT'
8980 include 'COMMON.CONTACTS'
8981 include 'COMMON.CONTMAT'
8982 include 'COMMON.CORRMAT'
8983 include 'COMMON.CONTROL'
8984 include 'COMMON.LOCAL'
8985 double precision gx(3),gx1(3),time00
8988 C Set lprn=.true. for debugging
8993 if (nfgtasks.le.1) goto 30
8995 write (iout,'(a)') 'Contact function values before RECEIVE:'
8997 write (iout,'(2i3,50(1x,i2,f5.2))')
8998 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8999 & j=1,num_cont_hb(i))
9003 do i=1,ntask_cont_from
9006 do i=1,ntask_cont_to
9009 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9011 C Make the list of contacts to send to send to other procesors
9012 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
9014 do i=iturn3_start,iturn3_end
9015 c write (iout,*) "make contact list turn3",i," num_cont",
9017 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
9019 do i=iturn4_start,iturn4_end
9020 c write (iout,*) "make contact list turn4",i," num_cont",
9022 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
9026 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9028 do j=1,num_cont_hb(i)
9031 iproc=iint_sent_local(k,jjc,ii)
9032 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9033 if (iproc.gt.0) then
9034 ncont_sent(iproc)=ncont_sent(iproc)+1
9035 nn=ncont_sent(iproc)
9037 zapas(2,nn,iproc)=jjc
9038 zapas(3,nn,iproc)=facont_hb(j,i)
9039 zapas(4,nn,iproc)=ees0p(j,i)
9040 zapas(5,nn,iproc)=ees0m(j,i)
9041 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
9042 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
9043 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
9044 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
9045 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
9046 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
9047 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
9048 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
9049 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
9050 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
9051 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
9052 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
9053 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
9054 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
9055 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
9056 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
9057 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
9058 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
9059 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
9060 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
9061 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9068 & "Numbers of contacts to be sent to other processors",
9069 & (ncont_sent(i),i=1,ntask_cont_to)
9070 write (iout,*) "Contacts sent"
9071 do ii=1,ntask_cont_to
9073 iproc=itask_cont_to(ii)
9074 write (iout,*) nn," contacts to processor",iproc,
9075 & " of CONT_TO_COMM group"
9077 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9085 CorrelID1=nfgtasks+fg_rank+1
9087 C Receive the numbers of needed contacts from other processors
9088 do ii=1,ntask_cont_from
9089 iproc=itask_cont_from(ii)
9091 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9092 & FG_COMM,req(ireq),IERR)
9094 c write (iout,*) "IRECV ended"
9096 C Send the number of contacts needed by other processors
9097 do ii=1,ntask_cont_to
9098 iproc=itask_cont_to(ii)
9100 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9101 & FG_COMM,req(ireq),IERR)
9103 c write (iout,*) "ISEND ended"
9104 c write (iout,*) "number of requests (nn)",ireq
9107 & call MPI_Waitall(ireq,req,status_array,ierr)
9109 c & "Numbers of contacts to be received from other processors",
9110 c & (ncont_recv(i),i=1,ntask_cont_from)
9114 do ii=1,ntask_cont_from
9115 iproc=itask_cont_from(ii)
9117 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9118 c & " of CONT_TO_COMM group"
9122 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9123 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9124 c write (iout,*) "ireq,req",ireq,req(ireq)
9127 C Send the contacts to processors that need them
9128 do ii=1,ntask_cont_to
9129 iproc=itask_cont_to(ii)
9131 c write (iout,*) nn," contacts to processor",iproc,
9132 c & " of CONT_TO_COMM group"
9135 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9136 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9137 c write (iout,*) "ireq,req",ireq,req(ireq)
9139 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9143 c write (iout,*) "number of requests (contacts)",ireq
9144 c write (iout,*) "req",(req(i),i=1,4)
9147 & call MPI_Waitall(ireq,req,status_array,ierr)
9148 do iii=1,ntask_cont_from
9149 iproc=itask_cont_from(iii)
9152 write (iout,*) "Received",nn," contacts from processor",iproc,
9153 & " of CONT_FROM_COMM group"
9156 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9161 ii=zapas_recv(1,i,iii)
9162 c Flag the received contacts to prevent double-counting
9163 jj=-zapas_recv(2,i,iii)
9164 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9166 nnn=num_cont_hb(ii)+1
9169 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9170 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9171 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9172 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9173 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9174 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9175 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9176 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9177 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9178 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9179 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9180 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9181 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9182 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9183 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9184 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9185 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9186 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9187 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9188 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9189 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9190 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9191 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9192 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9196 write (iout,'(a)') 'Contact function values after receive:'
9198 write (iout,'(2i3,50(1x,i3,f5.2))')
9199 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9200 & j=1,num_cont_hb(i))
9207 write (iout,'(a)') 'Contact function values:'
9209 write (iout,'(2i3,50(1x,i3,f5.2))')
9210 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9211 & j=1,num_cont_hb(i))
9216 C Remove the loop below after debugging !!!
9223 C Calculate the local-electrostatic correlation terms
9224 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9226 num_conti=num_cont_hb(i)
9227 num_conti1=num_cont_hb(i+1)
9234 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9235 c & ' jj=',jj,' kk=',kk
9237 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9238 & .or. j.lt.0 .and. j1.gt.0) .and.
9239 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9240 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9241 C The system gains extra energy.
9242 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9243 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9244 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9246 else if (j1.eq.j) then
9247 C Contacts I-J and I-(J+1) occur simultaneously.
9248 C The system loses extra energy.
9249 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9254 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9255 c & ' jj=',jj,' kk=',kk
9257 C Contacts I-J and (I+1)-J occur simultaneously.
9258 C The system loses extra energy.
9259 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9266 c------------------------------------------------------------------------------
9267 subroutine add_hb_contact(ii,jj,itask)
9268 implicit real*8 (a-h,o-z)
9269 include "DIMENSIONS"
9270 include "COMMON.IOUNITS"
9273 parameter (max_cont=maxconts)
9274 parameter (max_dim=26)
9275 include "COMMON.CONTACTS"
9276 include 'COMMON.CONTMAT'
9277 include 'COMMON.CORRMAT'
9278 double precision zapas(max_dim,maxconts,max_fg_procs),
9279 & zapas_recv(max_dim,maxconts,max_fg_procs)
9280 common /przechowalnia/ zapas
9281 integer i,j,ii,jj,iproc,itask(4),nn
9282 c write (iout,*) "itask",itask
9285 if (iproc.gt.0) then
9286 do j=1,num_cont_hb(ii)
9288 c write (iout,*) "i",ii," j",jj," jjc",jjc
9290 ncont_sent(iproc)=ncont_sent(iproc)+1
9291 nn=ncont_sent(iproc)
9292 zapas(1,nn,iproc)=ii
9293 zapas(2,nn,iproc)=jjc
9294 zapas(3,nn,iproc)=facont_hb(j,ii)
9295 zapas(4,nn,iproc)=ees0p(j,ii)
9296 zapas(5,nn,iproc)=ees0m(j,ii)
9297 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9298 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9299 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9300 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9301 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9302 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9303 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9304 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9305 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9306 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9307 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9308 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9309 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9310 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9311 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9312 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9313 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9314 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9315 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9316 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9317 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9325 c------------------------------------------------------------------------------
9326 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9328 C This subroutine calculates multi-body contributions to hydrogen-bonding
9329 implicit real*8 (a-h,o-z)
9330 include 'DIMENSIONS'
9331 include 'COMMON.IOUNITS'
9334 parameter (max_cont=maxconts)
9335 parameter (max_dim=70)
9336 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9337 double precision zapas(max_dim,maxconts,max_fg_procs),
9338 & zapas_recv(max_dim,maxconts,max_fg_procs)
9339 common /przechowalnia/ zapas
9340 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9341 & status_array(MPI_STATUS_SIZE,maxconts*2)
9343 include 'COMMON.SETUP'
9344 include 'COMMON.FFIELD'
9345 include 'COMMON.DERIV'
9346 include 'COMMON.LOCAL'
9347 include 'COMMON.INTERACT'
9348 include 'COMMON.CONTACTS'
9349 include 'COMMON.CONTMAT'
9350 include 'COMMON.CORRMAT'
9351 include 'COMMON.CHAIN'
9352 include 'COMMON.CONTROL'
9353 include 'COMMON.SHIELD'
9354 double precision gx(3),gx1(3)
9355 integer num_cont_hb_old(maxres)
9357 double precision eello4,eello5,eelo6,eello_turn6
9358 external eello4,eello5,eello6,eello_turn6
9359 C Set lprn=.true. for debugging
9364 num_cont_hb_old(i)=num_cont_hb(i)
9368 if (nfgtasks.le.1) goto 30
9370 write (iout,'(a)') 'Contact function values before RECEIVE:'
9372 write (iout,'(2i3,50(1x,i2,f5.2))')
9373 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9374 & j=1,num_cont_hb(i))
9377 do i=1,ntask_cont_from
9380 do i=1,ntask_cont_to
9383 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9385 C Make the list of contacts to send to send to other procesors
9386 do i=iturn3_start,iturn3_end
9387 c write (iout,*) "make contact list turn3",i," num_cont",
9389 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9391 do i=iturn4_start,iturn4_end
9392 c write (iout,*) "make contact list turn4",i," num_cont",
9394 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9398 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9400 do j=1,num_cont_hb(i)
9403 iproc=iint_sent_local(k,jjc,ii)
9404 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9405 if (iproc.ne.0) then
9406 ncont_sent(iproc)=ncont_sent(iproc)+1
9407 nn=ncont_sent(iproc)
9409 zapas(2,nn,iproc)=jjc
9410 zapas(3,nn,iproc)=d_cont(j,i)
9414 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9419 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9427 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9438 & "Numbers of contacts to be sent to other processors",
9439 & (ncont_sent(i),i=1,ntask_cont_to)
9440 write (iout,*) "Contacts sent"
9441 do ii=1,ntask_cont_to
9443 iproc=itask_cont_to(ii)
9444 write (iout,*) nn," contacts to processor",iproc,
9445 & " of CONT_TO_COMM group"
9447 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9455 CorrelID1=nfgtasks+fg_rank+1
9457 C Receive the numbers of needed contacts from other processors
9458 do ii=1,ntask_cont_from
9459 iproc=itask_cont_from(ii)
9461 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9462 & FG_COMM,req(ireq),IERR)
9464 c write (iout,*) "IRECV ended"
9466 C Send the number of contacts needed by other processors
9467 do ii=1,ntask_cont_to
9468 iproc=itask_cont_to(ii)
9470 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9471 & FG_COMM,req(ireq),IERR)
9473 c write (iout,*) "ISEND ended"
9474 c write (iout,*) "number of requests (nn)",ireq
9477 & call MPI_Waitall(ireq,req,status_array,ierr)
9479 c & "Numbers of contacts to be received from other processors",
9480 c & (ncont_recv(i),i=1,ntask_cont_from)
9484 do ii=1,ntask_cont_from
9485 iproc=itask_cont_from(ii)
9487 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9488 c & " of CONT_TO_COMM group"
9492 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9493 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9494 c write (iout,*) "ireq,req",ireq,req(ireq)
9497 C Send the contacts to processors that need them
9498 do ii=1,ntask_cont_to
9499 iproc=itask_cont_to(ii)
9501 c write (iout,*) nn," contacts to processor",iproc,
9502 c & " of CONT_TO_COMM group"
9505 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9506 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9507 c write (iout,*) "ireq,req",ireq,req(ireq)
9509 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9513 c write (iout,*) "number of requests (contacts)",ireq
9514 c write (iout,*) "req",(req(i),i=1,4)
9517 & call MPI_Waitall(ireq,req,status_array,ierr)
9518 do iii=1,ntask_cont_from
9519 iproc=itask_cont_from(iii)
9522 write (iout,*) "Received",nn," contacts from processor",iproc,
9523 & " of CONT_FROM_COMM group"
9526 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9531 ii=zapas_recv(1,i,iii)
9532 c Flag the received contacts to prevent double-counting
9533 jj=-zapas_recv(2,i,iii)
9534 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9536 nnn=num_cont_hb(ii)+1
9539 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9543 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9548 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9556 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9564 write (iout,'(a)') 'Contact function values after receive:'
9566 write (iout,'(2i3,50(1x,i3,5f6.3))')
9567 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9568 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9575 write (iout,'(a)') 'Contact function values:'
9577 write (iout,'(2i3,50(1x,i2,5f6.3))')
9578 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9579 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9585 C Remove the loop below after debugging !!!
9592 C Calculate the dipole-dipole interaction energies
9593 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9594 do i=iatel_s,iatel_e+1
9595 num_conti=num_cont_hb(i)
9604 C Calculate the local-electrostatic correlation terms
9605 c write (iout,*) "gradcorr5 in eello5 before loop"
9607 c write (iout,'(i5,3f10.5)')
9608 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9610 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9611 c write (iout,*) "corr loop i",i
9613 num_conti=num_cont_hb(i)
9614 num_conti1=num_cont_hb(i+1)
9621 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9622 c & ' jj=',jj,' kk=',kk
9623 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9624 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9625 & .or. j.lt.0 .and. j1.gt.0) .and.
9626 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9627 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9628 C The system gains extra energy.
9630 sqd1=dsqrt(d_cont(jj,i))
9631 sqd2=dsqrt(d_cont(kk,i1))
9632 sred_geom = sqd1*sqd2
9633 IF (sred_geom.lt.cutoff_corr) THEN
9634 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9636 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9637 cd & ' jj=',jj,' kk=',kk
9638 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9639 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9641 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9642 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9645 cd write (iout,*) 'sred_geom=',sred_geom,
9646 cd & ' ekont=',ekont,' fprim=',fprimcont,
9647 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9648 cd write (iout,*) "g_contij",g_contij
9649 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9650 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9651 call calc_eello(i,jp,i+1,jp1,jj,kk)
9652 if (wcorr4.gt.0.0d0)
9653 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9654 CC & *fac_shield(i)**2*fac_shield(j)**2
9655 if (energy_dec.and.wcorr4.gt.0.0d0)
9656 1 write (iout,'(a6,4i5,0pf7.3)')
9657 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9658 c write (iout,*) "gradcorr5 before eello5"
9660 c write (iout,'(i5,3f10.5)')
9661 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9663 if (wcorr5.gt.0.0d0)
9664 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9665 c write (iout,*) "gradcorr5 after eello5"
9667 c write (iout,'(i5,3f10.5)')
9668 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9670 if (energy_dec.and.wcorr5.gt.0.0d0)
9671 1 write (iout,'(a6,4i5,0pf7.3)')
9672 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9673 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9674 cd write(2,*)'ijkl',i,jp,i+1,jp1
9675 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9676 & .or. wturn6.eq.0.0d0))then
9677 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9678 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9679 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9680 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9681 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9682 cd & 'ecorr6=',ecorr6
9683 cd write (iout,'(4e15.5)') sred_geom,
9684 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9685 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9686 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9687 else if (wturn6.gt.0.0d0
9688 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9689 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9690 eturn6=eturn6+eello_turn6(i,jj,kk)
9691 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9692 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9693 cd write (2,*) 'multibody_eello:eturn6',eturn6
9702 num_cont_hb(i)=num_cont_hb_old(i)
9704 c write (iout,*) "gradcorr5 in eello5"
9706 c write (iout,'(i5,3f10.5)')
9707 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9711 c------------------------------------------------------------------------------
9712 subroutine add_hb_contact_eello(ii,jj,itask)
9713 implicit real*8 (a-h,o-z)
9714 include "DIMENSIONS"
9715 include "COMMON.IOUNITS"
9718 parameter (max_cont=maxconts)
9719 parameter (max_dim=70)
9720 include "COMMON.CONTACTS"
9721 include 'COMMON.CONTMAT'
9722 include 'COMMON.CORRMAT'
9723 double precision zapas(max_dim,maxconts,max_fg_procs),
9724 & zapas_recv(max_dim,maxconts,max_fg_procs)
9725 common /przechowalnia/ zapas
9726 integer i,j,ii,jj,iproc,itask(4),nn
9727 c write (iout,*) "itask",itask
9730 if (iproc.gt.0) then
9731 do j=1,num_cont_hb(ii)
9733 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9735 ncont_sent(iproc)=ncont_sent(iproc)+1
9736 nn=ncont_sent(iproc)
9737 zapas(1,nn,iproc)=ii
9738 zapas(2,nn,iproc)=jjc
9739 zapas(3,nn,iproc)=d_cont(j,ii)
9743 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9748 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9756 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9768 c------------------------------------------------------------------------------
9769 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9770 implicit real*8 (a-h,o-z)
9771 include 'DIMENSIONS'
9772 include 'COMMON.IOUNITS'
9773 include 'COMMON.DERIV'
9774 include 'COMMON.INTERACT'
9775 include 'COMMON.CONTACTS'
9776 include 'COMMON.CONTMAT'
9777 include 'COMMON.CORRMAT'
9778 include 'COMMON.SHIELD'
9779 include 'COMMON.CONTROL'
9780 double precision gx(3),gx1(3)
9783 C print *,"wchodze",fac_shield(i),shield_mode
9791 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9793 C & fac_shield(i)**2*fac_shield(j)**2
9794 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9795 C Following 4 lines for diagnostics.
9800 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9801 c & 'Contacts ',i,j,
9802 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9803 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9805 C Calculate the multi-body contribution to energy.
9806 C ecorr=ecorr+ekont*ees
9807 C Calculate multi-body contributions to the gradient.
9808 coeffpees0pij=coeffp*ees0pij
9809 coeffmees0mij=coeffm*ees0mij
9810 coeffpees0pkl=coeffp*ees0pkl
9811 coeffmees0mkl=coeffm*ees0mkl
9813 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9814 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9815 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9816 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9817 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9818 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9819 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9820 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9821 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9822 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9823 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9824 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9825 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9826 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9827 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9828 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9829 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9830 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9831 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9832 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9833 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9834 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9835 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9836 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9837 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9842 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9843 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9844 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9845 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9850 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9851 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9852 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9853 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9856 c write (iout,*) "ehbcorr",ekont*ees
9857 C print *,ekont,ees,i,k
9859 C now gradient over shielding
9861 if (shield_mode.gt.0) then
9864 C print *,i,j,fac_shield(i),fac_shield(j),
9865 C &fac_shield(k),fac_shield(l)
9866 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9867 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9868 do ilist=1,ishield_list(i)
9869 iresshield=shield_list(ilist,i)
9871 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9873 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9875 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9876 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9880 do ilist=1,ishield_list(j)
9881 iresshield=shield_list(ilist,j)
9883 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9885 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9887 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9888 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9893 do ilist=1,ishield_list(k)
9894 iresshield=shield_list(ilist,k)
9896 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9898 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9900 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9901 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9905 do ilist=1,ishield_list(l)
9906 iresshield=shield_list(ilist,l)
9908 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9910 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9912 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9913 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9917 C print *,gshieldx(m,iresshield)
9919 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9920 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9921 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9922 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9923 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9924 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9925 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9926 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9928 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9929 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9930 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9931 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9932 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9933 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9934 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9935 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9943 C---------------------------------------------------------------------------
9944 subroutine dipole(i,j,jj)
9945 implicit real*8 (a-h,o-z)
9946 include 'DIMENSIONS'
9947 include 'COMMON.IOUNITS'
9948 include 'COMMON.CHAIN'
9949 include 'COMMON.FFIELD'
9950 include 'COMMON.DERIV'
9951 include 'COMMON.INTERACT'
9952 include 'COMMON.CONTACTS'
9953 include 'COMMON.CONTMAT'
9954 include 'COMMON.CORRMAT'
9955 include 'COMMON.TORSION'
9956 include 'COMMON.VAR'
9957 include 'COMMON.GEO'
9958 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9960 iti1 = itortyp(itype(i+1))
9961 if (j.lt.nres-1) then
9962 itj1 = itype2loc(itype(j+1))
9967 dipi(iii,1)=Ub2(iii,i)
9968 dipderi(iii)=Ub2der(iii,i)
9969 dipi(iii,2)=b1(iii,i+1)
9970 dipj(iii,1)=Ub2(iii,j)
9971 dipderj(iii)=Ub2der(iii,j)
9972 dipj(iii,2)=b1(iii,j+1)
9976 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9979 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9986 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9990 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9995 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9996 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9998 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
10000 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
10002 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
10007 C---------------------------------------------------------------------------
10008 subroutine calc_eello(i,j,k,l,jj,kk)
10010 C This subroutine computes matrices and vectors needed to calculate
10011 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
10013 implicit real*8 (a-h,o-z)
10014 include 'DIMENSIONS'
10015 include 'COMMON.IOUNITS'
10016 include 'COMMON.CHAIN'
10017 include 'COMMON.DERIV'
10018 include 'COMMON.INTERACT'
10019 include 'COMMON.CONTACTS'
10020 include 'COMMON.CONTMAT'
10021 include 'COMMON.CORRMAT'
10022 include 'COMMON.TORSION'
10023 include 'COMMON.VAR'
10024 include 'COMMON.GEO'
10025 include 'COMMON.FFIELD'
10026 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
10027 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
10029 common /kutas/ lprn
10030 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
10031 cd & ' jj=',jj,' kk=',kk
10032 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
10033 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
10034 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
10037 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
10038 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
10041 call transpose2(aa1(1,1),aa1t(1,1))
10042 call transpose2(aa2(1,1),aa2t(1,1))
10045 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
10046 & aa1tder(1,1,lll,kkk))
10047 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
10048 & aa2tder(1,1,lll,kkk))
10052 C parallel orientation of the two CA-CA-CA frames.
10054 iti=itype2loc(itype(i))
10058 itk1=itype2loc(itype(k+1))
10059 itj=itype2loc(itype(j))
10060 if (l.lt.nres-1) then
10061 itl1=itype2loc(itype(l+1))
10065 C A1 kernel(j+1) A2T
10067 cd write (iout,'(3f10.5,5x,3f10.5)')
10068 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10070 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10071 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10072 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10073 C Following matrices are needed only for 6-th order cumulants
10074 IF (wcorr6.gt.0.0d0) THEN
10075 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10076 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10077 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10078 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10079 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10080 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10081 & ADtEAderx(1,1,1,1,1,1))
10083 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10084 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10085 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10086 & ADtEA1derx(1,1,1,1,1,1))
10088 C End 6-th order cumulants
10091 cd write (2,*) 'In calc_eello6'
10093 cd write (2,*) 'iii=',iii
10095 cd write (2,*) 'kkk=',kkk
10097 cd write (2,'(3(2f10.5),5x)')
10098 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10103 call transpose2(EUgder(1,1,k),auxmat(1,1))
10104 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10105 call transpose2(EUg(1,1,k),auxmat(1,1))
10106 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10107 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10108 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10109 c in theta; to be sriten later.
10111 c call transpose2(gtEE(1,1,k),auxmat(1,1))
10112 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10113 c call transpose2(EUg(1,1,k),auxmat(1,1))
10114 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10119 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10120 & EAEAderx(1,1,lll,kkk,iii,1))
10124 C A1T kernel(i+1) A2
10125 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10126 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10127 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10128 C Following matrices are needed only for 6-th order cumulants
10129 IF (wcorr6.gt.0.0d0) THEN
10130 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10131 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10132 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10133 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10134 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10135 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10136 & ADtEAderx(1,1,1,1,1,2))
10137 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10138 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10139 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10140 & ADtEA1derx(1,1,1,1,1,2))
10142 C End 6-th order cumulants
10143 call transpose2(EUgder(1,1,l),auxmat(1,1))
10144 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10145 call transpose2(EUg(1,1,l),auxmat(1,1))
10146 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10147 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10151 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10152 & EAEAderx(1,1,lll,kkk,iii,2))
10157 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10158 C They are needed only when the fifth- or the sixth-order cumulants are
10160 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10161 call transpose2(AEA(1,1,1),auxmat(1,1))
10162 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10163 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10164 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10165 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10166 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10167 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10168 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10169 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10170 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10171 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10172 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10173 call transpose2(AEA(1,1,2),auxmat(1,1))
10174 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10175 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10176 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10177 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10178 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10179 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10180 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10181 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10182 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10183 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10184 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10185 C Calculate the Cartesian derivatives of the vectors.
10189 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10190 call matvec2(auxmat(1,1),b1(1,i),
10191 & AEAb1derx(1,lll,kkk,iii,1,1))
10192 call matvec2(auxmat(1,1),Ub2(1,i),
10193 & AEAb2derx(1,lll,kkk,iii,1,1))
10194 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10195 & AEAb1derx(1,lll,kkk,iii,2,1))
10196 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10197 & AEAb2derx(1,lll,kkk,iii,2,1))
10198 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10199 call matvec2(auxmat(1,1),b1(1,j),
10200 & AEAb1derx(1,lll,kkk,iii,1,2))
10201 call matvec2(auxmat(1,1),Ub2(1,j),
10202 & AEAb2derx(1,lll,kkk,iii,1,2))
10203 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10204 & AEAb1derx(1,lll,kkk,iii,2,2))
10205 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10206 & AEAb2derx(1,lll,kkk,iii,2,2))
10213 C Antiparallel orientation of the two CA-CA-CA frames.
10215 iti=itype2loc(itype(i))
10219 itk1=itype2loc(itype(k+1))
10220 itl=itype2loc(itype(l))
10221 itj=itype2loc(itype(j))
10222 if (j.lt.nres-1) then
10223 itj1=itype2loc(itype(j+1))
10227 C A2 kernel(j-1)T A1T
10228 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10229 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10230 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10231 C Following matrices are needed only for 6-th order cumulants
10232 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10233 & j.eq.i+4 .and. l.eq.i+3)) THEN
10234 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10235 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10236 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10237 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10238 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10239 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10240 & ADtEAderx(1,1,1,1,1,1))
10241 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10242 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10243 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10244 & ADtEA1derx(1,1,1,1,1,1))
10246 C End 6-th order cumulants
10247 call transpose2(EUgder(1,1,k),auxmat(1,1))
10248 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10249 call transpose2(EUg(1,1,k),auxmat(1,1))
10250 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10251 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10255 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10256 & EAEAderx(1,1,lll,kkk,iii,1))
10260 C A2T kernel(i+1)T A1
10261 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10262 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10263 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10264 C Following matrices are needed only for 6-th order cumulants
10265 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10266 & j.eq.i+4 .and. l.eq.i+3)) THEN
10267 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10268 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10269 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10270 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10271 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10272 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10273 & ADtEAderx(1,1,1,1,1,2))
10274 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10275 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10276 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10277 & ADtEA1derx(1,1,1,1,1,2))
10279 C End 6-th order cumulants
10280 call transpose2(EUgder(1,1,j),auxmat(1,1))
10281 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10282 call transpose2(EUg(1,1,j),auxmat(1,1))
10283 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10284 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10288 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10289 & EAEAderx(1,1,lll,kkk,iii,2))
10294 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10295 C They are needed only when the fifth- or the sixth-order cumulants are
10297 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10298 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10299 call transpose2(AEA(1,1,1),auxmat(1,1))
10300 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10301 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10302 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10303 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10304 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10305 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10306 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10307 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10308 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10309 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10310 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10311 call transpose2(AEA(1,1,2),auxmat(1,1))
10312 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10313 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10314 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10315 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10316 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10317 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10318 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10319 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10320 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10321 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10322 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10323 C Calculate the Cartesian derivatives of the vectors.
10327 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10328 call matvec2(auxmat(1,1),b1(1,i),
10329 & AEAb1derx(1,lll,kkk,iii,1,1))
10330 call matvec2(auxmat(1,1),Ub2(1,i),
10331 & AEAb2derx(1,lll,kkk,iii,1,1))
10332 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10333 & AEAb1derx(1,lll,kkk,iii,2,1))
10334 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10335 & AEAb2derx(1,lll,kkk,iii,2,1))
10336 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10337 call matvec2(auxmat(1,1),b1(1,l),
10338 & AEAb1derx(1,lll,kkk,iii,1,2))
10339 call matvec2(auxmat(1,1),Ub2(1,l),
10340 & AEAb2derx(1,lll,kkk,iii,1,2))
10341 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10342 & AEAb1derx(1,lll,kkk,iii,2,2))
10343 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10344 & AEAb2derx(1,lll,kkk,iii,2,2))
10353 C---------------------------------------------------------------------------
10354 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10355 & KK,KKderg,AKA,AKAderg,AKAderx)
10359 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10360 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10361 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10362 integer iii,kkk,lll
10365 common /kutas/ lprn
10366 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10368 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10369 & AKAderg(1,1,iii))
10371 cd if (lprn) write (2,*) 'In kernel'
10373 cd if (lprn) write (2,*) 'kkk=',kkk
10375 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10376 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10378 cd write (2,*) 'lll=',lll
10379 cd write (2,*) 'iii=1'
10381 cd write (2,'(3(2f10.5),5x)')
10382 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10385 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10386 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10388 cd write (2,*) 'lll=',lll
10389 cd write (2,*) 'iii=2'
10391 cd write (2,'(3(2f10.5),5x)')
10392 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10399 C---------------------------------------------------------------------------
10400 double precision function eello4(i,j,k,l,jj,kk)
10401 implicit real*8 (a-h,o-z)
10402 include 'DIMENSIONS'
10403 include 'COMMON.IOUNITS'
10404 include 'COMMON.CHAIN'
10405 include 'COMMON.DERIV'
10406 include 'COMMON.INTERACT'
10407 include 'COMMON.CONTACTS'
10408 include 'COMMON.CONTMAT'
10409 include 'COMMON.CORRMAT'
10410 include 'COMMON.TORSION'
10411 include 'COMMON.VAR'
10412 include 'COMMON.GEO'
10413 double precision pizda(2,2),ggg1(3),ggg2(3)
10414 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10418 cd print *,'eello4:',i,j,k,l,jj,kk
10419 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10420 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10421 cold eij=facont_hb(jj,i)
10422 cold ekl=facont_hb(kk,k)
10424 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10425 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10426 gcorr_loc(k-1)=gcorr_loc(k-1)
10427 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10429 gcorr_loc(l-1)=gcorr_loc(l-1)
10430 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10431 C Al 4/16/16: Derivatives in theta, to be added later.
10433 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10434 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10437 gcorr_loc(j-1)=gcorr_loc(j-1)
10438 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10440 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10441 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10447 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10448 & -EAEAderx(2,2,lll,kkk,iii,1)
10449 cd derx(lll,kkk,iii)=0.0d0
10453 cd gcorr_loc(l-1)=0.0d0
10454 cd gcorr_loc(j-1)=0.0d0
10455 cd gcorr_loc(k-1)=0.0d0
10457 cd write (iout,*)'Contacts have occurred for peptide groups',
10458 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10459 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10460 if (j.lt.nres-1) then
10467 if (l.lt.nres-1) then
10475 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10476 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10477 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10478 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10479 cgrad ghalf=0.5d0*ggg1(ll)
10480 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10481 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10482 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10483 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10484 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10485 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10486 cgrad ghalf=0.5d0*ggg2(ll)
10487 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10488 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10489 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10490 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10491 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10492 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10496 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10501 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10506 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10511 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10515 cd write (2,*) iii,gcorr_loc(iii)
10518 cd write (2,*) 'ekont',ekont
10519 cd write (iout,*) 'eello4',ekont*eel4
10522 C---------------------------------------------------------------------------
10523 double precision function eello5(i,j,k,l,jj,kk)
10524 implicit real*8 (a-h,o-z)
10525 include 'DIMENSIONS'
10526 include 'COMMON.IOUNITS'
10527 include 'COMMON.CHAIN'
10528 include 'COMMON.DERIV'
10529 include 'COMMON.INTERACT'
10530 include 'COMMON.CONTACTS'
10531 include 'COMMON.CONTMAT'
10532 include 'COMMON.CORRMAT'
10533 include 'COMMON.TORSION'
10534 include 'COMMON.VAR'
10535 include 'COMMON.GEO'
10536 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10537 double precision ggg1(3),ggg2(3)
10538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10540 C Parallel chains C
10543 C /l\ / \ \ / \ / \ / C
10544 C / \ / \ \ / \ / \ / C
10545 C j| o |l1 | o | o| o | | o |o C
10546 C \ |/k\| |/ \| / |/ \| |/ \| C
10547 C \i/ \ / \ / / \ / \ C
10549 C (I) (II) (III) (IV) C
10551 C eello5_1 eello5_2 eello5_3 eello5_4 C
10553 C Antiparallel chains C
10556 C /j\ / \ \ / \ / \ / C
10557 C / \ / \ \ / \ / \ / C
10558 C j1| o |l | o | o| o | | o |o C
10559 C \ |/k\| |/ \| / |/ \| |/ \| C
10560 C \i/ \ / \ / / \ / \ C
10562 C (I) (II) (III) (IV) C
10564 C eello5_1 eello5_2 eello5_3 eello5_4 C
10566 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10568 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10569 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10574 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10576 itk=itype2loc(itype(k))
10577 itl=itype2loc(itype(l))
10578 itj=itype2loc(itype(j))
10583 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10584 cd & eel5_3_num,eel5_4_num)
10588 derx(lll,kkk,iii)=0.0d0
10592 cd eij=facont_hb(jj,i)
10593 cd ekl=facont_hb(kk,k)
10595 cd write (iout,*)'Contacts have occurred for peptide groups',
10596 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10598 C Contribution from the graph I.
10599 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10600 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10601 call transpose2(EUg(1,1,k),auxmat(1,1))
10602 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10603 vv(1)=pizda(1,1)-pizda(2,2)
10604 vv(2)=pizda(1,2)+pizda(2,1)
10605 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10606 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10607 C Explicit gradient in virtual-dihedral angles.
10608 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10609 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10610 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10611 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10612 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10613 vv(1)=pizda(1,1)-pizda(2,2)
10614 vv(2)=pizda(1,2)+pizda(2,1)
10615 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10616 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10617 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10618 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10619 vv(1)=pizda(1,1)-pizda(2,2)
10620 vv(2)=pizda(1,2)+pizda(2,1)
10622 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10624 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10626 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10627 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10628 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10630 C Cartesian gradient
10634 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10636 vv(1)=pizda(1,1)-pizda(2,2)
10637 vv(2)=pizda(1,2)+pizda(2,1)
10638 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10639 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10640 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10646 C Contribution from graph II
10647 call transpose2(EE(1,1,k),auxmat(1,1))
10648 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10649 vv(1)=pizda(1,1)+pizda(2,2)
10650 vv(2)=pizda(2,1)-pizda(1,2)
10651 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10652 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10653 C Explicit gradient in virtual-dihedral angles.
10654 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10655 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10656 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10657 vv(1)=pizda(1,1)+pizda(2,2)
10658 vv(2)=pizda(2,1)-pizda(1,2)
10660 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10661 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10662 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10664 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10665 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10666 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10668 C Cartesian gradient
10672 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10674 vv(1)=pizda(1,1)+pizda(2,2)
10675 vv(2)=pizda(2,1)-pizda(1,2)
10676 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10677 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10678 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10686 C Parallel orientation
10687 C Contribution from graph III
10688 call transpose2(EUg(1,1,l),auxmat(1,1))
10689 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10690 vv(1)=pizda(1,1)-pizda(2,2)
10691 vv(2)=pizda(1,2)+pizda(2,1)
10692 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10693 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10694 C Explicit gradient in virtual-dihedral angles.
10695 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10696 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10697 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10698 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10699 vv(1)=pizda(1,1)-pizda(2,2)
10700 vv(2)=pizda(1,2)+pizda(2,1)
10701 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10702 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10703 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10704 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10705 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10706 vv(1)=pizda(1,1)-pizda(2,2)
10707 vv(2)=pizda(1,2)+pizda(2,1)
10708 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10709 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10710 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10711 C Cartesian gradient
10715 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10717 vv(1)=pizda(1,1)-pizda(2,2)
10718 vv(2)=pizda(1,2)+pizda(2,1)
10719 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10720 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10721 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10726 C Contribution from graph IV
10728 call transpose2(EE(1,1,l),auxmat(1,1))
10729 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10730 vv(1)=pizda(1,1)+pizda(2,2)
10731 vv(2)=pizda(2,1)-pizda(1,2)
10732 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10733 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10734 C Explicit gradient in virtual-dihedral angles.
10735 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10736 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10737 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10738 vv(1)=pizda(1,1)+pizda(2,2)
10739 vv(2)=pizda(2,1)-pizda(1,2)
10740 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10741 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10742 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10743 C Cartesian gradient
10747 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10749 vv(1)=pizda(1,1)+pizda(2,2)
10750 vv(2)=pizda(2,1)-pizda(1,2)
10751 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10752 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10753 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10758 C Antiparallel orientation
10759 C Contribution from graph III
10761 call transpose2(EUg(1,1,j),auxmat(1,1))
10762 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10763 vv(1)=pizda(1,1)-pizda(2,2)
10764 vv(2)=pizda(1,2)+pizda(2,1)
10765 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10766 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10767 C Explicit gradient in virtual-dihedral angles.
10768 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10769 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10770 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10771 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10772 vv(1)=pizda(1,1)-pizda(2,2)
10773 vv(2)=pizda(1,2)+pizda(2,1)
10774 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10775 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10776 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10777 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10778 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10779 vv(1)=pizda(1,1)-pizda(2,2)
10780 vv(2)=pizda(1,2)+pizda(2,1)
10781 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10782 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10783 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10784 C Cartesian gradient
10788 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10790 vv(1)=pizda(1,1)-pizda(2,2)
10791 vv(2)=pizda(1,2)+pizda(2,1)
10792 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10793 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10794 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10799 C Contribution from graph IV
10801 call transpose2(EE(1,1,j),auxmat(1,1))
10802 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10803 vv(1)=pizda(1,1)+pizda(2,2)
10804 vv(2)=pizda(2,1)-pizda(1,2)
10805 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10806 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10807 C Explicit gradient in virtual-dihedral angles.
10808 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10809 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10810 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10811 vv(1)=pizda(1,1)+pizda(2,2)
10812 vv(2)=pizda(2,1)-pizda(1,2)
10813 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10814 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10815 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10816 C Cartesian gradient
10820 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10822 vv(1)=pizda(1,1)+pizda(2,2)
10823 vv(2)=pizda(2,1)-pizda(1,2)
10824 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10825 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10826 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10832 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10833 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10834 cd write (2,*) 'ijkl',i,j,k,l
10835 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10836 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10838 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10839 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10840 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10841 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10842 if (j.lt.nres-1) then
10849 if (l.lt.nres-1) then
10859 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10860 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10861 C summed up outside the subrouine as for the other subroutines
10862 C handling long-range interactions. The old code is commented out
10863 C with "cgrad" to keep track of changes.
10865 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10866 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10867 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10868 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10869 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10870 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10871 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10872 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10873 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10874 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10876 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10877 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10878 cgrad ghalf=0.5d0*ggg1(ll)
10880 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10881 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10882 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10883 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10884 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10885 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10886 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10887 cgrad ghalf=0.5d0*ggg2(ll)
10889 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10890 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10891 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10892 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10893 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10894 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10899 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10900 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10905 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10906 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10912 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10917 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10921 cd write (2,*) iii,g_corr5_loc(iii)
10924 cd write (2,*) 'ekont',ekont
10925 cd write (iout,*) 'eello5',ekont*eel5
10928 c--------------------------------------------------------------------------
10929 double precision function eello6(i,j,k,l,jj,kk)
10930 implicit real*8 (a-h,o-z)
10931 include 'DIMENSIONS'
10932 include 'COMMON.IOUNITS'
10933 include 'COMMON.CHAIN'
10934 include 'COMMON.DERIV'
10935 include 'COMMON.INTERACT'
10936 include 'COMMON.CONTACTS'
10937 include 'COMMON.CONTMAT'
10938 include 'COMMON.CORRMAT'
10939 include 'COMMON.TORSION'
10940 include 'COMMON.VAR'
10941 include 'COMMON.GEO'
10942 include 'COMMON.FFIELD'
10943 double precision ggg1(3),ggg2(3)
10944 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10949 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10957 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10958 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10962 derx(lll,kkk,iii)=0.0d0
10966 cd eij=facont_hb(jj,i)
10967 cd ekl=facont_hb(kk,k)
10973 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10974 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10975 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10976 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10977 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10978 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10980 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10981 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10982 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10983 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10984 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10985 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10989 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10991 C If turn contributions are considered, they will be handled separately.
10992 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10993 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10994 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10995 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10996 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10997 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10998 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
11000 if (j.lt.nres-1) then
11007 if (l.lt.nres-1) then
11015 cgrad ggg1(ll)=eel6*g_contij(ll,1)
11016 cgrad ggg2(ll)=eel6*g_contij(ll,2)
11017 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
11018 cgrad ghalf=0.5d0*ggg1(ll)
11020 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
11021 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
11022 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
11023 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
11024 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
11025 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
11026 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
11027 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
11028 cgrad ghalf=0.5d0*ggg2(ll)
11029 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
11031 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
11032 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
11033 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
11034 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
11035 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
11036 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
11041 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
11042 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
11047 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
11048 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
11054 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
11059 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
11063 cd write (2,*) iii,g_corr6_loc(iii)
11066 cd write (2,*) 'ekont',ekont
11067 cd write (iout,*) 'eello6',ekont*eel6
11070 c--------------------------------------------------------------------------
11071 double precision function eello6_graph1(i,j,k,l,imat,swap)
11072 implicit real*8 (a-h,o-z)
11073 include 'DIMENSIONS'
11074 include 'COMMON.IOUNITS'
11075 include 'COMMON.CHAIN'
11076 include 'COMMON.DERIV'
11077 include 'COMMON.INTERACT'
11078 include 'COMMON.CONTACTS'
11079 include 'COMMON.CONTMAT'
11080 include 'COMMON.CORRMAT'
11081 include 'COMMON.TORSION'
11082 include 'COMMON.VAR'
11083 include 'COMMON.GEO'
11084 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11087 common /kutas/ lprn
11088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11090 C Parallel Antiparallel C
11096 C \ j|/k\| / \ |/k\|l / C
11097 C \ / \ / \ / \ / C
11101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11102 itk=itype2loc(itype(k))
11103 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11104 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11105 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11106 call transpose2(EUgC(1,1,k),auxmat(1,1))
11107 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11108 vv1(1)=pizda1(1,1)-pizda1(2,2)
11109 vv1(2)=pizda1(1,2)+pizda1(2,1)
11110 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11111 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11112 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11113 s5=scalar2(vv(1),Dtobr2(1,i))
11114 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11115 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11116 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11117 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11118 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11119 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11120 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11121 & +scalar2(vv(1),Dtobr2der(1,i)))
11122 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11123 vv1(1)=pizda1(1,1)-pizda1(2,2)
11124 vv1(2)=pizda1(1,2)+pizda1(2,1)
11125 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11126 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11128 g_corr6_loc(l-1)=g_corr6_loc(l-1)
11129 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11130 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11131 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11132 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11134 g_corr6_loc(j-1)=g_corr6_loc(j-1)
11135 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11136 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11137 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11138 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11140 call transpose2(EUgCder(1,1,k),auxmat(1,1))
11141 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11142 vv1(1)=pizda1(1,1)-pizda1(2,2)
11143 vv1(2)=pizda1(1,2)+pizda1(2,1)
11144 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11145 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11146 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11147 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11156 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11157 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11158 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11159 call transpose2(EUgC(1,1,k),auxmat(1,1))
11160 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11162 vv1(1)=pizda1(1,1)-pizda1(2,2)
11163 vv1(2)=pizda1(1,2)+pizda1(2,1)
11164 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11165 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11166 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11167 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11168 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11169 s5=scalar2(vv(1),Dtobr2(1,i))
11170 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11176 c----------------------------------------------------------------------------
11177 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11178 implicit real*8 (a-h,o-z)
11179 include 'DIMENSIONS'
11180 include 'COMMON.IOUNITS'
11181 include 'COMMON.CHAIN'
11182 include 'COMMON.DERIV'
11183 include 'COMMON.INTERACT'
11184 include 'COMMON.CONTACTS'
11185 include 'COMMON.CONTMAT'
11186 include 'COMMON.CORRMAT'
11187 include 'COMMON.TORSION'
11188 include 'COMMON.VAR'
11189 include 'COMMON.GEO'
11191 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11192 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11194 common /kutas/ lprn
11195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11197 C Parallel Antiparallel C
11203 C \ j|/k\| \ |/k\|l C
11208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11209 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11210 C AL 7/4/01 s1 would occur in the sixth-order moment,
11211 C but not in a cluster cumulant
11213 s1=dip(1,jj,i)*dip(1,kk,k)
11215 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11216 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11217 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11218 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11219 call transpose2(EUg(1,1,k),auxmat(1,1))
11220 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11221 vv(1)=pizda(1,1)-pizda(2,2)
11222 vv(2)=pizda(1,2)+pizda(2,1)
11223 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11224 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11226 eello6_graph2=-(s1+s2+s3+s4)
11228 eello6_graph2=-(s2+s3+s4)
11230 c eello6_graph2=-s3
11231 C Derivatives in gamma(i-1)
11234 s1=dipderg(1,jj,i)*dip(1,kk,k)
11236 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11237 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11238 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11239 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11241 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11243 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11245 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11247 C Derivatives in gamma(k-1)
11249 s1=dip(1,jj,i)*dipderg(1,kk,k)
11251 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11252 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11253 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11254 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11255 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11256 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11257 vv(1)=pizda(1,1)-pizda(2,2)
11258 vv(2)=pizda(1,2)+pizda(2,1)
11259 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11261 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11263 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11265 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11266 C Derivatives in gamma(j-1) or gamma(l-1)
11269 s1=dipderg(3,jj,i)*dip(1,kk,k)
11271 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11272 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11273 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11274 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11275 vv(1)=pizda(1,1)-pizda(2,2)
11276 vv(2)=pizda(1,2)+pizda(2,1)
11277 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11280 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11282 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11285 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11286 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11288 C Derivatives in gamma(l-1) or gamma(j-1)
11291 s1=dip(1,jj,i)*dipderg(3,kk,k)
11293 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11294 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11295 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11296 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11297 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11298 vv(1)=pizda(1,1)-pizda(2,2)
11299 vv(2)=pizda(1,2)+pizda(2,1)
11300 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11303 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11305 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11308 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11309 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11311 C Cartesian derivatives.
11313 write (2,*) 'In eello6_graph2'
11315 write (2,*) 'iii=',iii
11317 write (2,*) 'kkk=',kkk
11319 write (2,'(3(2f10.5),5x)')
11320 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11330 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11332 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11335 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11337 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11338 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11340 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11341 call transpose2(EUg(1,1,k),auxmat(1,1))
11342 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11344 vv(1)=pizda(1,1)-pizda(2,2)
11345 vv(2)=pizda(1,2)+pizda(2,1)
11346 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11347 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11349 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11351 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11354 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11356 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11363 c----------------------------------------------------------------------------
11364 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11365 implicit real*8 (a-h,o-z)
11366 include 'DIMENSIONS'
11367 include 'COMMON.IOUNITS'
11368 include 'COMMON.CHAIN'
11369 include 'COMMON.DERIV'
11370 include 'COMMON.INTERACT'
11371 include 'COMMON.CONTACTS'
11372 include 'COMMON.CONTMAT'
11373 include 'COMMON.CORRMAT'
11374 include 'COMMON.TORSION'
11375 include 'COMMON.VAR'
11376 include 'COMMON.GEO'
11377 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11381 C Parallel Antiparallel C
11386 C /| o |o o| o |\ C
11387 C j|/k\| / |/k\|l / C
11392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11394 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11395 C energy moment and not to the cluster cumulant.
11396 iti=itortyp(itype(i))
11397 if (j.lt.nres-1) then
11398 itj1=itype2loc(itype(j+1))
11402 itk=itype2loc(itype(k))
11403 itk1=itype2loc(itype(k+1))
11404 if (l.lt.nres-1) then
11405 itl1=itype2loc(itype(l+1))
11410 s1=dip(4,jj,i)*dip(4,kk,k)
11412 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11413 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11414 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11415 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11416 call transpose2(EE(1,1,k),auxmat(1,1))
11417 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11418 vv(1)=pizda(1,1)+pizda(2,2)
11419 vv(2)=pizda(2,1)-pizda(1,2)
11420 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11421 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11422 cd & "sum",-(s2+s3+s4)
11424 eello6_graph3=-(s1+s2+s3+s4)
11426 eello6_graph3=-(s2+s3+s4)
11428 c eello6_graph3=-s4
11429 C Derivatives in gamma(k-1)
11430 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11431 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11432 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11433 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11434 C Derivatives in gamma(l-1)
11435 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11436 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11437 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11438 vv(1)=pizda(1,1)+pizda(2,2)
11439 vv(2)=pizda(2,1)-pizda(1,2)
11440 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11441 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11442 C Cartesian derivatives.
11448 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11450 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11453 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11455 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11456 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11458 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11459 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11461 vv(1)=pizda(1,1)+pizda(2,2)
11462 vv(2)=pizda(2,1)-pizda(1,2)
11463 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11465 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11467 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11470 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11472 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11474 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11480 c----------------------------------------------------------------------------
11481 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11482 implicit real*8 (a-h,o-z)
11483 include 'DIMENSIONS'
11484 include 'COMMON.IOUNITS'
11485 include 'COMMON.CHAIN'
11486 include 'COMMON.DERIV'
11487 include 'COMMON.INTERACT'
11488 include 'COMMON.CONTACTS'
11489 include 'COMMON.CONTMAT'
11490 include 'COMMON.CORRMAT'
11491 include 'COMMON.TORSION'
11492 include 'COMMON.VAR'
11493 include 'COMMON.GEO'
11494 include 'COMMON.FFIELD'
11495 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11496 & auxvec1(2),auxmat1(2,2)
11498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11500 C Parallel Antiparallel C
11505 C /| o |o o| o |\ C
11506 C \ j|/k\| \ |/k\|l C
11511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11513 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11514 C energy moment and not to the cluster cumulant.
11515 cd write (2,*) 'eello_graph4: wturn6',wturn6
11516 iti=itype2loc(itype(i))
11517 itj=itype2loc(itype(j))
11518 if (j.lt.nres-1) then
11519 itj1=itype2loc(itype(j+1))
11523 itk=itype2loc(itype(k))
11524 if (k.lt.nres-1) then
11525 itk1=itype2loc(itype(k+1))
11529 itl=itype2loc(itype(l))
11530 if (l.lt.nres-1) then
11531 itl1=itype2loc(itype(l+1))
11535 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11536 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11537 cd & ' itl',itl,' itl1',itl1
11539 if (imat.eq.1) then
11540 s1=dip(3,jj,i)*dip(3,kk,k)
11542 s1=dip(2,jj,j)*dip(2,kk,l)
11545 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11546 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11548 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11549 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11551 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11552 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11554 call transpose2(EUg(1,1,k),auxmat(1,1))
11555 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11556 vv(1)=pizda(1,1)-pizda(2,2)
11557 vv(2)=pizda(2,1)+pizda(1,2)
11558 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11559 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11561 eello6_graph4=-(s1+s2+s3+s4)
11563 eello6_graph4=-(s2+s3+s4)
11565 C Derivatives in gamma(i-1)
11568 if (imat.eq.1) then
11569 s1=dipderg(2,jj,i)*dip(3,kk,k)
11571 s1=dipderg(4,jj,j)*dip(2,kk,l)
11574 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11576 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11577 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11579 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11580 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11582 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11583 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11584 cd write (2,*) 'turn6 derivatives'
11586 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11588 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11592 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11594 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11598 C Derivatives in gamma(k-1)
11600 if (imat.eq.1) then
11601 s1=dip(3,jj,i)*dipderg(2,kk,k)
11603 s1=dip(2,jj,j)*dipderg(4,kk,l)
11606 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11607 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11609 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11610 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11612 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11613 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11615 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11616 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11617 vv(1)=pizda(1,1)-pizda(2,2)
11618 vv(2)=pizda(2,1)+pizda(1,2)
11619 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11620 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11622 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11624 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11628 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11630 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11633 C Derivatives in gamma(j-1) or gamma(l-1)
11634 if (l.eq.j+1 .and. l.gt.1) then
11635 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11636 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11637 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11638 vv(1)=pizda(1,1)-pizda(2,2)
11639 vv(2)=pizda(2,1)+pizda(1,2)
11640 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11641 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11642 else if (j.gt.1) then
11643 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11644 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11645 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11646 vv(1)=pizda(1,1)-pizda(2,2)
11647 vv(2)=pizda(2,1)+pizda(1,2)
11648 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11649 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11650 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11652 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11655 C Cartesian derivatives.
11661 if (imat.eq.1) then
11662 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11664 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11667 if (imat.eq.1) then
11668 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11670 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11674 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11676 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11678 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11679 & b1(1,j+1),auxvec(1))
11680 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11682 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11683 & b1(1,l+1),auxvec(1))
11684 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11686 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11688 vv(1)=pizda(1,1)-pizda(2,2)
11689 vv(2)=pizda(2,1)+pizda(1,2)
11690 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11692 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11694 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11697 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11700 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11703 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11705 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11707 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11711 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11713 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11716 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11718 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11726 c----------------------------------------------------------------------------
11727 double precision function eello_turn6(i,jj,kk)
11728 implicit real*8 (a-h,o-z)
11729 include 'DIMENSIONS'
11730 include 'COMMON.IOUNITS'
11731 include 'COMMON.CHAIN'
11732 include 'COMMON.DERIV'
11733 include 'COMMON.INTERACT'
11734 include 'COMMON.CONTACTS'
11735 include 'COMMON.CONTMAT'
11736 include 'COMMON.CORRMAT'
11737 include 'COMMON.TORSION'
11738 include 'COMMON.VAR'
11739 include 'COMMON.GEO'
11740 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11741 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11743 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11744 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11745 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11746 C the respective energy moment and not to the cluster cumulant.
11755 iti=itype2loc(itype(i))
11756 itk=itype2loc(itype(k))
11757 itk1=itype2loc(itype(k+1))
11758 itl=itype2loc(itype(l))
11759 itj=itype2loc(itype(j))
11760 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11761 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11762 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11767 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11769 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11773 derx_turn(lll,kkk,iii)=0.0d0
11780 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11782 cd write (2,*) 'eello6_5',eello6_5
11784 call transpose2(AEA(1,1,1),auxmat(1,1))
11785 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11786 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11787 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11789 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11790 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11791 s2 = scalar2(b1(1,k),vtemp1(1))
11793 call transpose2(AEA(1,1,2),atemp(1,1))
11794 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11795 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11796 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11798 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11799 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11800 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11802 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11803 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11804 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11805 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11806 ss13 = scalar2(b1(1,k),vtemp4(1))
11807 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11809 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11815 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11816 C Derivatives in gamma(i+2)
11820 call transpose2(AEA(1,1,1),auxmatd(1,1))
11821 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11822 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11823 call transpose2(AEAderg(1,1,2),atempd(1,1))
11824 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11825 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11827 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11828 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11829 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11835 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11836 C Derivatives in gamma(i+3)
11838 call transpose2(AEA(1,1,1),auxmatd(1,1))
11839 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11840 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11841 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11843 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11844 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11845 s2d = scalar2(b1(1,k),vtemp1d(1))
11847 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11848 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11850 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11852 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11853 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11854 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11862 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11863 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11865 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11866 & -0.5d0*ekont*(s2d+s12d)
11868 C Derivatives in gamma(i+4)
11869 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11870 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11871 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11873 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11874 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11875 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11883 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11885 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11887 C Derivatives in gamma(i+5)
11889 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11890 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11891 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11893 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11894 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11895 s2d = scalar2(b1(1,k),vtemp1d(1))
11897 call transpose2(AEA(1,1,2),atempd(1,1))
11898 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11899 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11901 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11902 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11904 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11905 ss13d = scalar2(b1(1,k),vtemp4d(1))
11906 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11914 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11915 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11917 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11918 & -0.5d0*ekont*(s2d+s12d)
11920 C Cartesian derivatives
11925 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11926 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11927 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11929 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11930 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11932 s2d = scalar2(b1(1,k),vtemp1d(1))
11934 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11935 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11936 s8d = -(atempd(1,1)+atempd(2,2))*
11937 & scalar2(cc(1,1,l),vtemp2(1))
11939 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11941 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11942 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11949 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11950 & - 0.5d0*(s1d+s2d)
11952 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11956 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11957 & - 0.5d0*(s8d+s12d)
11959 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11968 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11969 & achuj_tempd(1,1))
11970 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11971 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11972 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11973 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11974 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11976 ss13d = scalar2(b1(1,k),vtemp4d(1))
11977 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11978 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11982 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11983 cd & 16*eel_turn6_num
11985 if (j.lt.nres-1) then
11992 if (l.lt.nres-1) then
12000 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
12001 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
12002 cgrad ghalf=0.5d0*ggg1(ll)
12004 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
12005 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
12006 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
12007 & +ekont*derx_turn(ll,2,1)
12008 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
12009 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
12010 & +ekont*derx_turn(ll,4,1)
12011 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
12012 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
12013 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
12014 cgrad ghalf=0.5d0*ggg2(ll)
12016 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
12017 & +ekont*derx_turn(ll,2,2)
12018 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
12019 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
12020 & +ekont*derx_turn(ll,4,2)
12021 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
12022 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
12023 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
12028 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
12033 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
12039 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
12044 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
12048 cd write (2,*) iii,g_corr6_loc(iii)
12050 eello_turn6=ekont*eel_turn6
12051 cd write (2,*) 'ekont',ekont
12052 cd write (2,*) 'eel_turn6',ekont*eel_turn6
12055 C-----------------------------------------------------------------------------
12057 double precision function scalar(u,v)
12058 !DIR$ INLINEALWAYS scalar
12060 cDEC$ ATTRIBUTES FORCEINLINE::scalar
12063 double precision u(3),v(3)
12064 cd double precision sc
12072 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12075 crc-------------------------------------------------
12076 SUBROUTINE MATVEC2(A1,V1,V2)
12077 !DIR$ INLINEALWAYS MATVEC2
12079 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12081 implicit real*8 (a-h,o-z)
12082 include 'DIMENSIONS'
12083 DIMENSION A1(2,2),V1(2),V2(2)
12087 c 3 VI=VI+A1(I,K)*V1(K)
12091 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12092 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12097 C---------------------------------------
12098 SUBROUTINE MATMAT2(A1,A2,A3)
12100 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12102 implicit real*8 (a-h,o-z)
12103 include 'DIMENSIONS'
12104 DIMENSION A1(2,2),A2(2,2),A3(2,2)
12105 c DIMENSION AI3(2,2)
12109 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
12115 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12116 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12117 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12118 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12126 c-------------------------------------------------------------------------
12127 double precision function scalar2(u,v)
12128 !DIR$ INLINEALWAYS scalar2
12130 double precision u(2),v(2)
12131 double precision sc
12133 scalar2=u(1)*v(1)+u(2)*v(2)
12137 C-----------------------------------------------------------------------------
12139 subroutine transpose2(a,at)
12140 !DIR$ INLINEALWAYS transpose2
12142 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12145 double precision a(2,2),at(2,2)
12152 c--------------------------------------------------------------------------
12153 subroutine transpose(n,a,at)
12156 double precision a(n,n),at(n,n)
12164 C---------------------------------------------------------------------------
12165 subroutine prodmat3(a1,a2,kk,transp,prod)
12166 !DIR$ INLINEALWAYS prodmat3
12168 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12172 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12174 crc double precision auxmat(2,2),prod_(2,2)
12177 crc call transpose2(kk(1,1),auxmat(1,1))
12178 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12179 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12181 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12182 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12183 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12184 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12185 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12186 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12187 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12188 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12191 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12192 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12194 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12195 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12196 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12197 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12198 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12199 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12200 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12201 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12204 c call transpose2(a2(1,1),a2t(1,1))
12207 crc print *,((prod_(i,j),i=1,2),j=1,2)
12208 crc print *,((prod(i,j),i=1,2),j=1,2)
12212 CCC----------------------------------------------
12213 subroutine Eliptransfer(eliptran)
12214 implicit real*8 (a-h,o-z)
12215 include 'DIMENSIONS'
12216 include 'COMMON.GEO'
12217 include 'COMMON.VAR'
12218 include 'COMMON.LOCAL'
12219 include 'COMMON.CHAIN'
12220 include 'COMMON.DERIV'
12221 include 'COMMON.NAMES'
12222 include 'COMMON.INTERACT'
12223 include 'COMMON.IOUNITS'
12224 include 'COMMON.CALC'
12225 include 'COMMON.CONTROL'
12226 include 'COMMON.SPLITELE'
12227 include 'COMMON.SBRIDGE'
12228 C this is done by Adasko
12229 C print *,"wchodze"
12230 C structure of box:
12232 C--bordliptop-- buffore starts
12233 C--bufliptop--- here true lipid starts
12235 C--buflipbot--- lipid ends buffore starts
12236 C--bordlipbot--buffore ends
12238 do i=ilip_start,ilip_end
12240 if (itype(i).eq.ntyp1) cycle
12242 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12243 if (positi.le.0.0) positi=positi+boxzsize
12245 C first for peptide groups
12246 c for each residue check if it is in lipid or lipid water border area
12247 if ((positi.gt.bordlipbot)
12248 &.and.(positi.lt.bordliptop)) then
12249 C the energy transfer exist
12250 if (positi.lt.buflipbot) then
12251 C what fraction I am in
12253 & ((positi-bordlipbot)/lipbufthick)
12254 C lipbufthick is thickenes of lipid buffore
12255 sslip=sscalelip(fracinbuf)
12256 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12257 eliptran=eliptran+sslip*pepliptran
12258 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12259 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12260 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12262 C print *,"doing sccale for lower part"
12263 C print *,i,sslip,fracinbuf,ssgradlip
12264 elseif (positi.gt.bufliptop) then
12265 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12266 sslip=sscalelip(fracinbuf)
12267 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12268 eliptran=eliptran+sslip*pepliptran
12269 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12270 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12271 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12272 C print *, "doing sscalefor top part"
12273 C print *,i,sslip,fracinbuf,ssgradlip
12275 eliptran=eliptran+pepliptran
12276 C print *,"I am in true lipid"
12279 C eliptran=elpitran+0.0 ! I am in water
12282 C print *, "nic nie bylo w lipidzie?"
12283 C now multiply all by the peptide group transfer factor
12284 C eliptran=eliptran*pepliptran
12285 C now the same for side chains
12287 do i=ilip_start,ilip_end
12288 if (itype(i).eq.ntyp1) cycle
12289 positi=(mod(c(3,i+nres),boxzsize))
12290 if (positi.le.0) positi=positi+boxzsize
12291 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12292 c for each residue check if it is in lipid or lipid water border area
12293 C respos=mod(c(3,i+nres),boxzsize)
12294 C print *,positi,bordlipbot,buflipbot
12295 if ((positi.gt.bordlipbot)
12296 & .and.(positi.lt.bordliptop)) then
12297 C the energy transfer exist
12298 if (positi.lt.buflipbot) then
12300 & ((positi-bordlipbot)/lipbufthick)
12301 C lipbufthick is thickenes of lipid buffore
12302 sslip=sscalelip(fracinbuf)
12303 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12304 eliptran=eliptran+sslip*liptranene(itype(i))
12305 gliptranx(3,i)=gliptranx(3,i)
12306 &+ssgradlip*liptranene(itype(i))
12307 gliptranc(3,i-1)= gliptranc(3,i-1)
12308 &+ssgradlip*liptranene(itype(i))
12309 C print *,"doing sccale for lower part"
12310 elseif (positi.gt.bufliptop) then
12312 &((bordliptop-positi)/lipbufthick)
12313 sslip=sscalelip(fracinbuf)
12314 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12315 eliptran=eliptran+sslip*liptranene(itype(i))
12316 gliptranx(3,i)=gliptranx(3,i)
12317 &+ssgradlip*liptranene(itype(i))
12318 gliptranc(3,i-1)= gliptranc(3,i-1)
12319 &+ssgradlip*liptranene(itype(i))
12320 C print *, "doing sscalefor top part",sslip,fracinbuf
12322 eliptran=eliptran+liptranene(itype(i))
12323 C print *,"I am in true lipid"
12325 endif ! if in lipid or buffor
12327 C eliptran=elpitran+0.0 ! I am in water
12331 C---------------------------------------------------------
12332 C AFM soubroutine for constant force
12333 subroutine AFMforce(Eafmforce)
12334 implicit real*8 (a-h,o-z)
12335 include 'DIMENSIONS'
12336 include 'COMMON.GEO'
12337 include 'COMMON.VAR'
12338 include 'COMMON.LOCAL'
12339 include 'COMMON.CHAIN'
12340 include 'COMMON.DERIV'
12341 include 'COMMON.NAMES'
12342 include 'COMMON.INTERACT'
12343 include 'COMMON.IOUNITS'
12344 include 'COMMON.CALC'
12345 include 'COMMON.CONTROL'
12346 include 'COMMON.SPLITELE'
12347 include 'COMMON.SBRIDGE'
12352 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12353 dist=dist+diffafm(i)**2
12356 Eafmforce=-forceAFMconst*(dist-distafminit)
12358 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12359 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12361 C print *,'AFM',Eafmforce
12364 C---------------------------------------------------------
12365 C AFM subroutine with pseudoconstant velocity
12366 subroutine AFMvel(Eafmforce)
12367 implicit real*8 (a-h,o-z)
12368 include 'DIMENSIONS'
12369 include 'COMMON.GEO'
12370 include 'COMMON.VAR'
12371 include 'COMMON.LOCAL'
12372 include 'COMMON.CHAIN'
12373 include 'COMMON.DERIV'
12374 include 'COMMON.NAMES'
12375 include 'COMMON.INTERACT'
12376 include 'COMMON.IOUNITS'
12377 include 'COMMON.CALC'
12378 include 'COMMON.CONTROL'
12379 include 'COMMON.SPLITELE'
12380 include 'COMMON.SBRIDGE'
12382 C Only for check grad COMMENT if not used for checkgrad
12384 C--------------------------------------------------------
12385 C print *,"wchodze"
12389 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12390 dist=dist+diffafm(i)**2
12393 Eafmforce=0.5d0*forceAFMconst
12394 & *(distafminit+totTafm*velAFMconst-dist)**2
12395 C Eafmforce=-forceAFMconst*(dist-distafminit)
12397 gradafm(i,afmend-1)=-forceAFMconst*
12398 &(distafminit+totTafm*velAFMconst-dist)
12400 gradafm(i,afmbeg-1)=forceAFMconst*
12401 &(distafminit+totTafm*velAFMconst-dist)
12404 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12407 C-----------------------------------------------------------
12408 C first for shielding is setting of function of side-chains
12409 subroutine set_shield_fac
12410 implicit real*8 (a-h,o-z)
12411 include 'DIMENSIONS'
12412 include 'COMMON.CHAIN'
12413 include 'COMMON.DERIV'
12414 include 'COMMON.IOUNITS'
12415 include 'COMMON.SHIELD'
12416 include 'COMMON.INTERACT'
12417 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12418 double precision div77_81/0.974996043d0/,
12419 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12421 C the vector between center of side_chain and peptide group
12422 double precision pep_side(3),long,side_calf(3),
12423 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12424 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12425 C the line belowe needs to be changed for FGPROC>1
12427 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12429 Cif there two consequtive dummy atoms there is no peptide group between them
12430 C the line below has to be changed for FGPROC>1
12433 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12437 C first lets set vector conecting the ithe side-chain with kth side-chain
12438 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12439 C pep_side(j)=2.0d0
12440 C and vector conecting the side-chain with its proper calfa
12441 side_calf(j)=c(j,k+nres)-c(j,k)
12442 C side_calf(j)=2.0d0
12443 pept_group(j)=c(j,i)-c(j,i+1)
12444 C lets have their lenght
12445 dist_pep_side=pep_side(j)**2+dist_pep_side
12446 dist_side_calf=dist_side_calf+side_calf(j)**2
12447 dist_pept_group=dist_pept_group+pept_group(j)**2
12449 dist_pep_side=dsqrt(dist_pep_side)
12450 dist_pept_group=dsqrt(dist_pept_group)
12451 dist_side_calf=dsqrt(dist_side_calf)
12453 pep_side_norm(j)=pep_side(j)/dist_pep_side
12454 side_calf_norm(j)=dist_side_calf
12456 C now sscale fraction
12457 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12458 C print *,buff_shield,"buff"
12460 if (sh_frac_dist.le.0.0) cycle
12461 C If we reach here it means that this side chain reaches the shielding sphere
12462 C Lets add him to the list for gradient
12463 ishield_list(i)=ishield_list(i)+1
12464 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12465 C this list is essential otherwise problem would be O3
12466 shield_list(ishield_list(i),i)=k
12467 C Lets have the sscale value
12468 if (sh_frac_dist.gt.1.0) then
12469 scale_fac_dist=1.0d0
12471 sh_frac_dist_grad(j)=0.0d0
12474 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12475 & *(2.0*sh_frac_dist-3.0d0)
12476 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12477 & /dist_pep_side/buff_shield*0.5
12478 C remember for the final gradient multiply sh_frac_dist_grad(j)
12479 C for side_chain by factor -2 !
12481 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12482 C print *,"jestem",scale_fac_dist,fac_help_scale,
12483 C & sh_frac_dist_grad(j)
12486 C if ((i.eq.3).and.(k.eq.2)) then
12487 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12491 C this is what is now we have the distance scaling now volume...
12492 short=short_r_sidechain(itype(k))
12493 long=long_r_sidechain(itype(k))
12494 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12497 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12498 C costhet_fac=0.0d0
12500 costhet_grad(j)=costhet_fac*pep_side(j)
12502 C remember for the final gradient multiply costhet_grad(j)
12503 C for side_chain by factor -2 !
12504 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12505 C pep_side0pept_group is vector multiplication
12506 pep_side0pept_group=0.0
12508 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12510 cosalfa=(pep_side0pept_group/
12511 & (dist_pep_side*dist_side_calf))
12512 fac_alfa_sin=1.0-cosalfa**2
12513 fac_alfa_sin=dsqrt(fac_alfa_sin)
12514 rkprim=fac_alfa_sin*(long-short)+short
12516 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12517 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12520 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12521 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12522 &*(long-short)/fac_alfa_sin*cosalfa/
12523 &((dist_pep_side*dist_side_calf))*
12524 &((side_calf(j))-cosalfa*
12525 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12527 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12528 &*(long-short)/fac_alfa_sin*cosalfa
12529 &/((dist_pep_side*dist_side_calf))*
12531 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12534 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12537 C now the gradient...
12538 C grad_shield is gradient of Calfa for peptide groups
12539 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12541 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12542 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12544 grad_shield(j,i)=grad_shield(j,i)
12545 C gradient po skalowaniu
12546 & +(sh_frac_dist_grad(j)
12547 C gradient po costhet
12548 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12549 &-scale_fac_dist*(cosphi_grad_long(j))
12550 &/(1.0-cosphi) )*div77_81
12552 C grad_shield_side is Cbeta sidechain gradient
12553 grad_shield_side(j,ishield_list(i),i)=
12554 & (sh_frac_dist_grad(j)*(-2.0d0)
12555 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12556 & +scale_fac_dist*(cosphi_grad_long(j))
12557 & *2.0d0/(1.0-cosphi))
12558 & *div77_81*VofOverlap
12560 grad_shield_loc(j,ishield_list(i),i)=
12561 & scale_fac_dist*cosphi_grad_loc(j)
12562 & *2.0d0/(1.0-cosphi)
12563 & *div77_81*VofOverlap
12565 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12567 fac_shield(i)=VolumeTotal*div77_81+div4_81
12568 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12572 C--------------------------------------------------------------------------
12573 double precision function tschebyshev(m,n,x,y)
12575 include "DIMENSIONS"
12577 double precision x(n),y,yy(0:maxvar),aux
12578 c Tschebyshev polynomial. Note that the first term is omitted
12579 c m=0: the constant term is included
12580 c m=1: the constant term is not included
12584 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12593 C--------------------------------------------------------------------------
12594 double precision function gradtschebyshev(m,n,x,y)
12596 include "DIMENSIONS"
12598 double precision x(n+1),y,yy(0:maxvar),aux
12599 c Tschebyshev polynomial. Note that the first term is omitted
12600 c m=0: the constant term is included
12601 c m=1: the constant term is not included
12605 yy(i)=2*y*yy(i-1)-yy(i-2)
12609 aux=aux+x(i+1)*yy(i)*(i+1)
12610 C print *, x(i+1),yy(i),i
12612 gradtschebyshev=aux
12615 C------------------------------------------------------------------------
12616 C first for shielding is setting of function of side-chains
12617 subroutine set_shield_fac2
12618 implicit real*8 (a-h,o-z)
12619 include 'DIMENSIONS'
12620 include 'COMMON.CHAIN'
12621 include 'COMMON.DERIV'
12622 include 'COMMON.IOUNITS'
12623 include 'COMMON.SHIELD'
12624 include 'COMMON.INTERACT'
12625 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12626 double precision div77_81/0.974996043d0/,
12627 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12629 C the vector between center of side_chain and peptide group
12630 double precision pep_side(3),long,side_calf(3),
12631 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12632 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12633 C the line belowe needs to be changed for FGPROC>1
12635 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12637 Cif there two consequtive dummy atoms there is no peptide group between them
12638 C the line below has to be changed for FGPROC>1
12641 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12645 C first lets set vector conecting the ithe side-chain with kth side-chain
12646 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12647 C pep_side(j)=2.0d0
12648 C and vector conecting the side-chain with its proper calfa
12649 side_calf(j)=c(j,k+nres)-c(j,k)
12650 C side_calf(j)=2.0d0
12651 pept_group(j)=c(j,i)-c(j,i+1)
12652 C lets have their lenght
12653 dist_pep_side=pep_side(j)**2+dist_pep_side
12654 dist_side_calf=dist_side_calf+side_calf(j)**2
12655 dist_pept_group=dist_pept_group+pept_group(j)**2
12657 dist_pep_side=dsqrt(dist_pep_side)
12658 dist_pept_group=dsqrt(dist_pept_group)
12659 dist_side_calf=dsqrt(dist_side_calf)
12661 pep_side_norm(j)=pep_side(j)/dist_pep_side
12662 side_calf_norm(j)=dist_side_calf
12664 C now sscale fraction
12665 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12666 C print *,buff_shield,"buff"
12668 if (sh_frac_dist.le.0.0) cycle
12669 C If we reach here it means that this side chain reaches the shielding sphere
12670 C Lets add him to the list for gradient
12671 ishield_list(i)=ishield_list(i)+1
12672 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12673 C this list is essential otherwise problem would be O3
12674 shield_list(ishield_list(i),i)=k
12675 C Lets have the sscale value
12676 if (sh_frac_dist.gt.1.0) then
12677 scale_fac_dist=1.0d0
12679 sh_frac_dist_grad(j)=0.0d0
12682 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12683 & *(2.0d0*sh_frac_dist-3.0d0)
12684 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12685 & /dist_pep_side/buff_shield*0.5d0
12686 C remember for the final gradient multiply sh_frac_dist_grad(j)
12687 C for side_chain by factor -2 !
12689 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12690 C sh_frac_dist_grad(j)=0.0d0
12691 C scale_fac_dist=1.0d0
12692 C print *,"jestem",scale_fac_dist,fac_help_scale,
12693 C & sh_frac_dist_grad(j)
12696 C this is what is now we have the distance scaling now volume...
12697 short=short_r_sidechain(itype(k))
12698 long=long_r_sidechain(itype(k))
12699 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12700 sinthet=short/dist_pep_side*costhet
12704 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12705 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12706 C & -short/dist_pep_side**2/costhet)
12707 C costhet_fac=0.0d0
12709 costhet_grad(j)=costhet_fac*pep_side(j)
12711 C remember for the final gradient multiply costhet_grad(j)
12712 C for side_chain by factor -2 !
12713 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12714 C pep_side0pept_group is vector multiplication
12715 pep_side0pept_group=0.0d0
12717 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12719 cosalfa=(pep_side0pept_group/
12720 & (dist_pep_side*dist_side_calf))
12721 fac_alfa_sin=1.0d0-cosalfa**2
12722 fac_alfa_sin=dsqrt(fac_alfa_sin)
12723 rkprim=fac_alfa_sin*(long-short)+short
12727 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12729 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12730 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12731 & dist_pep_side**2)
12734 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12735 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12736 &*(long-short)/fac_alfa_sin*cosalfa/
12737 &((dist_pep_side*dist_side_calf))*
12738 &((side_calf(j))-cosalfa*
12739 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12740 C cosphi_grad_long(j)=0.0d0
12741 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12742 &*(long-short)/fac_alfa_sin*cosalfa
12743 &/((dist_pep_side*dist_side_calf))*
12745 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12746 C cosphi_grad_loc(j)=0.0d0
12748 C print *,sinphi,sinthet
12749 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12750 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12751 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12754 C now the gradient...
12756 grad_shield(j,i)=grad_shield(j,i)
12757 C gradient po skalowaniu
12758 & +(sh_frac_dist_grad(j)*VofOverlap
12759 C gradient po costhet
12760 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12761 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12762 & sinphi/sinthet*costhet*costhet_grad(j)
12763 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12765 C grad_shield_side is Cbeta sidechain gradient
12766 grad_shield_side(j,ishield_list(i),i)=
12767 & (sh_frac_dist_grad(j)*(-2.0d0)
12769 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12770 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12771 & sinphi/sinthet*costhet*costhet_grad(j)
12772 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12775 grad_shield_loc(j,ishield_list(i),i)=
12776 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12777 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12778 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12782 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12784 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12786 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12787 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12788 c & " wshield",wshield
12789 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12793 C-----------------------------------------------------------------------
12794 C-----------------------------------------------------------
12795 C This subroutine is to mimic the histone like structure but as well can be
12796 C utilizet to nanostructures (infinit) small modification has to be used to
12797 C make it finite (z gradient at the ends has to be changes as well as the x,y
12798 C gradient has to be modified at the ends
12799 C The energy function is Kihara potential
12800 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12801 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12802 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12803 C simple Kihara potential
12804 subroutine calctube(Etube)
12805 implicit real*8 (a-h,o-z)
12806 include 'DIMENSIONS'
12807 include 'COMMON.GEO'
12808 include 'COMMON.VAR'
12809 include 'COMMON.LOCAL'
12810 include 'COMMON.CHAIN'
12811 include 'COMMON.DERIV'
12812 include 'COMMON.NAMES'
12813 include 'COMMON.INTERACT'
12814 include 'COMMON.IOUNITS'
12815 include 'COMMON.CALC'
12816 include 'COMMON.CONTROL'
12817 include 'COMMON.SPLITELE'
12818 include 'COMMON.SBRIDGE'
12819 double precision tub_r,vectube(3),enetube(maxres*2)
12824 C first we calculate the distance from tube center
12825 C first sugare-phosphate group for NARES this would be peptide group
12828 C lets ommit dummy atoms for now
12829 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12830 C now calculate distance from center of tube and direction vectors
12831 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12832 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12833 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12834 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12835 vectube(1)=vectube(1)-tubecenter(1)
12836 vectube(2)=vectube(2)-tubecenter(2)
12838 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12839 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12841 C as the tube is infinity we do not calculate the Z-vector use of Z
12844 C now calculte the distance
12845 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12846 C now normalize vector
12847 vectube(1)=vectube(1)/tub_r
12848 vectube(2)=vectube(2)/tub_r
12849 C calculte rdiffrence between r and r0
12852 rdiff6=rdiff**6.0d0
12853 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12854 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12855 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12856 C print *,rdiff,rdiff6,pep_aa_tube
12857 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12858 C now we calculate gradient
12859 fac=(-12.0d0*pep_aa_tube/rdiff6+
12860 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12861 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12864 C now direction of gg_tube vector
12866 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12867 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12870 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12872 C Lets not jump over memory as we use many times iti
12874 C lets ommit dummy atoms for now
12876 C in UNRES uncomment the line below as GLY has no side-chain...
12879 vectube(1)=c(1,i+nres)
12880 vectube(1)=mod(vectube(1),boxxsize)
12881 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12882 vectube(2)=c(2,i+nres)
12883 vectube(2)=mod(vectube(2),boxxsize)
12884 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12886 vectube(1)=vectube(1)-tubecenter(1)
12887 vectube(2)=vectube(2)-tubecenter(2)
12889 C as the tube is infinity we do not calculate the Z-vector use of Z
12892 C now calculte the distance
12893 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12894 C now normalize vector
12895 vectube(1)=vectube(1)/tub_r
12896 vectube(2)=vectube(2)/tub_r
12897 C calculte rdiffrence between r and r0
12900 rdiff6=rdiff**6.0d0
12901 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12902 sc_aa_tube=sc_aa_tube_par(iti)
12903 sc_bb_tube=sc_bb_tube_par(iti)
12904 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12905 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12906 C now we calculate gradient
12907 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12908 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12909 C now direction of gg_tube vector
12911 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12912 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12916 Etube=Etube+enetube(i)
12918 C print *,"ETUBE", etube
12921 C TO DO 1) add to total energy
12922 C 2) add to gradient summation
12923 C 3) add reading parameters (AND of course oppening of PARAM file)
12924 C 4) add reading the center of tube
12926 C 6) add to zerograd
12928 C-----------------------------------------------------------------------
12929 C-----------------------------------------------------------
12930 C This subroutine is to mimic the histone like structure but as well can be
12931 C utilizet to nanostructures (infinit) small modification has to be used to
12932 C make it finite (z gradient at the ends has to be changes as well as the x,y
12933 C gradient has to be modified at the ends
12934 C The energy function is Kihara potential
12935 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12936 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12937 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12938 C simple Kihara potential
12939 subroutine calctube2(Etube)
12940 implicit real*8 (a-h,o-z)
12941 include 'DIMENSIONS'
12942 include 'COMMON.GEO'
12943 include 'COMMON.VAR'
12944 include 'COMMON.LOCAL'
12945 include 'COMMON.CHAIN'
12946 include 'COMMON.DERIV'
12947 include 'COMMON.NAMES'
12948 include 'COMMON.INTERACT'
12949 include 'COMMON.IOUNITS'
12950 include 'COMMON.CALC'
12951 include 'COMMON.CONTROL'
12952 include 'COMMON.SPLITELE'
12953 include 'COMMON.SBRIDGE'
12954 double precision tub_r,vectube(3),enetube(maxres*2)
12959 C first we calculate the distance from tube center
12960 C first sugare-phosphate group for NARES this would be peptide group
12963 C lets ommit dummy atoms for now
12964 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12965 C now calculate distance from center of tube and direction vectors
12966 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12967 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12968 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12969 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12970 vectube(1)=vectube(1)-tubecenter(1)
12971 vectube(2)=vectube(2)-tubecenter(2)
12973 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12974 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12976 C as the tube is infinity we do not calculate the Z-vector use of Z
12979 C now calculte the distance
12980 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12981 C now normalize vector
12982 vectube(1)=vectube(1)/tub_r
12983 vectube(2)=vectube(2)/tub_r
12984 C calculte rdiffrence between r and r0
12987 rdiff6=rdiff**6.0d0
12988 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12989 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12990 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12991 C print *,rdiff,rdiff6,pep_aa_tube
12992 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12993 C now we calculate gradient
12994 fac=(-12.0d0*pep_aa_tube/rdiff6+
12995 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12996 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12999 C now direction of gg_tube vector
13001 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
13002 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
13005 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
13007 C Lets not jump over memory as we use many times iti
13009 C lets ommit dummy atoms for now
13011 C in UNRES uncomment the line below as GLY has no side-chain...
13014 vectube(1)=c(1,i+nres)
13015 vectube(1)=mod(vectube(1),boxxsize)
13016 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
13017 vectube(2)=c(2,i+nres)
13018 vectube(2)=mod(vectube(2),boxxsize)
13019 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
13021 vectube(1)=vectube(1)-tubecenter(1)
13022 vectube(2)=vectube(2)-tubecenter(2)
13023 C THIS FRAGMENT MAKES TUBE FINITE
13024 positi=(mod(c(3,i+nres),boxzsize))
13025 if (positi.le.0) positi=positi+boxzsize
13026 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
13027 c for each residue check if it is in lipid or lipid water border area
13028 C respos=mod(c(3,i+nres),boxzsize)
13029 print *,positi,bordtubebot,buftubebot,bordtubetop
13030 if ((positi.gt.bordtubebot)
13031 & .and.(positi.lt.bordtubetop)) then
13032 C the energy transfer exist
13033 if (positi.lt.buftubebot) then
13035 & ((positi-bordtubebot)/tubebufthick)
13036 C lipbufthick is thickenes of lipid buffore
13037 sstube=sscalelip(fracinbuf)
13038 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
13039 print *,ssgradtube, sstube,tubetranene(itype(i))
13040 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13041 gg_tube_SC(3,i)=gg_tube_SC(3,i)
13042 &+ssgradtube*tubetranene(itype(i))
13043 gg_tube(3,i-1)= gg_tube(3,i-1)
13044 &+ssgradtube*tubetranene(itype(i))
13045 C print *,"doing sccale for lower part"
13046 elseif (positi.gt.buftubetop) then
13048 &((bordtubetop-positi)/tubebufthick)
13049 sstube=sscalelip(fracinbuf)
13050 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
13051 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13052 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
13053 C &+ssgradtube*tubetranene(itype(i))
13054 C gg_tube(3,i-1)= gg_tube(3,i-1)
13055 C &+ssgradtube*tubetranene(itype(i))
13056 C print *, "doing sscalefor top part",sslip,fracinbuf
13060 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
13061 C print *,"I am in true lipid"
13067 endif ! if in lipid or buffor
13068 CEND OF FINITE FRAGMENT
13069 C as the tube is infinity we do not calculate the Z-vector use of Z
13072 C now calculte the distance
13073 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13074 C now normalize vector
13075 vectube(1)=vectube(1)/tub_r
13076 vectube(2)=vectube(2)/tub_r
13077 C calculte rdiffrence between r and r0
13080 rdiff6=rdiff**6.0d0
13081 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13082 sc_aa_tube=sc_aa_tube_par(iti)
13083 sc_bb_tube=sc_bb_tube_par(iti)
13084 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13085 & *sstube+enetube(i+nres)
13086 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13087 C now we calculate gradient
13088 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13089 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13090 C now direction of gg_tube vector
13092 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13093 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13095 gg_tube_SC(3,i)=gg_tube_SC(3,i)
13096 &+ssgradtube*enetube(i+nres)/sstube
13097 gg_tube(3,i-1)= gg_tube(3,i-1)
13098 &+ssgradtube*enetube(i+nres)/sstube
13102 Etube=Etube+enetube(i)
13104 C print *,"ETUBE", etube
13107 C TO DO 1) add to total energy
13108 C 2) add to gradient summation
13109 C 3) add reading parameters (AND of course oppening of PARAM file)
13110 C 4) add reading the center of tube
13112 C 6) add to zerograd
13113 c----------------------------------------------------------------------------
13114 subroutine e_saxs(Esaxs_constr)
13116 include 'DIMENSIONS'
13119 include "COMMON.SETUP"
13122 include 'COMMON.SBRIDGE'
13123 include 'COMMON.CHAIN'
13124 include 'COMMON.GEO'
13125 include 'COMMON.DERIV'
13126 include 'COMMON.LOCAL'
13127 include 'COMMON.INTERACT'
13128 include 'COMMON.VAR'
13129 include 'COMMON.IOUNITS'
13130 c include 'COMMON.MD'
13133 include 'COMMON.LANGEVIN.lang0.5diag'
13135 include 'COMMON.LANGEVIN.lang0'
13138 include 'COMMON.LANGEVIN'
13140 include 'COMMON.CONTROL'
13141 include 'COMMON.SAXS'
13142 include 'COMMON.NAMES'
13143 include 'COMMON.TIME1'
13144 include 'COMMON.FFIELD'
13146 double precision Esaxs_constr
13147 integer i,iint,j,k,l
13148 double precision PgradC(maxSAXS,3,maxres),
13149 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13151 double precision PgradC_(maxSAXS,3,maxres),
13152 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13154 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13155 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13156 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13157 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13158 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13159 double precision dist,mygauss,mygaussder
13161 integer llicz,lllicz
13162 double precision time01
13163 c SAXS restraint penalty function
13165 write(iout,*) "------- SAXS penalty function start -------"
13166 write (iout,*) "nsaxs",nsaxs
13167 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13168 write (iout,*) "Psaxs"
13170 write (iout,'(i5,e15.5)') i, Psaxs(i)
13176 Esaxs_constr = 0.0d0
13181 PgradC(k,l,j)=0.0d0
13182 PgradX(k,l,j)=0.0d0
13187 do i=iatsc_s,iatsc_e
13188 if (itype(i).eq.ntyp1) cycle
13189 do iint=1,nint_gr(i)
13190 do j=istart(i,iint),iend(i,iint)
13191 if (itype(j).eq.ntyp1) cycle
13194 dijCASC=dist(i,j+nres)
13195 dijSCCA=dist(i+nres,j)
13196 dijSCSC=dist(i+nres,j+nres)
13197 sigma2CACA=2.0d0/(pstok**2)
13198 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13199 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13200 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13203 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13204 if (itype(j).ne.10) then
13205 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13209 if (itype(i).ne.10) then
13210 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13214 if (itype(i).ne.10 .and. itype(j).ne.10) then
13215 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13219 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13221 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13223 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13224 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13225 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13226 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13229 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13230 PgradC(k,l,i) = PgradC(k,l,i)-aux
13231 PgradC(k,l,j) = PgradC(k,l,j)+aux
13233 if (itype(j).ne.10) then
13234 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13235 PgradC(k,l,i) = PgradC(k,l,i)-aux
13236 PgradC(k,l,j) = PgradC(k,l,j)+aux
13237 PgradX(k,l,j) = PgradX(k,l,j)+aux
13240 if (itype(i).ne.10) then
13241 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13242 PgradX(k,l,i) = PgradX(k,l,i)-aux
13243 PgradC(k,l,i) = PgradC(k,l,i)-aux
13244 PgradC(k,l,j) = PgradC(k,l,j)+aux
13247 if (itype(i).ne.10 .and. itype(j).ne.10) then
13248 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13249 PgradC(k,l,i) = PgradC(k,l,i)-aux
13250 PgradC(k,l,j) = PgradC(k,l,j)+aux
13251 PgradX(k,l,i) = PgradX(k,l,i)-aux
13252 PgradX(k,l,j) = PgradX(k,l,j)+aux
13258 sigma2CACA=scal_rad**2*0.25d0/
13259 & (restok(itype(j))**2+restok(itype(i))**2)
13260 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13261 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13263 sigmaCACA=dsqrt(sigma2CACA)
13264 threesig=3.0d0/sigmaCACA
13268 if (dabs(dijCACA-dk).ge.threesig) cycle
13271 aux = sigmaCACA*(dijCACA-dk)
13272 expCACA = mygauss(aux)
13273 c if (expcaca.eq.0.0d0) cycle
13274 Pcalc(k) = Pcalc(k)+expCACA
13275 CACAgrad = -sigmaCACA*mygaussder(aux)
13276 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13278 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13279 PgradC(k,l,i) = PgradC(k,l,i)-aux
13280 PgradC(k,l,j) = PgradC(k,l,j)+aux
13283 c write (iout,*) "i",i," j",j," llicz",llicz
13285 IF (saxs_cutoff.eq.0) THEN
13288 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13289 Pcalc(k) = Pcalc(k)+expCACA
13290 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13292 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13293 PgradC(k,l,i) = PgradC(k,l,i)-aux
13294 PgradC(k,l,j) = PgradC(k,l,j)+aux
13298 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13301 c write (2,*) "ijk",i,j,k
13302 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13303 if (sss2.eq.0.0d0) cycle
13304 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13305 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13306 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13307 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13309 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13310 Pcalc(k) = Pcalc(k)+expCACA
13312 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13314 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13315 & ssgrad2*expCACA/sss2
13318 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13319 PgradC(k,l,i) = PgradC(k,l,i)+aux
13320 PgradC(k,l,j) = PgradC(k,l,j)-aux
13330 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13332 c write (iout,*) "lllicz",lllicz
13334 c time01=MPI_Wtime()
13337 if (nfgtasks.gt.1) then
13338 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13339 & MPI_SUM,FG_COMM,IERR)
13340 c if (fg_rank.eq.king) then
13342 Pcalc(k) = Pcalc_(k)
13345 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13346 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13347 c if (fg_rank.eq.king) then
13351 c PgradC(k,l,i) = PgradC_(k,l,i)
13357 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13358 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13359 c if (fg_rank.eq.king) then
13363 c PgradX(k,l,i) = PgradX_(k,l,i)
13373 Cnorm = Cnorm + Pcalc(k)
13376 if (fg_rank.eq.king) then
13378 Esaxs_constr = dlog(Cnorm)-wsaxs0
13380 if (Pcalc(k).gt.0.0d0)
13381 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13383 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13387 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13402 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13403 auxC1 = auxC1+PgradC(k,l,i)
13405 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13406 auxX1 = auxX1+PgradX(k,l,i)
13409 gsaxsC(l,i) = auxC - auxC1/Cnorm
13411 gsaxsX(l,i) = auxX - auxX1/Cnorm
13413 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13414 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13415 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13416 c * " gradX",wsaxs*gsaxsX(l,i)
13420 time_SAXS=time_SAXS+MPI_Wtime()-time01
13423 write (iout,*) "gsaxsc"
13425 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13433 c----------------------------------------------------------------------------
13434 subroutine e_saxsC(Esaxs_constr)
13436 include 'DIMENSIONS'
13439 include "COMMON.SETUP"
13442 include 'COMMON.SBRIDGE'
13443 include 'COMMON.CHAIN'
13444 include 'COMMON.GEO'
13445 include 'COMMON.DERIV'
13446 include 'COMMON.LOCAL'
13447 include 'COMMON.INTERACT'
13448 include 'COMMON.VAR'
13449 include 'COMMON.IOUNITS'
13450 c include 'COMMON.MD'
13453 include 'COMMON.LANGEVIN.lang0.5diag'
13455 include 'COMMON.LANGEVIN.lang0'
13458 include 'COMMON.LANGEVIN'
13460 include 'COMMON.CONTROL'
13461 include 'COMMON.SAXS'
13462 include 'COMMON.NAMES'
13463 include 'COMMON.TIME1'
13464 include 'COMMON.FFIELD'
13466 double precision Esaxs_constr
13467 integer i,iint,j,k,l
13468 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13470 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13472 double precision dk,dijCASPH,dijSCSPH,
13473 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13474 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13476 c SAXS restraint penalty function
13478 write(iout,*) "------- SAXS penalty function start -------"
13479 write (iout,*) "nsaxs",nsaxs
13482 print *,MyRank,"C",i,(C(j,i),j=1,3)
13485 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13488 Esaxs_constr = 0.0d0
13490 do j=isaxs_start,isaxs_end
13499 if (itype(i).eq.ntyp1) cycle
13503 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13505 if (itype(i).ne.10) then
13507 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13510 sigma2CA=2.0d0/pstok**2
13511 sigma2SC=4.0d0/restok(itype(i))**2
13512 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13513 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13514 Pcalc = Pcalc+expCASPH+expSCSPH
13516 write(*,*) "processor i j Pcalc",
13517 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13519 CASPHgrad = sigma2CA*expCASPH
13520 SCSPHgrad = sigma2SC*expSCSPH
13522 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13523 PgradX(l,i) = PgradX(l,i) + aux
13524 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13529 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13530 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13533 logPtot = logPtot - dlog(Pcalc)
13534 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13535 c & " logPtot",logPtot
13538 if (nfgtasks.gt.1) then
13539 c write (iout,*) "logPtot before reduction",logPtot
13540 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13541 & MPI_SUM,king,FG_COMM,IERR)
13543 c write (iout,*) "logPtot after reduction",logPtot
13544 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13545 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13546 if (fg_rank.eq.king) then
13549 gsaxsC(l,i) = gsaxsC_(l,i)
13553 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13554 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13555 if (fg_rank.eq.king) then
13558 gsaxsX(l,i) = gsaxsX_(l,i)
13564 Esaxs_constr = logPtot
13567 c----------------------------------------------------------------------------
13568 double precision function sscale2(r,r_cut,r0,rlamb)
13570 double precision r,gamm,r_cut,r0,rlamb,rr
13572 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13573 c write (2,*) "rr",rr
13574 if(rr.lt.r_cut-rlamb) then
13576 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13577 gamm=(rr-(r_cut-rlamb))/rlamb
13578 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13584 C-----------------------------------------------------------------------
13585 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13587 double precision r,gamm,r_cut,r0,rlamb,rr
13589 if(rr.lt.r_cut-rlamb) then
13591 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13592 gamm=(rr-(r_cut-rlamb))/rlamb
13594 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13596 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb