1 subroutine etotal(energia)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
13 double precision time00
16 include 'COMMON.SETUP'
17 include 'COMMON.IOUNITS'
18 double precision energia(0:n_ene)
19 include 'COMMON.LOCAL'
20 include 'COMMON.FFIELD'
21 include 'COMMON.DERIV'
22 include 'COMMON.INTERACT'
23 include 'COMMON.SBRIDGE'
24 include 'COMMON.CHAIN'
27 include 'COMMON.QRESTR'
28 include 'COMMON.CONTROL'
29 include 'COMMON.TIME1'
30 include 'COMMON.SPLITELE'
31 include 'COMMON.TORCNSTR'
34 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
35 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
36 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
37 & eliptran,Eafmforce,Etube,
38 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
39 integer n_corr,n_corr1
41 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
42 c & " nfgtasks",nfgtasks
43 if (nfgtasks.gt.1) then
45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
46 if (fg_rank.eq.0) then
47 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
48 c print *,"Processor",myrank," BROADCAST iorder"
49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
50 C FG slaves as WEIGHTS array.
73 weights_(28)=wdfa_dist
76 weights_(31)=wdfa_beta
77 C FG Master broadcasts the WEIGHTS_ array
78 call MPI_Bcast(weights_(1),n_ene,
79 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
81 C FG slaves receive the WEIGHTS array
82 call MPI_Bcast(weights(1),n_ene,
83 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
106 wdfa_dist=weights_(28)
107 wdfa_tor=weights_(29)
108 wdfa_nei=weights_(30)
109 wdfa_beta=weights_(31)
111 time_Bcast=time_Bcast+MPI_Wtime()-time00
112 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
113 c call chainbuild_cart
115 if (nfgtasks.gt.1) then
116 call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
118 c write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
119 if (mod(itime_mat,imatupdate).eq.0) then
120 call make_SCp_inter_list
121 call make_SCSC_inter_list
122 call make_pp_inter_list
123 call make_pp_vdw_inter_list
125 c print *,'Processor',myrank,' calling etotal ipot=',ipot
126 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
128 c if (modecalc.eq.12.or.modecalc.eq.14) then
129 c call int_from_cart1(.false.)
143 C Compute the side-chain and electrostatic interaction energy
146 goto (101,102,103,104,105,106) ipot
147 C Lennard-Jones potential.
149 cd print '(a)','Exit ELJ'
151 C Lennard-Jones-Kihara potential (shifted).
154 C Berne-Pechukas potential (dilated LJ, angular dependence).
157 C Gay-Berne potential (shifted LJ, angular dependence).
159 C print *,"bylem w egb"
161 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
164 C Soft-sphere potential
165 106 call e_softsphere(evdw)
167 C Calculate electrostatic (H-bonding) energy of the main chain.
171 C BARTEK for dfa test!
172 if (wdfa_dist.gt.0) then
177 c print*, 'edfad is finished!', edfadis
178 if (wdfa_tor.gt.0) then
183 c print*, 'edfat is finished!', edfator
184 if (wdfa_nei.gt.0) then
189 c print*, 'edfan is finished!', edfanei
190 if (wdfa_beta.gt.0) then
197 cmc Sep-06: egb takes care of dynamic ss bonds too
199 c if (dyn_ss) call dyn_set_nss
201 c print *,"Processor",myrank," computed USCSC"
207 time_vec=time_vec+MPI_Wtime()-time01
209 C Introduction of shielding effect first for each peptide group
210 C the shielding factor is set this factor is describing how each
211 C peptide group is shielded by side-chains
212 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
213 C write (iout,*) "shield_mode",shield_mode
214 if (shield_mode.eq.1) then
216 else if (shield_mode.eq.2) then
219 c print *,"Processor",myrank," left VEC_AND_DERIV"
222 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
223 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
224 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
225 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
227 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
228 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
229 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
230 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
232 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
241 write (iout,*) "Soft-spheer ELEC potential"
242 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
246 c time_enecalc=time_enecalc+MPI_Wtime()-time00
248 c print *,"Processor",myrank," computed UELEC"
250 C Calculate excluded-volume interaction energy between peptide groups
255 call escp(evdw2,evdw2_14)
261 c write (iout,*) "Soft-sphere SCP potential"
262 call escp_soft_sphere(evdw2,evdw2_14)
265 c Calculate the bond-stretching energy
269 C Calculate the disulfide-bridge and other energy and the contributions
270 C from other distance constraints.
271 cd write (iout,*) 'Calling EHPB'
273 cd print *,'EHPB exitted succesfully.'
275 C Calculate the virtual-bond-angle energy.
277 if (wang.gt.0d0) then
278 if (tor_mode.eq.0) then
281 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
289 if (with_theta_constr) call etheta_constr(ethetacnstr)
290 c print *,"Processor",myrank," computed UB"
292 C Calculate the SC local energy.
294 C print *,"TU DOCHODZE?"
296 c print *,"Processor",myrank," computed USC"
298 C Calculate the virtual-bond torsional energy.
300 cd print *,'nterm=',nterm
301 C print *,"tor",tor_mode
302 if (wtor.gt.0.0d0) then
303 if (tor_mode.eq.0) then
306 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
314 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
315 c print *,"Processor",myrank," computed Utor"
316 if (constr_homology.ge.1) then
317 call e_modeller(ehomology_constr)
318 c print *,'iset=',iset,'me=',me,ehomology_constr,
319 c & 'Processor',fg_rank,' CG group',kolor,
320 c & ' absolute rank',MyRank
322 ehomology_constr=0.0d0
325 C 6/23/01 Calculate double-torsional energy
327 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
332 c print *,"Processor",myrank," computed Utord"
334 C 21/5/07 Calculate local sicdechain correlation energy
336 if (wsccor.gt.0.0d0) then
337 call eback_sc_corr(esccor)
342 C print *,"PRZED MULIt"
343 c print *,"Processor",myrank," computed Usccorr"
345 C 12/1/95 Multi-body terms
349 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
350 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
351 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
352 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
353 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
361 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
362 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
365 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
366 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
371 c print *,"Processor",myrank," computed Ucorr"
372 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
373 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
374 call e_saxs(Esaxs_constr)
375 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
376 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
377 call e_saxsC(Esaxs_constr)
378 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
383 C If performing constraint dynamics, call the constraint energy
384 C after the equilibration time
385 c if(usampl.and.totT.gt.eq_time) then
386 c write (iout,*) "usampl",usampl
390 call Econstr_back_qlike
398 C 01/27/2015 added by adasko
399 C the energy component below is energy transfer into lipid environment
400 C based on partition function
401 C print *,"przed lipidami"
402 if (wliptran.gt.0) then
403 call Eliptransfer(eliptran)
407 C print *,"za lipidami"
408 if (AFMlog.gt.0) then
409 call AFMforce(Eafmforce)
410 else if (selfguide.gt.0) then
411 call AFMvel(Eafmforce)
413 if (TUBElog.eq.1) then
414 C print *,"just before call"
416 elseif (TUBElog.eq.2) then
417 call calctube2(Etube)
423 time_enecalc=time_enecalc+MPI_Wtime()-time00
425 c print *,"Processor",myrank," computed Uconstr"
434 energia(2)=evdw2-evdw2_14
451 energia(8)=eello_turn3
452 energia(9)=eello_turn4
459 energia(19)=edihcnstr
461 energia(20)=Uconst+Uconst_back
464 energia(23)=Eafmforce
465 energia(24)=ethetacnstr
467 energia(26)=Esaxs_constr
468 energia(27)=ehomology_constr
473 c write (iout,*) "esaxs_constr",energia(26)
474 c Here are the energies showed per procesor if the are more processors
475 c per molecule then we sum it up in sum_energy subroutine
476 c print *," Processor",myrank," calls SUM_ENERGY"
477 call sum_energy(energia,.true.)
478 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
479 if (dyn_ss) call dyn_set_nss
480 c print *," Processor",myrank," left SUM_ENERGY"
482 time_sumene=time_sumene+MPI_Wtime()-time00
486 c-------------------------------------------------------------------------------
487 subroutine sum_energy(energia,reduce)
493 cMS$ATTRIBUTES C :: proc_proc
499 double precision time00
501 include 'COMMON.SETUP'
502 include 'COMMON.IOUNITS'
503 double precision energia(0:n_ene),enebuff(0:n_ene+1)
504 include 'COMMON.FFIELD'
505 include 'COMMON.DERIV'
506 include 'COMMON.INTERACT'
507 include 'COMMON.SBRIDGE'
508 include 'COMMON.CHAIN'
510 include 'COMMON.CONTROL'
511 include 'COMMON.TIME1'
514 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
515 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
516 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
517 & eliptran,Eafmforce,Etube,
518 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
519 double precision Uconst,etot
521 if (nfgtasks.gt.1 .and. reduce) then
523 write (iout,*) "energies before REDUCE"
524 call enerprint(energia)
528 enebuff(i)=energia(i)
531 call MPI_Barrier(FG_COMM,IERR)
532 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
534 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
535 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
537 write (iout,*) "energies after REDUCE"
538 call enerprint(energia)
541 time_Reduce=time_Reduce+MPI_Wtime()-time00
543 if (fg_rank.eq.0) then
547 evdw2=energia(2)+energia(18)
563 eello_turn3=energia(8)
564 eello_turn4=energia(9)
571 edihcnstr=energia(19)
576 Eafmforce=energia(23)
577 ethetacnstr=energia(24)
579 esaxs_constr=energia(26)
580 ehomology_constr=energia(27)
586 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
587 & +wang*ebe+wtor*etors+wscloc*escloc
588 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
589 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
590 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
591 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
592 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
593 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
596 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
597 & +wang*ebe+wtor*etors+wscloc*escloc
598 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
599 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
600 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
601 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
603 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
604 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
611 if (isnan(etot).ne.0) energia(0)=1.0d+99
613 if (isnan(etot)) energia(0)=1.0d+99
618 idumm=proc_proc(etot,i)
620 call proc_proc(etot,i)
622 if(i.eq.1)energia(0)=1.0d+99
629 c-------------------------------------------------------------------------------
630 subroutine sum_gradient
636 cMS$ATTRIBUTES C :: proc_proc
642 double precision time00,time01
644 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
645 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
646 & ,gloc_scbuf(3,-1:maxres)
647 include 'COMMON.SETUP'
648 include 'COMMON.IOUNITS'
649 include 'COMMON.FFIELD'
650 include 'COMMON.DERIV'
651 include 'COMMON.INTERACT'
652 include 'COMMON.SBRIDGE'
653 include 'COMMON.CHAIN'
655 include 'COMMON.CONTROL'
656 include 'COMMON.TIME1'
657 include 'COMMON.MAXGRAD'
658 include 'COMMON.SCCOR'
659 c include 'COMMON.MD'
660 include 'COMMON.QRESTR'
662 double precision scalar
663 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
664 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
665 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
666 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
667 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
673 write (iout,*) "sum_gradient gvdwc, gvdwx"
675 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
676 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
681 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
683 write (iout,'(i3,3e15.5,5x,3e15.5)')
684 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
689 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
690 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
691 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
694 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
695 C in virtual-bond-vector coordinates
698 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
700 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
701 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
703 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
705 c write (iout,'(i5,3f10.5,2x,f10.5)')
706 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
708 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
710 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
711 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
717 write (iout,*) "gsaxsc"
719 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
726 gradbufc(j,i)=wsc*gvdwc(j,i)+
727 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
728 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
729 & wel_loc*gel_loc_long(j,i)+
730 & wcorr*gradcorr_long(j,i)+
731 & wcorr5*gradcorr5_long(j,i)+
732 & wcorr6*gradcorr6_long(j,i)+
733 & wturn6*gcorr6_turn_long(j,i)+
735 & +wliptran*gliptranc(j,i)
737 & +welec*gshieldc(j,i)
738 & +wcorr*gshieldc_ec(j,i)
739 & +wturn3*gshieldc_t3(j,i)
740 & +wturn4*gshieldc_t4(j,i)
741 & +wel_loc*gshieldc_ll(j,i)
742 & +wtube*gg_tube(j,i)
749 gradbufc(j,i)=wsc*gvdwc(j,i)+
750 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
751 & welec*gelc_long(j,i)+
753 & wel_loc*gel_loc_long(j,i)+
754 & wcorr*gradcorr_long(j,i)+
755 & wcorr5*gradcorr5_long(j,i)+
756 & wcorr6*gradcorr6_long(j,i)+
757 & wturn6*gcorr6_turn_long(j,i)+
759 & +wliptran*gliptranc(j,i)
761 & +welec*gshieldc(j,i)
762 & +wcorr*gshieldc_ec(j,i)
763 & +wturn4*gshieldc_t4(j,i)
764 & +wel_loc*gshieldc_ll(j,i)
765 & +wtube*gg_tube(j,i)
772 gradbufc(j,i)=gradbufc(j,i)+
773 & wdfa_dist*gdfad(j,i)+
774 & wdfa_tor*gdfat(j,i)+
775 & wdfa_nei*gdfan(j,i)+
776 & wdfa_beta*gdfab(j,i)
780 write (iout,*) "gradc from gradbufc"
782 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
787 if (nfgtasks.gt.1) then
790 write (iout,*) "gradbufc before allreduce"
792 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
798 gradbufc_sum(j,i)=gradbufc(j,i)
801 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
802 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
803 c time_reduce=time_reduce+MPI_Wtime()-time00
805 c write (iout,*) "gradbufc_sum after allreduce"
807 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
812 c time_allreduce=time_allreduce+MPI_Wtime()-time00
820 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
821 write (iout,*) (i," jgrad_start",jgrad_start(i),
822 & " jgrad_end ",jgrad_end(i),
823 & i=igrad_start,igrad_end)
826 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
827 c do not parallelize this part.
829 c do i=igrad_start,igrad_end
830 c do j=jgrad_start(i),jgrad_end(i)
832 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
837 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
841 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
845 write (iout,*) "gradbufc after summing"
847 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
854 write (iout,*) "gradbufc"
856 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
862 gradbufc_sum(j,i)=gradbufc(j,i)
867 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
871 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
876 c gradbufc(k,i)=0.0d0
880 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
885 write (iout,*) "gradbufc after summing"
887 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
895 gradbufc(k,nres)=0.0d0
900 C print *,gradbufc(1,13)
901 C print *,welec*gelc(1,13)
902 C print *,wel_loc*gel_loc(1,13)
903 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
904 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
905 C print *,wel_loc*gel_loc_long(1,13)
906 C print *,gradafm(1,13),"AFM"
907 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
908 & wel_loc*gel_loc(j,i)+
909 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
910 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
911 & wel_loc*gel_loc_long(j,i)+
912 & wcorr*gradcorr_long(j,i)+
913 & wcorr5*gradcorr5_long(j,i)+
914 & wcorr6*gradcorr6_long(j,i)+
915 & wturn6*gcorr6_turn_long(j,i))+
917 & wcorr*gradcorr(j,i)+
918 & wturn3*gcorr3_turn(j,i)+
919 & wturn4*gcorr4_turn(j,i)+
920 & wcorr5*gradcorr5(j,i)+
921 & wcorr6*gradcorr6(j,i)+
922 & wturn6*gcorr6_turn(j,i)+
923 & wsccor*gsccorc(j,i)
924 & +wscloc*gscloc(j,i)
925 & +wliptran*gliptranc(j,i)
927 & +welec*gshieldc(j,i)
928 & +welec*gshieldc_loc(j,i)
929 & +wcorr*gshieldc_ec(j,i)
930 & +wcorr*gshieldc_loc_ec(j,i)
931 & +wturn3*gshieldc_t3(j,i)
932 & +wturn3*gshieldc_loc_t3(j,i)
933 & +wturn4*gshieldc_t4(j,i)
934 & +wturn4*gshieldc_loc_t4(j,i)
935 & +wel_loc*gshieldc_ll(j,i)
936 & +wel_loc*gshieldc_loc_ll(j,i)
937 & +wtube*gg_tube(j,i)
940 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
941 & wel_loc*gel_loc(j,i)+
942 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
943 & welec*gelc_long(j,i)+
944 & wel_loc*gel_loc_long(j,i)+
945 & wcorr*gcorr_long(j,i)+
946 & wcorr5*gradcorr5_long(j,i)+
947 & wcorr6*gradcorr6_long(j,i)+
948 & wturn6*gcorr6_turn_long(j,i))+
950 & wcorr*gradcorr(j,i)+
951 & wturn3*gcorr3_turn(j,i)+
952 & wturn4*gcorr4_turn(j,i)+
953 & wcorr5*gradcorr5(j,i)+
954 & wcorr6*gradcorr6(j,i)+
955 & wturn6*gcorr6_turn(j,i)+
956 & wsccor*gsccorc(j,i)
957 & +wscloc*gscloc(j,i)
958 & +wliptran*gliptranc(j,i)
960 & +welec*gshieldc(j,i)
961 & +welec*gshieldc_loc(j,i)
962 & +wcorr*gshieldc_ec(j,i)
963 & +wcorr*gshieldc_loc_ec(j,i)
964 & +wturn3*gshieldc_t3(j,i)
965 & +wturn3*gshieldc_loc_t3(j,i)
966 & +wturn4*gshieldc_t4(j,i)
967 & +wturn4*gshieldc_loc_t4(j,i)
968 & +wel_loc*gshieldc_ll(j,i)
969 & +wel_loc*gshieldc_loc_ll(j,i)
970 & +wtube*gg_tube(j,i)
974 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
976 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
977 & wsccor*gsccorx(j,i)
978 & +wscloc*gsclocx(j,i)
979 & +wliptran*gliptranx(j,i)
980 & +welec*gshieldx(j,i)
981 & +wcorr*gshieldx_ec(j,i)
982 & +wturn3*gshieldx_t3(j,i)
983 & +wturn4*gshieldx_t4(j,i)
984 & +wel_loc*gshieldx_ll(j,i)
985 & +wtube*gg_tube_sc(j,i)
992 if (constr_homology.gt.0) then
995 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
996 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1001 write (iout,*) "gradc gradx gloc after adding"
1003 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1004 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1008 write (iout,*) "gloc before adding corr"
1010 write (iout,*) i,gloc(i,icg)
1014 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1015 & +wcorr5*g_corr5_loc(i)
1016 & +wcorr6*g_corr6_loc(i)
1017 & +wturn4*gel_loc_turn4(i)
1018 & +wturn3*gel_loc_turn3(i)
1019 & +wturn6*gel_loc_turn6(i)
1020 & +wel_loc*gel_loc_loc(i)
1023 write (iout,*) "gloc after adding corr"
1025 write (iout,*) i,gloc(i,icg)
1029 if (nfgtasks.gt.1) then
1032 gradbufc(j,i)=gradc(j,i,icg)
1033 gradbufx(j,i)=gradx(j,i,icg)
1037 glocbuf(i)=gloc(i,icg)
1041 write (iout,*) "gloc_sc before reduce"
1044 write (iout,*) i,j,gloc_sc(j,i,icg)
1051 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1055 call MPI_Barrier(FG_COMM,IERR)
1056 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1058 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1059 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1060 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1061 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1062 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1063 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1064 time_reduce=time_reduce+MPI_Wtime()-time00
1065 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1066 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1067 time_reduce=time_reduce+MPI_Wtime()-time00
1069 write (iout,*) "gradc after reduce"
1072 write (iout,*) i,j,gradc(j,i,icg)
1077 write (iout,*) "gloc_sc after reduce"
1080 write (iout,*) i,j,gloc_sc(j,i,icg)
1085 write (iout,*) "gloc after reduce"
1087 write (iout,*) i,gloc(i,icg)
1092 if (gnorm_check) then
1094 c Compute the maximum elements of the gradient
1104 gcorr3_turn_max=0.0d0
1105 gcorr4_turn_max=0.0d0
1108 gcorr6_turn_max=0.0d0
1118 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1119 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1120 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1121 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1122 & gvdwc_scp_max=gvdwc_scp_norm
1123 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1124 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1125 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1126 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1127 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1128 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1129 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1130 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1131 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1132 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1133 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1134 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1135 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1136 & gcorr3_turn(1,i)))
1137 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1138 & gcorr3_turn_max=gcorr3_turn_norm
1139 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1140 & gcorr4_turn(1,i)))
1141 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1142 & gcorr4_turn_max=gcorr4_turn_norm
1143 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1144 if (gradcorr5_norm.gt.gradcorr5_max)
1145 & gradcorr5_max=gradcorr5_norm
1146 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1147 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1148 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1149 & gcorr6_turn(1,i)))
1150 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1151 & gcorr6_turn_max=gcorr6_turn_norm
1152 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1153 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1154 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1155 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1156 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1157 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1158 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1159 if (gradx_scp_norm.gt.gradx_scp_max)
1160 & gradx_scp_max=gradx_scp_norm
1161 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1162 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1163 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1164 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1165 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1166 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1167 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1168 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1171 #if (defined AIX || defined CRAY)
1172 open(istat,file=statname,position="append")
1174 open(istat,file=statname,access="append")
1176 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1177 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1178 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1179 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1180 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1181 & gsccorrx_max,gsclocx_max
1183 if (gvdwc_max.gt.1.0d4) then
1184 write (iout,*) "gvdwc gvdwx gradb gradbx"
1186 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1187 & gradb(j,i),gradbx(j,i),j=1,3)
1189 call pdbout(0.0d0,'cipiszcze',iout)
1195 write (iout,*) "gradc gradx gloc"
1197 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1198 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1202 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1206 c-------------------------------------------------------------------------------
1207 subroutine rescale_weights(t_bath)
1213 include 'DIMENSIONS'
1214 include 'COMMON.IOUNITS'
1215 include 'COMMON.FFIELD'
1216 include 'COMMON.SBRIDGE'
1217 include 'COMMON.CONTROL'
1218 double precision t_bath
1219 double precision facT,facT2,facT3,facT4,facT5
1220 double precision kfac /2.4d0/
1221 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1223 c facT=2*temp0/(t_bath+temp0)
1224 if (rescale_mode.eq.0) then
1230 else if (rescale_mode.eq.1) then
1231 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1232 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1233 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1234 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1235 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1236 else if (rescale_mode.eq.2) then
1242 facT=licznik/dlog(dexp(x)+dexp(-x))
1243 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1244 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1245 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1246 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1248 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1249 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1251 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1255 if (shield_mode.gt.0) then
1256 wscp=weights(2)*fact
1258 wvdwpp=weights(16)*fact
1260 welec=weights(3)*fact
1261 wcorr=weights(4)*fact3
1262 wcorr5=weights(5)*fact4
1263 wcorr6=weights(6)*fact5
1264 wel_loc=weights(7)*fact2
1265 wturn3=weights(8)*fact2
1266 wturn4=weights(9)*fact3
1267 wturn6=weights(10)*fact5
1268 wtor=weights(13)*fact
1269 wtor_d=weights(14)*fact2
1270 wsccor=weights(21)*fact
1271 if (scale_umb) wumb=t_bath/temp0
1272 c write (iout,*) "scale_umb",scale_umb
1273 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1277 C------------------------------------------------------------------------
1278 subroutine enerprint(energia)
1280 include 'DIMENSIONS'
1281 include 'COMMON.IOUNITS'
1282 include 'COMMON.FFIELD'
1283 include 'COMMON.SBRIDGE'
1284 include 'COMMON.QRESTR'
1285 double precision energia(0:n_ene)
1286 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1287 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1288 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1290 & eliptran,Eafmforce,Etube,
1291 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1296 evdw2=energia(2)+energia(18)
1308 eello_turn3=energia(8)
1309 eello_turn4=energia(9)
1310 eello_turn6=energia(10)
1316 edihcnstr=energia(19)
1320 eliptran=energia(22)
1321 Eafmforce=energia(23)
1322 ethetacnstr=energia(24)
1325 ehomology_constr=energia(27)
1327 edfadis = energia(28)
1328 edfator = energia(29)
1329 edfanei = energia(30)
1330 edfabet = energia(31)
1332 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1333 & estr,wbond,ebe,wang,
1334 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1337 & ecorr5,wcorr5,ecorr6,wcorr6,
1339 & eel_loc,wel_loc,eello_turn3,wturn3,
1340 & eello_turn4,wturn4,
1342 & eello_turn6,wturn6,
1344 & esccor,wsccor,edihcnstr,
1345 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1346 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1347 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1348 & edfabet,wdfa_beta,
1350 10 format (/'Virtual-chain energies:'//
1351 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1352 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1353 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1354 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1355 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1356 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1357 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1358 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1359 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1360 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1361 & ' (SS bridges & dist. cnstr.)'/
1363 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1364 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1365 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1367 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1368 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1369 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1371 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1373 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1374 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1375 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1376 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1377 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1378 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1379 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1380 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1381 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1382 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1383 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1384 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1385 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1386 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1387 & 'ETOT= ',1pE16.6,' (total)')
1390 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1391 & estr,wbond,ebe,wang,
1392 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1395 & ecorr5,wcorr5,ecorr6,wcorr6,
1397 & eel_loc,wel_loc,eello_turn3,wturn3,
1398 & eello_turn4,wturn4,
1400 & eello_turn6,wturn6,
1402 & esccor,wsccor,edihcnstr,
1403 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1404 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1405 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1406 & edfabet,wdfa_beta,
1408 10 format (/'Virtual-chain energies:'//
1409 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1410 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1411 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1412 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1413 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1414 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1415 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1416 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1417 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1418 & ' (SS bridges & dist. restr.)'/
1420 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1421 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1422 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1424 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1425 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1426 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1428 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1430 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1431 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1432 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1433 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1434 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1435 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1436 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1437 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1438 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1439 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1440 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1441 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1442 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1443 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1444 & 'ETOT= ',1pE16.6,' (total)')
1448 C-----------------------------------------------------------------------
1449 subroutine elj(evdw)
1451 C This subroutine calculates the interaction energy of nonbonded side chains
1452 C assuming the LJ potential of interaction.
1455 double precision accur
1456 include 'DIMENSIONS'
1457 parameter (accur=1.0d-10)
1458 include 'COMMON.GEO'
1459 include 'COMMON.VAR'
1460 include 'COMMON.LOCAL'
1461 include 'COMMON.CHAIN'
1462 include 'COMMON.DERIV'
1463 include 'COMMON.INTERACT'
1464 include 'COMMON.TORSION'
1465 include 'COMMON.SBRIDGE'
1466 include 'COMMON.NAMES'
1467 include 'COMMON.IOUNITS'
1468 include 'COMMON.SPLITELE'
1470 include 'COMMON.CONTACTS'
1471 include 'COMMON.CONTMAT'
1473 double precision gg(3)
1474 double precision evdw,evdwij
1475 integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1476 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1477 & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1478 double precision fcont,fprimcont
1479 double precision sscale,sscagrad
1480 double precision boxshift
1481 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1483 c do i=iatsc_s,iatsc_e
1484 do ikont=g_listscsc_start,g_listscsc_end
1485 i=newcontlisti(ikont)
1486 j=newcontlistj(ikont)
1487 itypi=iabs(itype(i))
1488 if (itypi.eq.ntyp1) cycle
1489 itypi1=iabs(itype(i+1))
1493 call to_box(xi,yi,zi)
1497 C Calculate SC interaction energy.
1499 c do iint=1,nint_gr(i)
1500 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1501 cd & 'iend=',iend(i,iint)
1502 c do j=istart(i,iint),iend(i,iint)
1503 itypj=iabs(itype(j))
1504 if (itypj.eq.ntyp1) cycle
1508 call to_box(xj,yj,zj)
1509 xj=boxshift(xj-xi,boxxsize)
1510 yj=boxshift(yj-yi,boxysize)
1511 zj=boxshift(zj-zi,boxzsize)
1512 C Change 12/1/95 to calculate four-body interactions
1513 rij=xj*xj+yj*yj+zj*zj
1516 sss1=sscale(sqrij,r_cut_int)
1517 if (sss1.eq.0.0d0) cycle
1518 sssgrad1=sscagrad(sqrij,r_cut_int)
1520 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1521 eps0ij=eps(itypi,itypj)
1523 C have you changed here?
1527 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1528 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1529 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1530 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1531 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1532 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1533 evdw=evdw+sss1*evdwij
1535 C Calculate the components of the gradient in DC and X
1537 fac=-rrij*(e1+evdwij)*sss1
1538 & +evdwij*sssgrad1/sqrij/expon
1543 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1544 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1545 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1546 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1550 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1555 C 12/1/95, revised on 5/20/97
1557 C Calculate the contact function. The ith column of the array JCONT will
1558 C contain the numbers of atoms that make contacts with the atom I (of numbers
1559 C greater than I). The arrays FACONT and GACONT will contain the values of
1560 C the contact function and its derivative.
1562 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1563 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1564 C Uncomment next line, if the correlation interactions are contact function only
1565 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1567 sigij=sigma(itypi,itypj)
1568 r0ij=rs0(itypi,itypj)
1570 C Check whether the SC's are not too far to make a contact.
1573 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1574 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1576 if (fcont.gt.0.0D0) then
1577 C If the SC-SC distance if close to sigma, apply spline.
1578 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1579 cAdam & fcont1,fprimcont1)
1580 cAdam fcont1=1.0d0-fcont1
1581 cAdam if (fcont1.gt.0.0d0) then
1582 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1583 cAdam fcont=fcont*fcont1
1585 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1586 cga eps0ij=1.0d0/dsqrt(eps0ij)
1588 cga gg(k)=gg(k)*eps0ij
1590 cga eps0ij=-evdwij*eps0ij
1591 C Uncomment for AL's type of SC correlation interactions.
1592 cadam eps0ij=-evdwij
1593 num_conti=num_conti+1
1594 jcont(num_conti,i)=j
1595 facont(num_conti,i)=fcont*eps0ij
1596 fprimcont=eps0ij*fprimcont/rij
1598 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1599 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1600 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1601 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1602 gacont(1,num_conti,i)=-fprimcont*xj
1603 gacont(2,num_conti,i)=-fprimcont*yj
1604 gacont(3,num_conti,i)=-fprimcont*zj
1605 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1606 cd write (iout,'(2i3,3f10.5)')
1607 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1615 num_cont(i)=num_conti
1620 gvdwc(j,i)=expon*gvdwc(j,i)
1621 gvdwx(j,i)=expon*gvdwx(j,i)
1624 C******************************************************************************
1628 C To save time, the factor of EXPON has been extracted from ALL components
1629 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1632 C******************************************************************************
1635 C-----------------------------------------------------------------------------
1636 subroutine eljk(evdw)
1638 C This subroutine calculates the interaction energy of nonbonded side chains
1639 C assuming the LJK potential of interaction.
1642 include 'DIMENSIONS'
1643 include 'COMMON.GEO'
1644 include 'COMMON.VAR'
1645 include 'COMMON.LOCAL'
1646 include 'COMMON.CHAIN'
1647 include 'COMMON.DERIV'
1648 include 'COMMON.INTERACT'
1649 include 'COMMON.IOUNITS'
1650 include 'COMMON.NAMES'
1651 include 'COMMON.SPLITELE'
1652 double precision gg(3)
1653 double precision evdw,evdwij
1654 integer i,j,k,itypi,itypj,itypi1,iint,ikont
1655 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1656 & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1658 double precision sscale,sscagrad
1659 double precision boxshift
1660 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1662 c do i=iatsc_s,iatsc_e
1663 do ikont=g_listscsc_start,g_listscsc_end
1664 i=newcontlisti(ikont)
1665 j=newcontlistj(ikont)
1666 itypi=iabs(itype(i))
1667 if (itypi.eq.ntyp1) cycle
1668 itypi1=iabs(itype(i+1))
1672 call to_box(xi,yi,zi)
1674 C Calculate SC interaction energy.
1676 c do iint=1,nint_gr(i)
1677 c do j=istart(i,iint),iend(i,iint)
1678 itypj=iabs(itype(j))
1679 if (itypj.eq.ntyp1) cycle
1683 call to_box(xj,yj,zj)
1684 xj=boxshift(xj-xi,boxxsize)
1685 yj=boxshift(yj-yi,boxysize)
1686 zj=boxshift(zj-zi,boxzsize)
1687 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1688 fac_augm=rrij**expon
1689 e_augm=augm(itypi,itypj)*fac_augm
1690 r_inv_ij=dsqrt(rrij)
1692 sss1=sscale(rij,r_cut_int)
1693 if (sss1.eq.0.0d0) cycle
1694 sssgrad1=sscagrad(rij,r_cut_int)
1695 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1696 fac=r_shift_inv**expon
1697 C have you changed here?
1701 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1702 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1703 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1704 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1705 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1706 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1707 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1708 evdw=evdw+evdwij*sss1
1710 C Calculate the components of the gradient in DC and X
1712 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1713 & +evdwij*sssgrad1*r_inv_ij/expon
1718 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1719 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1720 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1721 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1725 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1733 gvdwc(j,i)=expon*gvdwc(j,i)
1734 gvdwx(j,i)=expon*gvdwx(j,i)
1739 C-----------------------------------------------------------------------------
1740 subroutine ebp(evdw)
1742 C This subroutine calculates the interaction energy of nonbonded side chains
1743 C assuming the Berne-Pechukas potential of interaction.
1746 include 'DIMENSIONS'
1747 include 'COMMON.GEO'
1748 include 'COMMON.VAR'
1749 include 'COMMON.LOCAL'
1750 include 'COMMON.CHAIN'
1751 include 'COMMON.DERIV'
1752 include 'COMMON.NAMES'
1753 include 'COMMON.INTERACT'
1754 include 'COMMON.IOUNITS'
1755 include 'COMMON.CALC'
1756 include 'COMMON.SPLITELE'
1758 common /srutu/ icall
1759 double precision evdw
1760 integer itypi,itypj,itypi1,iint,ind,ikont
1761 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1763 double precision sscale,sscagrad
1764 double precision boxshift
1765 c double precision rrsave(maxdim)
1768 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1770 c if (icall.eq.0) then
1776 c do i=iatsc_s,iatsc_e
1777 do ikont=g_listscsc_start,g_listscsc_end
1778 i=newcontlisti(ikont)
1779 j=newcontlistj(ikont)
1780 itypi=iabs(itype(i))
1781 if (itypi.eq.ntyp1) cycle
1782 itypi1=iabs(itype(i+1))
1786 call to_box(xi,yi,zi)
1787 dxi=dc_norm(1,nres+i)
1788 dyi=dc_norm(2,nres+i)
1789 dzi=dc_norm(3,nres+i)
1790 c dsci_inv=dsc_inv(itypi)
1791 dsci_inv=vbld_inv(i+nres)
1793 C Calculate SC interaction energy.
1795 c do iint=1,nint_gr(i)
1796 c do j=istart(i,iint),iend(i,iint)
1798 itypj=iabs(itype(j))
1799 if (itypj.eq.ntyp1) cycle
1800 c dscj_inv=dsc_inv(itypj)
1801 dscj_inv=vbld_inv(j+nres)
1802 chi1=chi(itypi,itypj)
1803 chi2=chi(itypj,itypi)
1810 alf12=0.5D0*(alf1+alf2)
1811 C For diagnostics only!!!
1824 call to_box(xj,yj,zj)
1825 xj=boxshift(xj-xi,boxxsize)
1826 yj=boxshift(yj-yi,boxysize)
1827 zj=boxshift(zj-zi,boxzsize)
1828 dxj=dc_norm(1,nres+j)
1829 dyj=dc_norm(2,nres+j)
1830 dzj=dc_norm(3,nres+j)
1831 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1832 cd if (icall.eq.0) then
1838 sss1=sscale(1.0d0/rij,r_cut_int)
1839 if (sss1.eq.0.0d0) cycle
1840 sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1841 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1843 C Calculate whole angle-dependent part of epsilon and contributions
1844 C to its derivatives
1845 C have you changed here?
1846 fac=(rrij*sigsq)**expon2
1849 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1850 eps2der=evdwij*eps3rt
1851 eps3der=evdwij*eps2rt
1852 evdwij=evdwij*eps2rt*eps3rt
1853 evdw=evdw+sss1*evdwij
1855 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1857 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1858 cd & restyp(itypi),i,restyp(itypj),j,
1859 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1860 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1861 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1864 C Calculate gradient components.
1865 e1=e1*eps1*eps2rt**2*eps3rt**2
1866 fac=-expon*(e1+evdwij)
1869 & +evdwij*sssgrad1/sss1*rij
1870 C Calculate radial part of the gradient
1874 C Calculate the angular part of the gradient and sum add the contributions
1875 C to the appropriate components of the Cartesian gradient.
1883 C-----------------------------------------------------------------------------
1884 subroutine egb(evdw)
1886 C This subroutine calculates the interaction energy of nonbonded side chains
1887 C assuming the Gay-Berne potential of interaction.
1890 include 'DIMENSIONS'
1891 include 'COMMON.GEO'
1892 include 'COMMON.VAR'
1893 include 'COMMON.LOCAL'
1894 include 'COMMON.CHAIN'
1895 include 'COMMON.DERIV'
1896 include 'COMMON.NAMES'
1897 include 'COMMON.INTERACT'
1898 include 'COMMON.IOUNITS'
1899 include 'COMMON.CALC'
1900 include 'COMMON.CONTROL'
1901 include 'COMMON.SPLITELE'
1902 include 'COMMON.SBRIDGE'
1904 double precision evdw
1905 integer itypi,itypj,itypi1,iint,ind,ikont
1906 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1907 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1908 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1909 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1910 double precision boxshift
1912 ccccc energy_dec=.false.
1913 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1916 c if (icall.eq.0) lprn=.false.
1918 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1919 C we have the original box)
1923 c do i=iatsc_s,iatsc_e
1924 do ikont=g_listscsc_start,g_listscsc_end
1925 i=newcontlisti(ikont)
1926 j=newcontlistj(ikont)
1927 itypi=iabs(itype(i))
1928 if (itypi.eq.ntyp1) cycle
1929 itypi1=iabs(itype(i+1))
1933 call to_box(xi,yi,zi)
1934 C define scaling factor for lipids
1936 C if (positi.le.0) positi=positi+boxzsize
1938 C first for peptide groups
1939 c for each residue check if it is in lipid or lipid water border area
1940 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1941 C xi=xi+xshift*boxxsize
1942 C yi=yi+yshift*boxysize
1943 C zi=zi+zshift*boxzsize
1945 dxi=dc_norm(1,nres+i)
1946 dyi=dc_norm(2,nres+i)
1947 dzi=dc_norm(3,nres+i)
1948 c dsci_inv=dsc_inv(itypi)
1949 dsci_inv=vbld_inv(i+nres)
1950 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1951 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1953 C Calculate SC interaction energy.
1955 c do iint=1,nint_gr(i)
1956 c do j=istart(i,iint),iend(i,iint)
1957 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1959 c write(iout,*) "PRZED ZWYKLE", evdwij
1960 call dyn_ssbond_ene(i,j,evdwij)
1961 c write(iout,*) "PO ZWYKLE", evdwij
1964 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1965 & 'evdw',i,j,evdwij,' ss'
1966 C triple bond artifac removal
1967 do k=j+1,iend(i,iint)
1968 C search over all next residues
1969 if (dyn_ss_mask(k)) then
1970 C check if they are cysteins
1971 C write(iout,*) 'k=',k
1973 c write(iout,*) "PRZED TRI", evdwij
1974 evdwij_przed_tri=evdwij
1975 call triple_ssbond_ene(i,j,k,evdwij)
1976 c if(evdwij_przed_tri.ne.evdwij) then
1977 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1980 c write(iout,*) "PO TRI", evdwij
1981 C call the energy function that removes the artifical triple disulfide
1982 C bond the soubroutine is located in ssMD.F
1984 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1985 & 'evdw',i,j,evdwij,'tss'
1986 endif!dyn_ss_mask(k)
1990 itypj=iabs(itype(j))
1991 if (itypj.eq.ntyp1) cycle
1992 c dscj_inv=dsc_inv(itypj)
1993 dscj_inv=vbld_inv(j+nres)
1994 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1995 c & 1.0d0/vbld(j+nres)
1996 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1997 sig0ij=sigma(itypi,itypj)
1998 chi1=chi(itypi,itypj)
1999 chi2=chi(itypj,itypi)
2006 alf12=0.5D0*(alf1+alf2)
2007 C For diagnostics only!!!
2020 call to_box(xj,yj,zj)
2021 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2022 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2023 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2024 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2025 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2026 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2027 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2028 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2029 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2030 C print *,sslipi,sslipj,bordlipbot,zi,zj
2031 xj=boxshift(xj-xi,boxxsize)
2032 yj=boxshift(yj-yi,boxysize)
2033 zj=boxshift(zj-zi,boxzsize)
2034 dxj=dc_norm(1,nres+j)
2035 dyj=dc_norm(2,nres+j)
2036 dzj=dc_norm(3,nres+j)
2040 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2041 c write (iout,*) "j",j," dc_norm",
2042 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2043 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2045 sss=sscale(1.0d0/rij,r_cut_int)
2046 c write (iout,'(a7,4f8.3)')
2047 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2048 if (sss.eq.0.0d0) cycle
2049 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2050 C Calculate angle-dependent terms of energy and contributions to their
2054 sig=sig0ij*dsqrt(sigsq)
2055 rij_shift=1.0D0/rij-sig+sig0ij
2057 c & write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2058 c & " sig",sig," sig0ij",sig0ij
2059 c for diagnostics; uncomment
2060 c rij_shift=1.2*sig0ij
2061 C I hate to put IF's in the loops, but here don't have another choice!!!!
2062 if (rij_shift.le.0.0D0) then
2064 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2065 cd & restyp(itypi),i,restyp(itypj),j,
2066 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2070 c---------------------------------------------------------------
2071 rij_shift=1.0D0/rij_shift
2072 fac=rij_shift**expon
2073 C here to start with
2078 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2079 eps2der=evdwij*eps3rt
2080 eps3der=evdwij*eps2rt
2081 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2082 C &((sslipi+sslipj)/2.0d0+
2083 C &(2.0d0-sslipi-sslipj)/2.0d0)
2084 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2085 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2086 evdwij=evdwij*eps2rt*eps3rt
2087 evdw=evdw+evdwij*sss
2089 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2091 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2092 & restyp(itypi),i,restyp(itypj),j,
2093 & epsi,sigm,chi1,chi2,chip1,chip2,
2094 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2095 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2099 if (energy_dec) write (iout,'(a,2i5,2f10.5,e15.5)')
2100 & 'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2102 C Calculate gradient components.
2103 e1=e1*eps1*eps2rt**2*eps3rt**2
2104 fac=-expon*(e1+evdwij)*rij_shift
2107 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2108 c & evdwij,fac,sigma(itypi,itypj),expon
2109 fac=fac+evdwij*sssgrad/sss*rij
2111 C Calculate the radial part of the gradient
2112 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2113 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2114 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2115 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2116 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2117 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2123 C Calculate angular part of the gradient.
2124 c call sc_grad_scale(sss)
2133 c write (iout,*) "Number of loop steps in EGB:",ind
2134 cccc energy_dec=.false.
2137 C-----------------------------------------------------------------------------
2138 subroutine egbv(evdw)
2140 C This subroutine calculates the interaction energy of nonbonded side chains
2141 C assuming the Gay-Berne-Vorobjev potential of interaction.
2144 include 'DIMENSIONS'
2145 include 'COMMON.GEO'
2146 include 'COMMON.VAR'
2147 include 'COMMON.LOCAL'
2148 include 'COMMON.CHAIN'
2149 include 'COMMON.DERIV'
2150 include 'COMMON.NAMES'
2151 include 'COMMON.INTERACT'
2152 include 'COMMON.IOUNITS'
2153 include 'COMMON.CALC'
2154 include 'COMMON.SPLITELE'
2155 double precision boxshift
2157 common /srutu/ icall
2159 double precision evdw
2160 integer itypi,itypj,itypi1,iint,ind,ikont
2161 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2162 & xi,yi,zi,fac_augm,e_augm
2163 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2164 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2165 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2167 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2170 c if (icall.eq.0) lprn=.true.
2172 c do i=iatsc_s,iatsc_e
2173 do ikont=g_listscsc_start,g_listscsc_end
2174 i=newcontlisti(ikont)
2175 j=newcontlistj(ikont)
2176 itypi=iabs(itype(i))
2177 if (itypi.eq.ntyp1) cycle
2178 itypi1=iabs(itype(i+1))
2182 call to_box(xi,yi,zi)
2183 C define scaling factor for lipids
2185 C if (positi.le.0) positi=positi+boxzsize
2187 C first for peptide groups
2188 c for each residue check if it is in lipid or lipid water border area
2189 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2190 dxi=dc_norm(1,nres+i)
2191 dyi=dc_norm(2,nres+i)
2192 dzi=dc_norm(3,nres+i)
2193 c dsci_inv=dsc_inv(itypi)
2194 dsci_inv=vbld_inv(i+nres)
2196 C Calculate SC interaction energy.
2198 c do iint=1,nint_gr(i)
2199 c do j=istart(i,iint),iend(i,iint)
2201 itypj=iabs(itype(j))
2202 if (itypj.eq.ntyp1) cycle
2203 c dscj_inv=dsc_inv(itypj)
2204 dscj_inv=vbld_inv(j+nres)
2205 sig0ij=sigma(itypi,itypj)
2206 r0ij=r0(itypi,itypj)
2207 chi1=chi(itypi,itypj)
2208 chi2=chi(itypj,itypi)
2215 alf12=0.5D0*(alf1+alf2)
2216 C For diagnostics only!!!
2229 call to_box(xj,yj,zj)
2230 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2231 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2232 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2233 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2234 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2235 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2236 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2237 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2238 xj=boxshift(xj-xi,boxxsize)
2239 yj=boxshift(yj-yi,boxysize)
2240 zj=boxshift(zj-zi,boxzsize)
2241 dxj=dc_norm(1,nres+j)
2242 dyj=dc_norm(2,nres+j)
2243 dzj=dc_norm(3,nres+j)
2244 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2246 sss=sscale(1.0d0/rij,r_cut_int)
2247 if (sss.eq.0.0d0) cycle
2248 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2249 C Calculate angle-dependent terms of energy and contributions to their
2253 sig=sig0ij*dsqrt(sigsq)
2254 rij_shift=1.0D0/rij-sig+r0ij
2255 C I hate to put IF's in the loops, but here don't have another choice!!!!
2256 if (rij_shift.le.0.0D0) then
2261 c---------------------------------------------------------------
2262 rij_shift=1.0D0/rij_shift
2263 fac=rij_shift**expon
2266 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2267 eps2der=evdwij*eps3rt
2268 eps3der=evdwij*eps2rt
2269 fac_augm=rrij**expon
2270 e_augm=augm(itypi,itypj)*fac_augm
2271 evdwij=evdwij*eps2rt*eps3rt
2272 evdw=evdw+evdwij+e_augm
2274 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2276 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2277 & restyp(itypi),i,restyp(itypj),j,
2278 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2279 & chi1,chi2,chip1,chip2,
2280 & eps1,eps2rt**2,eps3rt**2,
2281 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2284 C Calculate gradient components.
2285 e1=e1*eps1*eps2rt**2*eps3rt**2
2286 fac=-expon*(e1+evdwij)*rij_shift
2288 fac=rij*fac-2*expon*rrij*e_augm
2289 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2290 C Calculate the radial part of the gradient
2294 C Calculate angular part of the gradient.
2295 c call sc_grad_scale(sss)
2301 C-----------------------------------------------------------------------------
2302 subroutine sc_angular
2303 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2304 C om12. Called by ebp, egb, and egbv.
2306 include 'COMMON.CALC'
2307 include 'COMMON.IOUNITS'
2311 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2312 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2313 om12=dxi*dxj+dyi*dyj+dzi*dzj
2315 C Calculate eps1(om12) and its derivative in om12
2316 faceps1=1.0D0-om12*chiom12
2317 faceps1_inv=1.0D0/faceps1
2318 eps1=dsqrt(faceps1_inv)
2319 C Following variable is eps1*deps1/dom12
2320 eps1_om12=faceps1_inv*chiom12
2325 c write (iout,*) "om12",om12," eps1",eps1
2326 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2331 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2332 sigsq=1.0D0-facsig*faceps1_inv
2333 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2334 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2335 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2341 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2342 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2344 C Calculate eps2 and its derivatives in om1, om2, and om12.
2347 chipom12=chip12*om12
2348 facp=1.0D0-om12*chipom12
2350 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2351 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2352 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2353 C Following variable is the square root of eps2
2354 eps2rt=1.0D0-facp1*facp_inv
2355 C Following three variables are the derivatives of the square root of eps
2356 C in om1, om2, and om12.
2357 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2358 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2359 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2360 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2361 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2362 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2363 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2364 c & " eps2rt_om12",eps2rt_om12
2365 C Calculate whole angle-dependent part of epsilon and contributions
2366 C to its derivatives
2369 C----------------------------------------------------------------------------
2371 implicit real*8 (a-h,o-z)
2372 include 'DIMENSIONS'
2373 include 'COMMON.CHAIN'
2374 include 'COMMON.DERIV'
2375 include 'COMMON.CALC'
2376 include 'COMMON.IOUNITS'
2377 double precision dcosom1(3),dcosom2(3)
2378 cc print *,'sss=',sss
2379 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2380 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2381 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2382 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2386 c eom12=evdwij*eps1_om12
2388 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2389 c & " sigder",sigder
2390 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2391 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2393 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2394 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2397 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2399 c write (iout,*) "gg",(gg(k),k=1,3)
2401 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2402 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2403 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2404 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2405 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2406 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2407 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2409 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2410 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2413 C Calculate the components of the gradient in DC and X
2417 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2421 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2422 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2426 C-----------------------------------------------------------------------
2427 subroutine e_softsphere(evdw)
2429 C This subroutine calculates the interaction energy of nonbonded side chains
2430 C assuming the LJ potential of interaction.
2432 implicit real*8 (a-h,o-z)
2433 include 'DIMENSIONS'
2434 parameter (accur=1.0d-10)
2435 include 'COMMON.GEO'
2436 include 'COMMON.VAR'
2437 include 'COMMON.LOCAL'
2438 include 'COMMON.CHAIN'
2439 include 'COMMON.DERIV'
2440 include 'COMMON.INTERACT'
2441 include 'COMMON.TORSION'
2442 include 'COMMON.SBRIDGE'
2443 include 'COMMON.NAMES'
2444 include 'COMMON.IOUNITS'
2445 c include 'COMMON.CONTACTS'
2447 double precision boxshift
2448 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2450 c do i=iatsc_s,iatsc_e
2451 do ikont=g_listscsc_start,g_listscsc_end
2452 i=newcontlisti(ikont)
2453 j=newcontlistj(ikont)
2454 itypi=iabs(itype(i))
2455 if (itypi.eq.ntyp1) cycle
2456 itypi1=iabs(itype(i+1))
2460 call to_box(xi,yi,zi)
2462 C Calculate SC interaction energy.
2464 c do iint=1,nint_gr(i)
2465 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd & 'iend=',iend(i,iint)
2467 c do j=istart(i,iint),iend(i,iint)
2468 itypj=iabs(itype(j))
2469 if (itypj.eq.ntyp1) cycle
2470 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2471 yj=boxshift(c(2,nres+j)-yi,boxysize)
2472 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2473 rij=xj*xj+yj*yj+zj*zj
2474 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475 r0ij=r0(itypi,itypj)
2477 c print *,i,j,r0ij,dsqrt(rij)
2478 if (rij.lt.r0ijsq) then
2479 evdwij=0.25d0*(rij-r0ijsq)**2
2487 C Calculate the components of the gradient in DC and X
2493 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2500 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2508 C--------------------------------------------------------------------------
2509 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2512 C Soft-sphere potential of p-p interaction
2514 implicit real*8 (a-h,o-z)
2515 include 'DIMENSIONS'
2516 include 'COMMON.CONTROL'
2517 include 'COMMON.IOUNITS'
2518 include 'COMMON.GEO'
2519 include 'COMMON.VAR'
2520 include 'COMMON.LOCAL'
2521 include 'COMMON.CHAIN'
2522 include 'COMMON.DERIV'
2523 include 'COMMON.INTERACT'
2524 c include 'COMMON.CONTACTS'
2525 include 'COMMON.TORSION'
2526 include 'COMMON.VECTORS'
2527 include 'COMMON.FFIELD'
2529 double precision boxshift
2530 C write(iout,*) 'In EELEC_soft_sphere'
2537 do i=iatel_s,iatel_e
2538 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2542 xmedi=c(1,i)+0.5d0*dxi
2543 ymedi=c(2,i)+0.5d0*dyi
2544 zmedi=c(3,i)+0.5d0*dzi
2545 call to_box(xmedi,ymedi,zmedi)
2547 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2548 do j=ielstart(i),ielend(i)
2549 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2553 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2554 r0ij=rpp(iteli,itelj)
2562 call to_box(xj,yj,zj)
2563 xj=boxshift(xj-xmedi,boxxsize)
2564 yj=boxshift(yj-ymedi,boxysize)
2565 zj=boxshift(zj-zmedi,boxzsize)
2566 rij=xj*xj+yj*yj+zj*zj
2567 sss=sscale(sqrt(rij),r_cut_int)
2568 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2569 if (rij.lt.r0ijsq) then
2570 evdw1ij=0.25d0*(rij-r0ijsq)**2
2576 evdw1=evdw1+evdw1ij*sss
2578 C Calculate contributions to the Cartesian gradient.
2580 ggg(1)=fac*xj*sssgrad
2581 ggg(2)=fac*yj*sssgrad
2582 ggg(3)=fac*zj*sssgrad
2584 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2585 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2588 * Loop over residues i+1 thru j-1.
2592 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2597 cgrad do i=nnt,nct-1
2599 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2601 cgrad do j=i+1,nct-1
2603 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2609 c------------------------------------------------------------------------------
2610 subroutine vec_and_deriv
2611 implicit real*8 (a-h,o-z)
2612 include 'DIMENSIONS'
2616 include 'COMMON.IOUNITS'
2617 include 'COMMON.GEO'
2618 include 'COMMON.VAR'
2619 include 'COMMON.LOCAL'
2620 include 'COMMON.CHAIN'
2621 include 'COMMON.VECTORS'
2622 include 'COMMON.SETUP'
2623 include 'COMMON.TIME1'
2624 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2625 C Compute the local reference systems. For reference system (i), the
2626 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2627 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2629 do i=ivec_start,ivec_end
2633 if (i.eq.nres-1) then
2634 C Case of the last full residue
2635 C Compute the Z-axis
2636 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2637 costh=dcos(pi-theta(nres))
2638 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2642 C Compute the derivatives of uz
2644 uzder(2,1,1)=-dc_norm(3,i-1)
2645 uzder(3,1,1)= dc_norm(2,i-1)
2646 uzder(1,2,1)= dc_norm(3,i-1)
2648 uzder(3,2,1)=-dc_norm(1,i-1)
2649 uzder(1,3,1)=-dc_norm(2,i-1)
2650 uzder(2,3,1)= dc_norm(1,i-1)
2653 uzder(2,1,2)= dc_norm(3,i)
2654 uzder(3,1,2)=-dc_norm(2,i)
2655 uzder(1,2,2)=-dc_norm(3,i)
2657 uzder(3,2,2)= dc_norm(1,i)
2658 uzder(1,3,2)= dc_norm(2,i)
2659 uzder(2,3,2)=-dc_norm(1,i)
2661 C Compute the Y-axis
2664 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2666 C Compute the derivatives of uy
2669 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2670 & -dc_norm(k,i)*dc_norm(j,i-1)
2671 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2673 uyder(j,j,1)=uyder(j,j,1)-costh
2674 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2679 uygrad(l,k,j,i)=uyder(l,k,j)
2680 uzgrad(l,k,j,i)=uzder(l,k,j)
2684 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2685 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2686 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2687 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2690 C Compute the Z-axis
2691 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2692 costh=dcos(pi-theta(i+2))
2693 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2697 C Compute the derivatives of uz
2699 uzder(2,1,1)=-dc_norm(3,i+1)
2700 uzder(3,1,1)= dc_norm(2,i+1)
2701 uzder(1,2,1)= dc_norm(3,i+1)
2703 uzder(3,2,1)=-dc_norm(1,i+1)
2704 uzder(1,3,1)=-dc_norm(2,i+1)
2705 uzder(2,3,1)= dc_norm(1,i+1)
2708 uzder(2,1,2)= dc_norm(3,i)
2709 uzder(3,1,2)=-dc_norm(2,i)
2710 uzder(1,2,2)=-dc_norm(3,i)
2712 uzder(3,2,2)= dc_norm(1,i)
2713 uzder(1,3,2)= dc_norm(2,i)
2714 uzder(2,3,2)=-dc_norm(1,i)
2716 C Compute the Y-axis
2719 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2721 C Compute the derivatives of uy
2724 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2725 & -dc_norm(k,i)*dc_norm(j,i+1)
2726 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2728 uyder(j,j,1)=uyder(j,j,1)-costh
2729 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2734 uygrad(l,k,j,i)=uyder(l,k,j)
2735 uzgrad(l,k,j,i)=uzder(l,k,j)
2739 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2740 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2741 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2742 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2746 vbld_inv_temp(1)=vbld_inv(i+1)
2747 if (i.lt.nres-1) then
2748 vbld_inv_temp(2)=vbld_inv(i+2)
2750 vbld_inv_temp(2)=vbld_inv(i)
2755 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2756 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2761 #if defined(PARVEC) && defined(MPI)
2762 if (nfgtasks1.gt.1) then
2764 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2765 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2766 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2767 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2768 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2770 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2771 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2773 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2774 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2775 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2776 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2777 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2778 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2779 time_gather=time_gather+MPI_Wtime()-time00
2783 if (fg_rank.eq.0) then
2784 write (iout,*) "Arrays UY and UZ"
2786 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2793 C--------------------------------------------------------------------------
2794 subroutine set_matrices
2795 implicit real*8 (a-h,o-z)
2796 include 'DIMENSIONS'
2799 include "COMMON.SETUP"
2801 integer status(MPI_STATUS_SIZE)
2803 include 'COMMON.IOUNITS'
2804 include 'COMMON.GEO'
2805 include 'COMMON.VAR'
2806 include 'COMMON.LOCAL'
2807 include 'COMMON.CHAIN'
2808 include 'COMMON.DERIV'
2809 include 'COMMON.INTERACT'
2810 include 'COMMON.CORRMAT'
2811 include 'COMMON.TORSION'
2812 include 'COMMON.VECTORS'
2813 include 'COMMON.FFIELD'
2814 double precision auxvec(2),auxmat(2,2)
2816 C Compute the virtual-bond-torsional-angle dependent quantities needed
2817 C to calculate the el-loc multibody terms of various order.
2819 c write(iout,*) 'nphi=',nphi,nres
2820 c write(iout,*) "itype2loc",itype2loc
2822 do i=ivec_start+2,ivec_end+2
2827 c write (iout,*) "i",i,i-2," ii",ii
2829 innt=chain_border(1,ii)
2830 inct=chain_border(2,ii)
2831 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2832 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2833 if (i.gt. innt+2 .and. i.lt.inct+2) then
2834 iti = itype2loc(itype(i-2))
2838 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2839 if (i.gt. innt+1 .and. i.lt.inct+1) then
2840 iti1 = itype2loc(itype(i-1))
2844 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2845 c & " iti1",itype(i-1),iti1
2847 cost1=dcos(theta(i-1))
2848 sint1=dsin(theta(i-1))
2850 sint1cub=sint1sq*sint1
2851 sint1cost1=2*sint1*cost1
2852 c write (iout,*) "bnew1",i,iti
2853 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2854 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2855 c write (iout,*) "bnew2",i,iti
2856 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2857 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2859 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2861 gtb1(k,i-2)=cost1*b1k-sint1sq*
2862 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2863 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2865 gtb2(k,i-2)=cost1*b2k-sint1sq*
2866 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2869 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2870 cc(1,k,i-2)=sint1sq*aux
2871 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2872 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2873 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2874 dd(1,k,i-2)=sint1sq*aux
2875 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2876 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2878 cc(2,1,i-2)=cc(1,2,i-2)
2879 cc(2,2,i-2)=-cc(1,1,i-2)
2880 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2881 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2882 dd(2,1,i-2)=dd(1,2,i-2)
2883 dd(2,2,i-2)=-dd(1,1,i-2)
2884 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2885 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2888 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2889 EE(l,k,i-2)=sint1sq*aux
2890 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2893 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2894 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2895 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2896 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2897 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2898 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2899 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2900 c b1tilde(1,i-2)=b1(1,i-2)
2901 c b1tilde(2,i-2)=-b1(2,i-2)
2902 c b2tilde(1,i-2)=b2(1,i-2)
2903 c b2tilde(2,i-2)=-b2(2,i-2)
2905 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2906 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2907 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2908 write (iout,*) 'theta=', theta(i-1)
2911 if (i.gt. innt+2 .and. i.lt.inct+2) then
2912 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2913 iti = itype2loc(itype(i-2))
2917 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2918 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2919 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2920 iti1 = itype2loc(itype(i-1))
2930 CC(k,l,i-2)=ccold(k,l,iti)
2931 DD(k,l,i-2)=ddold(k,l,iti)
2932 EE(k,l,i-2)=eeold(k,l,iti)
2937 b1tilde(1,i-2)= b1(1,i-2)
2938 b1tilde(2,i-2)=-b1(2,i-2)
2939 b2tilde(1,i-2)= b2(1,i-2)
2940 b2tilde(2,i-2)=-b2(2,i-2)
2942 Ctilde(1,1,i-2)= CC(1,1,i-2)
2943 Ctilde(1,2,i-2)= CC(1,2,i-2)
2944 Ctilde(2,1,i-2)=-CC(2,1,i-2)
2945 Ctilde(2,2,i-2)=-CC(2,2,i-2)
2947 Dtilde(1,1,i-2)= DD(1,1,i-2)
2948 Dtilde(1,2,i-2)= DD(1,2,i-2)
2949 Dtilde(2,1,i-2)=-DD(2,1,i-2)
2950 Dtilde(2,2,i-2)=-DD(2,2,i-2)
2952 write(iout,*) "i",i," iti",iti
2953 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2954 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2959 do i=ivec_start+2,ivec_end+2
2963 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2964 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3002 obrot_der(1,i-2)=-sin1
3003 obrot_der(2,i-2)= cos1
3004 Ugder(1,1,i-2)= sin1
3005 Ugder(1,2,i-2)=-cos1
3006 Ugder(2,1,i-2)=-cos1
3007 Ugder(2,2,i-2)=-sin1
3010 obrot2_der(1,i-2)=-dwasin2
3011 obrot2_der(2,i-2)= dwacos2
3012 Ug2der(1,1,i-2)= dwasin2
3013 Ug2der(1,2,i-2)=-dwacos2
3014 Ug2der(2,1,i-2)=-dwacos2
3015 Ug2der(2,2,i-2)=-dwasin2
3017 obrot_der(1,i-2)=0.0d0
3018 obrot_der(2,i-2)=0.0d0
3019 Ugder(1,1,i-2)=0.0d0
3020 Ugder(1,2,i-2)=0.0d0
3021 Ugder(2,1,i-2)=0.0d0
3022 Ugder(2,2,i-2)=0.0d0
3023 obrot2_der(1,i-2)=0.0d0
3024 obrot2_der(2,i-2)=0.0d0
3025 Ug2der(1,1,i-2)=0.0d0
3026 Ug2der(1,2,i-2)=0.0d0
3027 Ug2der(2,1,i-2)=0.0d0
3028 Ug2der(2,2,i-2)=0.0d0
3030 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3031 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3032 if (i.gt.nnt+2 .and.i.lt.nct+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. nnt+1 .and. i.lt.nct+1) then
3039 iti1 = itype2loc(itype(i-1))
3043 cd write (iout,*) '*******i',i,' iti1',iti
3044 cd write (iout,*) 'b1',b1(:,iti)
3045 cd write (iout,*) 'b2',b2(:,iti)
3046 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3047 c if (i .gt. iatel_s+2) then
3048 if (i .gt. nnt+2) then
3049 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3051 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3052 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3054 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3055 c & EE(1,2,iti),EE(2,2,i)
3056 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3057 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3058 c write(iout,*) "Macierz EUG",
3059 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3062 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3064 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3065 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3066 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3067 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3068 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3080 DtUg2(l,k,i-2)=0.0d0
3084 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3085 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3087 muder(k,i-2)=Ub2der(k,i-2)
3089 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3090 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3091 if (itype(i-1).le.ntyp) then
3092 iti1 = itype2loc(itype(i-1))
3100 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3101 c mu(k,i-2)=b1(k,i-1)
3102 c mu(k,i-2)=Ub2(k,i-2)
3105 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3106 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3107 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3108 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3109 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3110 & ((ee(l,k,i-2),l=1,2),k=1,2)
3112 cd write (iout,*) 'mu1',mu1(:,i-2)
3113 cd write (iout,*) 'mu2',mu2(:,i-2)
3114 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3116 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3118 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3119 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3120 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3121 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3122 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3123 C Vectors and matrices dependent on a single virtual-bond dihedral.
3124 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3125 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3126 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3127 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3128 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3129 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3130 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3131 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3132 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3137 C Matrices dependent on two consecutive virtual-bond dihedrals.
3138 C The order of matrices is from left to right.
3139 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3141 c do i=max0(ivec_start,2),ivec_end
3143 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3144 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3145 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3146 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3147 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3148 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3149 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3150 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3154 #if defined(MPI) && defined(PARMAT)
3156 c if (fg_rank.eq.0) then
3157 write (iout,*) "Arrays UG and UGDER before GATHER"
3159 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3160 & ((ug(l,k,i),l=1,2),k=1,2),
3161 & ((ugder(l,k,i),l=1,2),k=1,2)
3163 write (iout,*) "Arrays UG2 and UG2DER"
3165 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3166 & ((ug2(l,k,i),l=1,2),k=1,2),
3167 & ((ug2der(l,k,i),l=1,2),k=1,2)
3169 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3171 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3172 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3173 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3175 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3177 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3178 & costab(i),sintab(i),costab2(i),sintab2(i)
3180 write (iout,*) "Array MUDER"
3182 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3186 if (nfgtasks.gt.1) then
3188 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3189 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3190 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3192 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3193 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3195 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3196 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3198 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3199 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3201 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3202 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3204 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3205 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3207 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3208 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3210 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3211 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3212 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3213 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3214 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3215 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3216 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3217 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3218 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3219 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3220 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3221 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3223 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3225 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3226 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3228 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3229 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3231 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3232 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3234 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3235 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3237 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3238 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3240 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3241 & ivec_count(fg_rank1),
3242 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3244 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3245 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3247 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3248 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3250 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3251 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3253 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3254 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3256 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3257 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3259 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3260 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3262 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3263 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3265 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3266 & ivec_count(fg_rank1),
3267 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3269 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3270 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3272 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3273 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3275 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3276 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3279 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3282 & ivec_count(fg_rank1),
3283 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3285 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3286 & ivec_count(fg_rank1),
3287 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3289 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3290 & ivec_count(fg_rank1),
3291 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3292 & MPI_MAT2,FG_COMM1,IERR)
3293 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3294 & ivec_count(fg_rank1),
3295 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3296 & MPI_MAT2,FG_COMM1,IERR)
3300 c Passes matrix info through the ring
3303 if (irecv.lt.0) irecv=nfgtasks1-1
3306 if (inext.ge.nfgtasks1) inext=0
3308 c write (iout,*) "isend",isend," irecv",irecv
3310 lensend=lentyp(isend)
3311 lenrecv=lentyp(irecv)
3312 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3313 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3314 c & MPI_ROTAT1(lensend),inext,2200+isend,
3315 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3316 c & iprev,2200+irecv,FG_COMM,status,IERR)
3317 c write (iout,*) "Gather ROTAT1"
3319 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3320 c & MPI_ROTAT2(lensend),inext,3300+isend,
3321 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3322 c & iprev,3300+irecv,FG_COMM,status,IERR)
3323 c write (iout,*) "Gather ROTAT2"
3325 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3326 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3327 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3328 & iprev,4400+irecv,FG_COMM,status,IERR)
3329 c write (iout,*) "Gather ROTAT_OLD"
3331 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3332 & MPI_PRECOMP11(lensend),inext,5500+isend,
3333 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3334 & iprev,5500+irecv,FG_COMM,status,IERR)
3335 c write (iout,*) "Gather PRECOMP11"
3337 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3338 & MPI_PRECOMP12(lensend),inext,6600+isend,
3339 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3340 & iprev,6600+irecv,FG_COMM,status,IERR)
3341 c write (iout,*) "Gather PRECOMP12"
3344 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3346 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3347 & MPI_ROTAT2(lensend),inext,7700+isend,
3348 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3349 & iprev,7700+irecv,FG_COMM,status,IERR)
3350 c write (iout,*) "Gather PRECOMP21"
3352 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3353 & MPI_PRECOMP22(lensend),inext,8800+isend,
3354 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3355 & iprev,8800+irecv,FG_COMM,status,IERR)
3356 c write (iout,*) "Gather PRECOMP22"
3358 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3359 & MPI_PRECOMP23(lensend),inext,9900+isend,
3360 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3361 & MPI_PRECOMP23(lenrecv),
3362 & iprev,9900+irecv,FG_COMM,status,IERR)
3364 c write (iout,*) "Gather PRECOMP23"
3369 if (irecv.lt.0) irecv=nfgtasks1-1
3372 time_gather=time_gather+MPI_Wtime()-time00
3375 c if (fg_rank.eq.0) then
3376 write (iout,*) "Arrays UG and UGDER"
3378 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3379 & ((ug(l,k,i),l=1,2),k=1,2),
3380 & ((ugder(l,k,i),l=1,2),k=1,2)
3382 write (iout,*) "Arrays UG2 and UG2DER"
3384 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3385 & ((ug2(l,k,i),l=1,2),k=1,2),
3386 & ((ug2der(l,k,i),l=1,2),k=1,2)
3388 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3390 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3391 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3392 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3394 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3396 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3397 & costab(i),sintab(i),costab2(i),sintab2(i)
3399 write (iout,*) "Array MUDER"
3401 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3407 cd iti = itype2loc(itype(i))
3410 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3411 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3416 C-----------------------------------------------------------------------------
3417 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3419 C This subroutine calculates the average interaction energy and its gradient
3420 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3421 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3422 C The potential depends both on the distance of peptide-group centers and on
3423 C the orientation of the CA-CA virtual bonds.
3425 implicit real*8 (a-h,o-z)
3429 include 'DIMENSIONS'
3430 include 'COMMON.CONTROL'
3431 include 'COMMON.SETUP'
3432 include 'COMMON.IOUNITS'
3433 include 'COMMON.GEO'
3434 include 'COMMON.VAR'
3435 include 'COMMON.LOCAL'
3436 include 'COMMON.CHAIN'
3437 include 'COMMON.DERIV'
3438 include 'COMMON.INTERACT'
3440 include 'COMMON.CONTACTS'
3441 include 'COMMON.CONTMAT'
3443 include 'COMMON.CORRMAT'
3444 include 'COMMON.TORSION'
3445 include 'COMMON.VECTORS'
3446 include 'COMMON.FFIELD'
3447 include 'COMMON.TIME1'
3448 include 'COMMON.SPLITELE'
3449 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3450 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3451 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3452 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3453 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3454 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3456 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3458 double precision scal_el /1.0d0/
3460 double precision scal_el /0.5d0/
3463 C 13-go grudnia roku pamietnego...
3464 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3465 & 0.0d0,1.0d0,0.0d0,
3466 & 0.0d0,0.0d0,1.0d0/
3467 cd write(iout,*) 'In EELEC'
3469 cd write(iout,*) 'Type',i
3470 cd write(iout,*) 'B1',B1(:,i)
3471 cd write(iout,*) 'B2',B2(:,i)
3472 cd write(iout,*) 'CC',CC(:,:,i)
3473 cd write(iout,*) 'DD',DD(:,:,i)
3474 cd write(iout,*) 'EE',EE(:,:,i)
3476 cd call check_vecgrad
3478 if (icheckgrad.eq.1) then
3480 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3482 dc_norm(k,i)=dc(k,i)*fac
3484 c write (iout,*) 'i',i,' fac',fac
3487 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3488 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3489 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3490 c call vec_and_deriv
3496 time_mat=time_mat+MPI_Wtime()-time01
3500 cd write (iout,*) 'i=',i
3502 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3505 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3506 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3521 cd print '(a)','Enter EELEC'
3522 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3524 gel_loc_loc(i)=0.0d0
3529 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3531 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3533 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3534 do i=iturn3_start,iturn3_end
3536 C write(iout,*) "tu jest i",i
3537 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3538 C changes suggested by Ana to avoid out of bounds
3539 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3540 c & .or.((i+4).gt.nres)
3541 c & .or.((i-1).le.0)
3542 C end of changes by Ana
3543 & .or. itype(i+2).eq.ntyp1
3544 & .or. itype(i+3).eq.ntyp1) cycle
3545 C Adam: Instructions below will switch off existing interactions
3547 c if(itype(i-1).eq.ntyp1)cycle
3549 c if(i.LT.nres-3)then
3550 c if (itype(i+4).eq.ntyp1) cycle
3555 dx_normi=dc_norm(1,i)
3556 dy_normi=dc_norm(2,i)
3557 dz_normi=dc_norm(3,i)
3558 xmedi=c(1,i)+0.5d0*dxi
3559 ymedi=c(2,i)+0.5d0*dyi
3560 zmedi=c(3,i)+0.5d0*dzi
3561 call to_box(xmedi,ymedi,zmedi)
3563 call eelecij(i,i+2,ees,evdw1,eel_loc)
3564 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3566 num_cont_hb(i)=num_conti
3569 do i=iturn4_start,iturn4_end
3571 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3572 C changes suggested by Ana to avoid out of bounds
3573 c & .or.((i+5).gt.nres)
3574 c & .or.((i-1).le.0)
3575 C end of changes suggested by Ana
3576 & .or. itype(i+3).eq.ntyp1
3577 & .or. itype(i+4).eq.ntyp1
3578 c & .or. itype(i+5).eq.ntyp1
3579 c & .or. itype(i).eq.ntyp1
3580 c & .or. itype(i-1).eq.ntyp1
3585 dx_normi=dc_norm(1,i)
3586 dy_normi=dc_norm(2,i)
3587 dz_normi=dc_norm(3,i)
3588 xmedi=c(1,i)+0.5d0*dxi
3589 ymedi=c(2,i)+0.5d0*dyi
3590 zmedi=c(3,i)+0.5d0*dzi
3591 C Return atom into box, boxxsize is size of box in x dimension
3593 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3594 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3595 C Condition for being inside the proper box
3596 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3597 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3601 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3602 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3603 C Condition for being inside the proper box
3604 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3605 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3609 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3610 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3611 C Condition for being inside the proper box
3612 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3613 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3616 call to_box(xmedi,ymedi,zmedi)
3618 num_conti=num_cont_hb(i)
3620 c write(iout,*) "JESTEM W PETLI"
3621 call eelecij(i,i+3,ees,evdw1,eel_loc)
3622 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3623 & call eturn4(i,eello_turn4)
3625 num_cont_hb(i)=num_conti
3628 C Loop over all neighbouring boxes
3633 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3636 c do i=iatel_s,iatel_e
3637 do ikont=g_listpp_start,g_listpp_end
3638 i=newcontlistppi(ikont)
3639 j=newcontlistppj(ikont)
3642 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3643 C changes suggested by Ana to avoid out of bounds
3644 c & .or.((i+2).gt.nres)
3645 c & .or.((i-1).le.0)
3646 C end of changes by Ana
3647 c & .or. itype(i+2).eq.ntyp1
3648 c & .or. itype(i-1).eq.ntyp1
3653 dx_normi=dc_norm(1,i)
3654 dy_normi=dc_norm(2,i)
3655 dz_normi=dc_norm(3,i)
3656 xmedi=c(1,i)+0.5d0*dxi
3657 ymedi=c(2,i)+0.5d0*dyi
3658 zmedi=c(3,i)+0.5d0*dzi
3659 call to_box(xmedi,ymedi,zmedi)
3660 C xmedi=xmedi+xshift*boxxsize
3661 C ymedi=ymedi+yshift*boxysize
3662 C zmedi=zmedi+zshift*boxzsize
3664 C Return tom into box, boxxsize is size of box in x dimension
3666 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3667 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3668 C Condition for being inside the proper box
3669 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3670 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3674 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3675 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3676 C Condition for being inside the proper box
3677 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3678 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3682 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3683 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3684 cC Condition for being inside the proper box
3685 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3686 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3690 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3692 num_conti=num_cont_hb(i)
3695 c do j=ielstart(i),ielend(i)
3697 C write (iout,*) i,j
3699 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3700 C changes suggested by Ana to avoid out of bounds
3701 c & .or.((j+2).gt.nres)
3702 c & .or.((j-1).le.0)
3703 C end of changes by Ana
3704 c & .or.itype(j+2).eq.ntyp1
3705 c & .or.itype(j-1).eq.ntyp1
3707 call eelecij(i,j,ees,evdw1,eel_loc)
3710 num_cont_hb(i)=num_conti
3717 c write (iout,*) "Number of loop steps in EELEC:",ind
3719 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3720 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3722 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3723 ccc eel_loc=eel_loc+eello_turn3
3724 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3727 C-------------------------------------------------------------------------------
3728 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3730 include 'DIMENSIONS'
3734 include 'COMMON.CONTROL'
3735 include 'COMMON.IOUNITS'
3736 include 'COMMON.GEO'
3737 include 'COMMON.VAR'
3738 include 'COMMON.LOCAL'
3739 include 'COMMON.CHAIN'
3740 include 'COMMON.DERIV'
3741 include 'COMMON.INTERACT'
3743 include 'COMMON.CONTACTS'
3744 include 'COMMON.CONTMAT'
3746 include 'COMMON.CORRMAT'
3747 include 'COMMON.TORSION'
3748 include 'COMMON.VECTORS'
3749 include 'COMMON.FFIELD'
3750 include 'COMMON.TIME1'
3751 include 'COMMON.SPLITELE'
3752 include 'COMMON.SHIELD'
3753 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3754 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3755 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3756 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3757 & gmuij2(4),gmuji2(4)
3758 double precision dxi,dyi,dzi
3759 double precision dx_normi,dy_normi,dz_normi,aux
3760 integer j1,j2,lll,num_conti
3761 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3762 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3764 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3765 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3766 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3767 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3768 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3769 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3770 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3771 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3772 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3773 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3774 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3775 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3776 double precision xmedi,ymedi,zmedi
3777 double precision sscale,sscagrad,scalar
3778 double precision boxshift
3779 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3781 double precision scal_el /1.0d0/
3783 double precision scal_el /0.5d0/
3786 C 13-go grudnia roku pamietnego...
3787 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3788 & 0.0d0,1.0d0,0.0d0,
3789 & 0.0d0,0.0d0,1.0d0/
3790 c time00=MPI_Wtime()
3791 cd write (iout,*) "eelecij",i,j
3795 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3796 aaa=app(iteli,itelj)
3797 bbb=bpp(iteli,itelj)
3798 ael6i=ael6(iteli,itelj)
3799 ael3i=ael3(iteli,itelj)
3803 dx_normj=dc_norm(1,j)
3804 dy_normj=dc_norm(2,j)
3805 dz_normj=dc_norm(3,j)
3806 C xj=c(1,j)+0.5D0*dxj-xmedi
3807 C yj=c(2,j)+0.5D0*dyj-ymedi
3808 C zj=c(3,j)+0.5D0*dzj-zmedi
3812 call to_box(xj,yj,zj)
3813 xj=boxshift(xj-xmedi,boxxsize)
3814 yj=boxshift(yj-ymedi,boxysize)
3815 zj=boxshift(zj-zmedi,boxzsize)
3816 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3818 rij=xj*xj+yj*yj+zj*zj
3820 sss=sscale(dsqrt(rij),r_cut_int)
3821 if (sss.eq.0.0d0) return
3822 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3823 c if (sss.gt.0.0d0) then
3829 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3830 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3831 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3832 fac=cosa-3.0D0*cosb*cosg
3834 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3835 if (j.eq.i+2) ev1=scal_el*ev1
3840 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3844 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3845 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3846 if (shield_mode.gt.0) then
3849 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3850 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3859 evdw1=evdw1+evdwij*sss
3860 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3861 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3862 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3863 cd & xmedi,ymedi,zmedi,xj,yj,zj
3865 if (energy_dec) then
3866 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3867 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3868 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3869 & fac_shield(i),fac_shield(j)
3873 C Calculate contributions to the Cartesian gradient.
3876 facvdw=-6*rrmij*(ev1+evdwij)*sss
3877 facel=-3*rrmij*(el1+eesij)
3884 * Radial derivatives. First process both termini of the fragment (i,j)
3886 aux=facel*sss+rmij*sssgrad*eesij
3890 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3891 & (shield_mode.gt.0)) then
3893 do ilist=1,ishield_list(i)
3894 iresshield=shield_list(ilist,i)
3896 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3898 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3900 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3901 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3902 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3903 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3904 C if (iresshield.gt.i) then
3905 C do ishi=i+1,iresshield-1
3906 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3907 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3911 C do ishi=iresshield,i
3912 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3913 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3919 do ilist=1,ishield_list(j)
3920 iresshield=shield_list(ilist,j)
3922 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3924 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3926 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3927 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3929 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3930 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3931 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3932 C if (iresshield.gt.j) then
3933 C do ishi=j+1,iresshield-1
3934 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3935 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3939 C do ishi=iresshield,j
3940 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3941 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3948 gshieldc(k,i)=gshieldc(k,i)+
3949 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3950 gshieldc(k,j)=gshieldc(k,j)+
3951 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3952 gshieldc(k,i-1)=gshieldc(k,i-1)+
3953 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3954 gshieldc(k,j-1)=gshieldc(k,j-1)+
3955 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3960 c ghalf=0.5D0*ggg(k)
3961 c gelc(k,i)=gelc(k,i)+ghalf
3962 c gelc(k,j)=gelc(k,j)+ghalf
3964 c 9/28/08 AL Gradient compotents will be summed only at the end
3965 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3967 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3968 C & +grad_shield(k,j)*eesij/fac_shield(j)
3969 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3970 C & +grad_shield(k,i)*eesij/fac_shield(i)
3971 C gelc_long(k,i-1)=gelc_long(k,i-1)
3972 C & +grad_shield(k,i)*eesij/fac_shield(i)
3973 C gelc_long(k,j-1)=gelc_long(k,j-1)
3974 C & +grad_shield(k,j)*eesij/fac_shield(j)
3976 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3979 * Loop over residues i+1 thru j-1.
3983 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3986 facvdw=facvdw+sssgrad*rmij*evdwij
3991 c ghalf=0.5D0*ggg(k)
3992 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3993 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3995 c 9/28/08 AL Gradient compotents will be summed only at the end
3997 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3998 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4001 * Loop over residues i+1 thru j-1.
4005 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4013 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4014 & +(evdwij+eesij)*sssgrad*rrmij
4019 * Radial derivatives. First process both termini of the fragment (i,j)
4022 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4024 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4026 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4028 c ghalf=0.5D0*ggg(k)
4029 c gelc(k,i)=gelc(k,i)+ghalf
4030 c gelc(k,j)=gelc(k,j)+ghalf
4032 c 9/28/08 AL Gradient compotents will be summed only at the end
4034 gelc_long(k,j)=gelc(k,j)+ggg(k)
4035 gelc_long(k,i)=gelc(k,i)-ggg(k)
4038 * Loop over residues i+1 thru j-1.
4042 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4045 c 9/28/08 AL Gradient compotents will be summed only at the end
4046 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4047 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4048 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4050 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4051 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4057 ecosa=2.0D0*fac3*fac1+fac4
4060 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4061 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4063 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4064 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4066 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4067 cd & (dcosg(k),k=1,3)
4069 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4070 & fac_shield(i)**2*fac_shield(j)**2*sss
4073 c ghalf=0.5D0*ggg(k)
4074 c gelc(k,i)=gelc(k,i)+ghalf
4075 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4076 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4077 c gelc(k,j)=gelc(k,j)+ghalf
4078 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4079 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4083 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4086 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4089 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4090 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4091 & *fac_shield(i)**2*fac_shield(j)**2
4093 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4094 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4095 & *fac_shield(i)**2*fac_shield(j)**2
4096 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4097 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4099 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4103 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4104 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4105 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4107 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4108 C energy of a peptide unit is assumed in the form of a second-order
4109 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4110 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4111 C are computed for EVERY pair of non-contiguous peptide groups.
4114 if (j.lt.nres-1) then
4126 muij(kkk)=mu(k,i)*mu(l,j)
4127 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4129 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4130 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4131 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4132 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4133 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4134 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4139 write (iout,*) 'EELEC: i',i,' j',j
4140 write (iout,*) 'j',j,' j1',j1,' j2',j2
4141 write(iout,*) 'muij',muij
4143 ury=scalar(uy(1,i),erij)
4144 urz=scalar(uz(1,i),erij)
4145 vry=scalar(uy(1,j),erij)
4146 vrz=scalar(uz(1,j),erij)
4147 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4148 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4149 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4150 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4151 fac=dsqrt(-ael6i)*r3ij
4153 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4154 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4155 & "uyvz",scalar(uy(1,i),uz(1,j)),
4156 & "uzvy",scalar(uz(1,i),uy(1,j)),
4157 & "uzvz",scalar(uz(1,i),uz(1,j))
4158 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4159 write (iout,*) "fac",fac
4166 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4169 cd write (iout,'(4i5,4f10.5)')
4170 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4171 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4172 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4173 cd & uy(:,j),uz(:,j)
4174 cd write (iout,'(4f10.5)')
4175 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4176 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4177 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4178 cd write (iout,'(9f10.5/)')
4179 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4180 C Derivatives of the elements of A in virtual-bond vectors
4181 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4183 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4184 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4185 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4186 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4187 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4188 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4189 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4190 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4191 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4192 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4193 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4194 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4196 C Compute radial contributions to the gradient
4214 C Add the contributions coming from er
4217 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4218 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4219 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4220 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4223 C Derivatives in DC(i)
4224 cgrad ghalf1=0.5d0*agg(k,1)
4225 cgrad ghalf2=0.5d0*agg(k,2)
4226 cgrad ghalf3=0.5d0*agg(k,3)
4227 cgrad ghalf4=0.5d0*agg(k,4)
4228 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4229 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4230 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4231 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4232 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4233 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4234 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4235 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4236 C Derivatives in DC(i+1)
4237 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4238 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4239 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4240 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4241 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4242 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4243 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4244 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4245 C Derivatives in DC(j)
4246 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4247 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4248 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4249 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4250 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4251 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4252 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4253 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4254 C Derivatives in DC(j+1) or DC(nres-1)
4255 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4256 & -3.0d0*vryg(k,3)*ury)
4257 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4258 & -3.0d0*vrzg(k,3)*ury)
4259 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4260 & -3.0d0*vryg(k,3)*urz)
4261 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4262 & -3.0d0*vrzg(k,3)*urz)
4263 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4265 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4278 aggi(k,l)=-aggi(k,l)
4279 aggi1(k,l)=-aggi1(k,l)
4280 aggj(k,l)=-aggj(k,l)
4281 aggj1(k,l)=-aggj1(k,l)
4284 if (j.lt.nres-1) then
4290 aggi(k,l)=-aggi(k,l)
4291 aggi1(k,l)=-aggi1(k,l)
4292 aggj(k,l)=-aggj(k,l)
4293 aggj1(k,l)=-aggj1(k,l)
4304 aggi(k,l)=-aggi(k,l)
4305 aggi1(k,l)=-aggi1(k,l)
4306 aggj(k,l)=-aggj(k,l)
4307 aggj1(k,l)=-aggj1(k,l)
4312 IF (wel_loc.gt.0.0d0) THEN
4313 C Contribution to the local-electrostatic energy coming from the i-j pair
4314 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4317 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4319 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4320 & " wel_loc",wel_loc
4322 if (shield_mode.eq.0) then
4329 eel_loc_ij=eel_loc_ij
4330 & *fac_shield(i)*fac_shield(j)*sss
4331 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4332 c & 'eelloc',i,j,eel_loc_ij
4333 C Now derivative over eel_loc
4334 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4335 & (shield_mode.gt.0)) then
4338 do ilist=1,ishield_list(i)
4339 iresshield=shield_list(ilist,i)
4341 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4344 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4346 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4347 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4351 do ilist=1,ishield_list(j)
4352 iresshield=shield_list(ilist,j)
4354 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4357 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4359 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4360 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4367 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4368 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4369 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4370 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4371 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4372 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4373 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4374 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4379 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4380 c & ' eel_loc_ij',eel_loc_ij
4381 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4382 C Calculate patrial derivative for theta angle
4384 geel_loc_ij=(a22*gmuij1(1)
4388 & *fac_shield(i)*fac_shield(j)*sss
4389 c write(iout,*) "derivative over thatai"
4390 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4392 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4393 & geel_loc_ij*wel_loc
4394 c write(iout,*) "derivative over thatai-1"
4395 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4402 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4403 & geel_loc_ij*wel_loc
4404 & *fac_shield(i)*fac_shield(j)*sss
4406 c Derivative over j residue
4407 geel_loc_ji=a22*gmuji1(1)
4411 c write(iout,*) "derivative over thataj"
4412 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4415 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4416 & geel_loc_ji*wel_loc
4417 & *fac_shield(i)*fac_shield(j)*sss
4424 c write(iout,*) "derivative over thataj-1"
4425 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4427 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4428 & geel_loc_ji*wel_loc
4429 & *fac_shield(i)*fac_shield(j)*sss
4431 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4433 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4434 & 'eelloc',i,j,eel_loc_ij
4435 c if (eel_loc_ij.ne.0)
4436 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4437 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4439 eel_loc=eel_loc+eel_loc_ij
4440 C Partial derivatives in virtual-bond dihedral angles gamma
4442 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4443 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4444 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4445 & *fac_shield(i)*fac_shield(j)*sss
4447 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4448 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4449 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4450 & *fac_shield(i)*fac_shield(j)*sss
4451 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4452 aux=eel_loc_ij/sss*sssgrad*rmij
4457 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4458 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4459 & *fac_shield(i)*fac_shield(j)*sss
4460 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4461 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4462 cgrad ghalf=0.5d0*ggg(l)
4463 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4464 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4468 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4471 C Remaining derivatives of eello
4473 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4474 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4475 & *fac_shield(i)*fac_shield(j)*sss
4477 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4478 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4479 & *fac_shield(i)*fac_shield(j)*sss
4481 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4482 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4483 & *fac_shield(i)*fac_shield(j)*sss
4485 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4486 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4487 & *fac_shield(i)*fac_shield(j)*sss
4491 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4492 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4494 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4495 & .and. num_conti.le.maxconts) then
4496 c write (iout,*) i,j," entered corr"
4498 C Calculate the contact function. The ith column of the array JCONT will
4499 C contain the numbers of atoms that make contacts with the atom I (of numbers
4500 C greater than I). The arrays FACONT and GACONT will contain the values of
4501 C the contact function and its derivative.
4502 c r0ij=1.02D0*rpp(iteli,itelj)
4503 c r0ij=1.11D0*rpp(iteli,itelj)
4504 r0ij=2.20D0*rpp(iteli,itelj)
4505 c r0ij=1.55D0*rpp(iteli,itelj)
4506 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4507 if (fcont.gt.0.0D0) then
4508 num_conti=num_conti+1
4509 if (num_conti.gt.maxconts) then
4510 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4511 & ' will skip next contacts for this conf.'
4513 jcont_hb(num_conti,i)=j
4514 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4515 cd & " jcont_hb",jcont_hb(num_conti,i)
4516 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4517 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4518 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4520 d_cont(num_conti,i)=rij
4521 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4522 C --- Electrostatic-interaction matrix ---
4523 a_chuj(1,1,num_conti,i)=a22
4524 a_chuj(1,2,num_conti,i)=a23
4525 a_chuj(2,1,num_conti,i)=a32
4526 a_chuj(2,2,num_conti,i)=a33
4527 C --- Gradient of rij
4529 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4536 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4537 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4538 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4539 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4540 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4545 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4546 C Calculate contact energies
4548 wij=cosa-3.0D0*cosb*cosg
4551 c fac3=dsqrt(-ael6i)/r0ij**3
4552 fac3=dsqrt(-ael6i)*r3ij
4553 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4554 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4555 if (ees0tmp.gt.0) then
4556 ees0pij=dsqrt(ees0tmp)
4560 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4561 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4562 if (ees0tmp.gt.0) then
4563 ees0mij=dsqrt(ees0tmp)
4568 if (shield_mode.eq.0) then
4572 ees0plist(num_conti,i)=j
4573 C fac_shield(i)=0.4d0
4574 C fac_shield(j)=0.6d0
4576 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4577 & *fac_shield(i)*fac_shield(j)*sss
4578 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4579 & *fac_shield(i)*fac_shield(j)*sss
4580 C Diagnostics. Comment out or remove after debugging!
4581 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4582 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4583 c ees0m(num_conti,i)=0.0D0
4585 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4586 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4587 C Angular derivatives of the contact function
4588 ees0pij1=fac3/ees0pij
4589 ees0mij1=fac3/ees0mij
4590 fac3p=-3.0D0*fac3*rrmij
4591 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4592 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4594 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4595 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4596 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4597 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4598 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4599 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4600 ecosap=ecosa1+ecosa2
4601 ecosbp=ecosb1+ecosb2
4602 ecosgp=ecosg1+ecosg2
4603 ecosam=ecosa1-ecosa2
4604 ecosbm=ecosb1-ecosb2
4605 ecosgm=ecosg1-ecosg2
4614 facont_hb(num_conti,i)=fcont
4615 fprimcont=fprimcont/rij
4616 cd facont_hb(num_conti,i)=1.0D0
4617 C Following line is for diagnostics.
4620 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4621 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4624 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4625 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4627 gggp(1)=gggp(1)+ees0pijp*xj
4628 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4629 gggp(2)=gggp(2)+ees0pijp*yj
4630 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4631 gggp(3)=gggp(3)+ees0pijp*zj
4632 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4633 gggm(1)=gggm(1)+ees0mijp*xj
4634 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4635 gggm(2)=gggm(2)+ees0mijp*yj
4636 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4637 gggm(3)=gggm(3)+ees0mijp*zj
4638 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4639 C Derivatives due to the contact function
4640 gacont_hbr(1,num_conti,i)=fprimcont*xj
4641 gacont_hbr(2,num_conti,i)=fprimcont*yj
4642 gacont_hbr(3,num_conti,i)=fprimcont*zj
4645 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4646 c following the change of gradient-summation algorithm.
4648 cgrad ghalfp=0.5D0*gggp(k)
4649 cgrad ghalfm=0.5D0*gggm(k)
4650 gacontp_hb1(k,num_conti,i)=!ghalfp
4651 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4652 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4653 & *fac_shield(i)*fac_shield(j)*sss
4655 gacontp_hb2(k,num_conti,i)=!ghalfp
4656 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4657 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4658 & *fac_shield(i)*fac_shield(j)*sss
4660 gacontp_hb3(k,num_conti,i)=gggp(k)
4661 & *fac_shield(i)*fac_shield(j)*sss
4663 gacontm_hb1(k,num_conti,i)=!ghalfm
4664 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4665 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4666 & *fac_shield(i)*fac_shield(j)*sss
4668 gacontm_hb2(k,num_conti,i)=!ghalfm
4669 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4670 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4671 & *fac_shield(i)*fac_shield(j)*sss
4673 gacontm_hb3(k,num_conti,i)=gggm(k)
4674 & *fac_shield(i)*fac_shield(j)*sss
4677 C Diagnostics. Comment out or remove after debugging!
4679 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4680 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4681 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4682 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4683 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4684 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4687 endif ! num_conti.le.maxconts
4691 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4694 ghalf=0.5d0*agg(l,k)
4695 aggi(l,k)=aggi(l,k)+ghalf
4696 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4697 aggj(l,k)=aggj(l,k)+ghalf
4700 if (j.eq.nres-1 .and. i.lt.j-2) then
4703 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4708 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4711 C-----------------------------------------------------------------------------
4712 subroutine eturn3(i,eello_turn3)
4713 C Third- and fourth-order contributions from turns
4714 implicit real*8 (a-h,o-z)
4715 include 'DIMENSIONS'
4716 include 'COMMON.IOUNITS'
4717 include 'COMMON.GEO'
4718 include 'COMMON.VAR'
4719 include 'COMMON.LOCAL'
4720 include 'COMMON.CHAIN'
4721 include 'COMMON.DERIV'
4722 include 'COMMON.INTERACT'
4723 include 'COMMON.CORRMAT'
4724 include 'COMMON.TORSION'
4725 include 'COMMON.VECTORS'
4726 include 'COMMON.FFIELD'
4727 include 'COMMON.CONTROL'
4728 include 'COMMON.SHIELD'
4730 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4731 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4732 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4733 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4734 & auxgmat2(2,2),auxgmatt2(2,2)
4735 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4736 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4737 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4738 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4741 c write (iout,*) "eturn3",i,j,j1,j2
4746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4748 C Third-order contributions
4755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4756 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4757 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4758 c auxalary matices for theta gradient
4759 c auxalary matrix for i+1 and constant i+2
4760 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4761 c auxalary matrix for i+2 and constant i+1
4762 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4763 call transpose2(auxmat(1,1),auxmat1(1,1))
4764 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4765 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4766 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4767 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4768 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4769 if (shield_mode.eq.0) then
4776 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4777 & *fac_shield(i)*fac_shield(j)
4778 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4779 & *fac_shield(i)*fac_shield(j)
4780 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4783 C Derivatives in theta
4784 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4785 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4786 & *fac_shield(i)*fac_shield(j)
4787 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4788 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4789 & *fac_shield(i)*fac_shield(j)
4792 C Derivatives in shield mode
4793 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4794 & (shield_mode.gt.0)) then
4797 do ilist=1,ishield_list(i)
4798 iresshield=shield_list(ilist,i)
4800 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4802 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4804 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4805 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4809 do ilist=1,ishield_list(j)
4810 iresshield=shield_list(ilist,j)
4812 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4814 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4816 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4817 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4824 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4825 & grad_shield(k,i)*eello_t3/fac_shield(i)
4826 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4827 & grad_shield(k,j)*eello_t3/fac_shield(j)
4828 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4829 & grad_shield(k,i)*eello_t3/fac_shield(i)
4830 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4831 & grad_shield(k,j)*eello_t3/fac_shield(j)
4835 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4836 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4837 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4838 cd & ' eello_turn3_num',4*eello_turn3_num
4839 C Derivatives in gamma(i)
4840 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4841 call transpose2(auxmat2(1,1),auxmat3(1,1))
4842 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4843 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4844 & *fac_shield(i)*fac_shield(j)
4845 C Derivatives in gamma(i+1)
4846 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4847 call transpose2(auxmat2(1,1),auxmat3(1,1))
4848 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4849 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4850 & +0.5d0*(pizda(1,1)+pizda(2,2))
4851 & *fac_shield(i)*fac_shield(j)
4852 C Cartesian derivatives
4854 c ghalf1=0.5d0*agg(l,1)
4855 c ghalf2=0.5d0*agg(l,2)
4856 c ghalf3=0.5d0*agg(l,3)
4857 c ghalf4=0.5d0*agg(l,4)
4858 a_temp(1,1)=aggi(l,1)!+ghalf1
4859 a_temp(1,2)=aggi(l,2)!+ghalf2
4860 a_temp(2,1)=aggi(l,3)!+ghalf3
4861 a_temp(2,2)=aggi(l,4)!+ghalf4
4862 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4863 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4864 & +0.5d0*(pizda(1,1)+pizda(2,2))
4865 & *fac_shield(i)*fac_shield(j)
4867 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4868 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4869 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4870 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4871 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4872 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4873 & +0.5d0*(pizda(1,1)+pizda(2,2))
4874 & *fac_shield(i)*fac_shield(j)
4875 a_temp(1,1)=aggj(l,1)!+ghalf1
4876 a_temp(1,2)=aggj(l,2)!+ghalf2
4877 a_temp(2,1)=aggj(l,3)!+ghalf3
4878 a_temp(2,2)=aggj(l,4)!+ghalf4
4879 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4880 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4881 & +0.5d0*(pizda(1,1)+pizda(2,2))
4882 & *fac_shield(i)*fac_shield(j)
4883 a_temp(1,1)=aggj1(l,1)
4884 a_temp(1,2)=aggj1(l,2)
4885 a_temp(2,1)=aggj1(l,3)
4886 a_temp(2,2)=aggj1(l,4)
4887 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4888 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4889 & +0.5d0*(pizda(1,1)+pizda(2,2))
4890 & *fac_shield(i)*fac_shield(j)
4894 C-------------------------------------------------------------------------------
4895 subroutine eturn4(i,eello_turn4)
4896 C Third- and fourth-order contributions from turns
4897 implicit real*8 (a-h,o-z)
4898 include 'DIMENSIONS'
4899 include 'COMMON.IOUNITS'
4900 include 'COMMON.GEO'
4901 include 'COMMON.VAR'
4902 include 'COMMON.LOCAL'
4903 include 'COMMON.CHAIN'
4904 include 'COMMON.DERIV'
4905 include 'COMMON.INTERACT'
4906 include 'COMMON.CORRMAT'
4907 include 'COMMON.TORSION'
4908 include 'COMMON.VECTORS'
4909 include 'COMMON.FFIELD'
4910 include 'COMMON.CONTROL'
4911 include 'COMMON.SHIELD'
4913 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4914 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4915 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4916 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4917 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4918 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4919 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4920 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4921 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4922 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4923 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4926 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4928 C Fourth-order contributions
4936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4937 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4938 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4939 c write(iout,*)"WCHODZE W PROGRAM"
4944 iti1=itype2loc(itype(i+1))
4945 iti2=itype2loc(itype(i+2))
4946 iti3=itype2loc(itype(i+3))
4947 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4948 call transpose2(EUg(1,1,i+1),e1t(1,1))
4949 call transpose2(Eug(1,1,i+2),e2t(1,1))
4950 call transpose2(Eug(1,1,i+3),e3t(1,1))
4951 C Ematrix derivative in theta
4952 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4953 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4954 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4955 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4956 c eta1 in derivative theta
4957 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4958 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4959 c auxgvec is derivative of Ub2 so i+3 theta
4960 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4961 c auxalary matrix of E i+1
4962 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4965 s1=scalar2(b1(1,i+2),auxvec(1))
4966 c derivative of theta i+2 with constant i+3
4967 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4968 c derivative of theta i+2 with constant i+2
4969 gs32=scalar2(b1(1,i+2),auxgvec(1))
4970 c derivative of E matix in theta of i+1
4971 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4973 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4974 c ea31 in derivative theta
4975 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4976 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4977 c auxilary matrix auxgvec of Ub2 with constant E matirx
4978 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4979 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4980 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4984 s2=scalar2(b1(1,i+1),auxvec(1))
4985 c derivative of theta i+1 with constant i+3
4986 gs13=scalar2(gtb1(1,i+1),auxvec(1))
4987 c derivative of theta i+2 with constant i+1
4988 gs21=scalar2(b1(1,i+1),auxgvec(1))
4989 c derivative of theta i+3 with constant i+1
4990 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4991 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4993 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4994 c two derivatives over diffetent matrices
4995 c gtae3e2 is derivative over i+3
4996 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4997 c ae3gte2 is derivative over i+2
4998 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4999 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5000 c three possible derivative over theta E matices
5002 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5004 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5006 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5007 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5009 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5010 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5011 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5012 if (shield_mode.eq.0) then
5019 eello_turn4=eello_turn4-(s1+s2+s3)
5020 & *fac_shield(i)*fac_shield(j)
5021 eello_t4=-(s1+s2+s3)
5022 & *fac_shield(i)*fac_shield(j)
5023 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5024 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5025 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5026 C Now derivative over shield:
5027 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5028 & (shield_mode.gt.0)) then
5031 do ilist=1,ishield_list(i)
5032 iresshield=shield_list(ilist,i)
5034 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5036 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5038 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5039 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5043 do ilist=1,ishield_list(j)
5044 iresshield=shield_list(ilist,j)
5046 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5048 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5050 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5051 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5058 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5059 & grad_shield(k,i)*eello_t4/fac_shield(i)
5060 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5061 & grad_shield(k,j)*eello_t4/fac_shield(j)
5062 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5063 & grad_shield(k,i)*eello_t4/fac_shield(i)
5064 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5065 & grad_shield(k,j)*eello_t4/fac_shield(j)
5074 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5075 cd & ' eello_turn4_num',8*eello_turn4_num
5077 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5078 & -(gs13+gsE13+gsEE1)*wturn4
5079 & *fac_shield(i)*fac_shield(j)
5080 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5081 & -(gs23+gs21+gsEE2)*wturn4
5082 & *fac_shield(i)*fac_shield(j)
5084 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5085 & -(gs32+gsE31+gsEE3)*wturn4
5086 & *fac_shield(i)*fac_shield(j)
5088 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5091 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5092 & 'eturn4',i,j,-(s1+s2+s3)
5093 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5094 c & ' eello_turn4_num',8*eello_turn4_num
5095 C Derivatives in gamma(i)
5096 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5097 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5098 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5099 s1=scalar2(b1(1,i+2),auxvec(1))
5100 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5101 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5102 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5103 & *fac_shield(i)*fac_shield(j)
5104 C Derivatives in gamma(i+1)
5105 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5106 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5107 s2=scalar2(b1(1,i+1),auxvec(1))
5108 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5109 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5110 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5111 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5112 & *fac_shield(i)*fac_shield(j)
5113 C Derivatives in gamma(i+2)
5114 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5115 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5116 s1=scalar2(b1(1,i+2),auxvec(1))
5117 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5118 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5119 s2=scalar2(b1(1,i+1),auxvec(1))
5120 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5121 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5122 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5123 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5124 & *fac_shield(i)*fac_shield(j)
5125 C Cartesian derivatives
5126 C Derivatives of this turn contributions in DC(i+2)
5127 if (j.lt.nres-1) then
5129 a_temp(1,1)=agg(l,1)
5130 a_temp(1,2)=agg(l,2)
5131 a_temp(2,1)=agg(l,3)
5132 a_temp(2,2)=agg(l,4)
5133 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5134 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5135 s1=scalar2(b1(1,i+2),auxvec(1))
5136 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5137 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5138 s2=scalar2(b1(1,i+1),auxvec(1))
5139 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5140 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5141 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5143 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5144 & *fac_shield(i)*fac_shield(j)
5147 C Remaining derivatives of this turn contribution
5149 a_temp(1,1)=aggi(l,1)
5150 a_temp(1,2)=aggi(l,2)
5151 a_temp(2,1)=aggi(l,3)
5152 a_temp(2,2)=aggi(l,4)
5153 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5154 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5155 s1=scalar2(b1(1,i+2),auxvec(1))
5156 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5157 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5158 s2=scalar2(b1(1,i+1),auxvec(1))
5159 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5160 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5161 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5162 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5163 & *fac_shield(i)*fac_shield(j)
5164 a_temp(1,1)=aggi1(l,1)
5165 a_temp(1,2)=aggi1(l,2)
5166 a_temp(2,1)=aggi1(l,3)
5167 a_temp(2,2)=aggi1(l,4)
5168 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5169 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5170 s1=scalar2(b1(1,i+2),auxvec(1))
5171 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5172 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5173 s2=scalar2(b1(1,i+1),auxvec(1))
5174 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5175 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5176 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5177 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5178 & *fac_shield(i)*fac_shield(j)
5179 a_temp(1,1)=aggj(l,1)
5180 a_temp(1,2)=aggj(l,2)
5181 a_temp(2,1)=aggj(l,3)
5182 a_temp(2,2)=aggj(l,4)
5183 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5184 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5185 s1=scalar2(b1(1,i+2),auxvec(1))
5186 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5187 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5188 s2=scalar2(b1(1,i+1),auxvec(1))
5189 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5190 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5191 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5192 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5193 & *fac_shield(i)*fac_shield(j)
5194 a_temp(1,1)=aggj1(l,1)
5195 a_temp(1,2)=aggj1(l,2)
5196 a_temp(2,1)=aggj1(l,3)
5197 a_temp(2,2)=aggj1(l,4)
5198 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5199 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5200 s1=scalar2(b1(1,i+2),auxvec(1))
5201 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5202 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5203 s2=scalar2(b1(1,i+1),auxvec(1))
5204 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5205 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5206 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5207 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5208 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5209 & *fac_shield(i)*fac_shield(j)
5213 C-----------------------------------------------------------------------------
5214 subroutine vecpr(u,v,w)
5215 implicit real*8(a-h,o-z)
5216 dimension u(3),v(3),w(3)
5217 w(1)=u(2)*v(3)-u(3)*v(2)
5218 w(2)=-u(1)*v(3)+u(3)*v(1)
5219 w(3)=u(1)*v(2)-u(2)*v(1)
5222 C-----------------------------------------------------------------------------
5223 subroutine unormderiv(u,ugrad,unorm,ungrad)
5224 C This subroutine computes the derivatives of a normalized vector u, given
5225 C the derivatives computed without normalization conditions, ugrad. Returns
5228 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5229 double precision vec(3)
5230 double precision scalar
5232 c write (2,*) 'ugrad',ugrad
5235 vec(i)=scalar(ugrad(1,i),u(1))
5237 c write (2,*) 'vec',vec
5240 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5243 c write (2,*) 'ungrad',ungrad
5246 C-----------------------------------------------------------------------------
5247 subroutine escp_soft_sphere(evdw2,evdw2_14)
5249 C This subroutine calculates the excluded-volume interaction energy between
5250 C peptide-group centers and side chains and its gradient in virtual-bond and
5251 C side-chain vectors.
5253 implicit real*8 (a-h,o-z)
5254 include 'DIMENSIONS'
5255 include 'COMMON.GEO'
5256 include 'COMMON.VAR'
5257 include 'COMMON.LOCAL'
5258 include 'COMMON.CHAIN'
5259 include 'COMMON.DERIV'
5260 include 'COMMON.INTERACT'
5261 include 'COMMON.FFIELD'
5262 include 'COMMON.IOUNITS'
5263 include 'COMMON.CONTROL'
5265 double precision boxshift
5269 cd print '(a)','Enter ESCP'
5270 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5274 c do i=iatscp_s,iatscp_e
5275 do ikont=g_listscp_start,g_listscp_end
5276 i=newcontlistscpi(ikont)
5277 j=newcontlistscpj(ikont)
5278 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5280 xi=0.5D0*(c(1,i)+c(1,i+1))
5281 yi=0.5D0*(c(2,i)+c(2,i+1))
5282 zi=0.5D0*(c(3,i)+c(3,i+1))
5283 C Return atom into box, boxxsize is size of box in x dimension
5285 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5286 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5287 C Condition for being inside the proper box
5288 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5289 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5293 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5294 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5295 C Condition for being inside the proper box
5296 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5297 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5301 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5302 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5303 cC Condition for being inside the proper box
5304 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5305 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5308 call to_box(xi,yi,zi)
5309 C xi=xi+xshift*boxxsize
5310 C yi=yi+yshift*boxysize
5311 C zi=zi+zshift*boxzsize
5312 c do iint=1,nscp_gr(i)
5314 c do j=iscpstart(i,iint),iscpend(i,iint)
5315 if (itype(j).eq.ntyp1) cycle
5316 itypj=iabs(itype(j))
5317 C Uncomment following three lines for SC-p interactions
5321 C Uncomment following three lines for Ca-p interactions
5325 call to_box(xj,yj,zj)
5326 xj=boxshift(xj-xi,boxxsize)
5327 yj=boxshift(yj-yi,boxysize)
5328 zj=boxshift(zj-zi,boxzsize)
5332 rij=xj*xj+yj*yj+zj*zj
5336 if (rij.lt.r0ijsq) then
5337 evdwij=0.25d0*(rij-r0ijsq)**2
5345 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5351 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5352 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5363 C-----------------------------------------------------------------------------
5364 subroutine escp(evdw2,evdw2_14)
5366 C This subroutine calculates the excluded-volume interaction energy between
5367 C peptide-group centers and side chains and its gradient in virtual-bond and
5368 C side-chain vectors.
5371 include 'DIMENSIONS'
5372 include 'COMMON.GEO'
5373 include 'COMMON.VAR'
5374 include 'COMMON.LOCAL'
5375 include 'COMMON.CHAIN'
5376 include 'COMMON.DERIV'
5377 include 'COMMON.INTERACT'
5378 include 'COMMON.FFIELD'
5379 include 'COMMON.IOUNITS'
5380 include 'COMMON.CONTROL'
5381 include 'COMMON.SPLITELE'
5382 double precision ggg(3)
5383 integer i,iint,j,k,iteli,itypj,subchap,ikont
5384 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5386 double precision evdw2,evdw2_14,evdwij
5387 double precision sscale,sscagrad
5388 double precision boxshift
5391 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5392 cd print '(a)','Enter ESCP'
5393 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5397 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5398 c do i=iatscp_s,iatscp_e
5399 do ikont=g_listscp_start,g_listscp_end
5400 i=newcontlistscpi(ikont)
5401 j=newcontlistscpj(ikont)
5402 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5404 xi=0.5D0*(c(1,i)+c(1,i+1))
5405 yi=0.5D0*(c(2,i)+c(2,i+1))
5406 zi=0.5D0*(c(3,i)+c(3,i+1))
5407 call to_box(xi,yi,zi)
5408 c do iint=1,nscp_gr(i)
5410 c do j=iscpstart(i,iint),iscpend(i,iint)
5411 itypj=iabs(itype(j))
5412 if (itypj.eq.ntyp1) cycle
5413 C Uncomment following three lines for SC-p interactions
5417 C Uncomment following three lines for Ca-p interactions
5421 call to_box(xj,yj,zj)
5422 xj=boxshift(xj-xi,boxxsize)
5423 yj=boxshift(yj-yi,boxysize)
5424 zj=boxshift(zj-zi,boxzsize)
5425 c print *,xj,yj,zj,'polozenie j'
5426 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5428 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5429 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5430 c if (sss.eq.0) print *,'czasem jest OK'
5431 if (sss.le.0.0d0) cycle
5432 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5434 e1=fac*fac*aad(itypj,iteli)
5435 e2=fac*bad(itypj,iteli)
5436 if (iabs(j-i) .le. 2) then
5439 evdw2_14=evdw2_14+(e1+e2)*sss
5442 evdw2=evdw2+evdwij*sss
5443 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5444 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5445 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5448 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5450 fac=-(evdwij+e1)*rrij*sss
5451 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5455 cgrad if (j.lt.i) then
5456 cd write (iout,*) 'j<i'
5457 C Uncomment following three lines for SC-p interactions
5459 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5462 cd write (iout,*) 'j>i'
5464 cgrad ggg(k)=-ggg(k)
5465 C Uncomment following line for SC-p interactions
5466 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5467 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5471 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5473 cgrad kstart=min0(i+1,j)
5474 cgrad kend=max0(i-1,j-1)
5475 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5476 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5477 cgrad do k=kstart,kend
5479 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5483 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5484 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5486 c endif !endif for sscale cutoff
5496 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5497 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5498 gradx_scp(j,i)=expon*gradx_scp(j,i)
5501 C******************************************************************************
5505 C To save time the factor EXPON has been extracted from ALL components
5506 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5509 C******************************************************************************
5512 C--------------------------------------------------------------------------
5513 subroutine edis(ehpb)
5515 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5517 implicit real*8 (a-h,o-z)
5518 include 'DIMENSIONS'
5519 include 'COMMON.SBRIDGE'
5520 include 'COMMON.CHAIN'
5521 include 'COMMON.DERIV'
5522 include 'COMMON.VAR'
5523 include 'COMMON.INTERACT'
5524 include 'COMMON.IOUNITS'
5525 include 'COMMON.CONTROL'
5526 dimension ggg(3),ggg_peak(3,1000)
5531 c 8/21/18 AL: added explicit restraints on reference coords
5532 c write (iout,*) "restr_on_coord",restr_on_coord
5533 if (restr_on_coord) then
5537 if (itype(i).eq.ntyp1) cycle
5539 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5540 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5542 if (itype(i).ne.10) then
5544 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5545 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5548 if (energy_dec) write (iout,*)
5549 & "i",i," bfac",bfac(i)," ecoor",ecoor
5550 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5554 C write (iout,*) ,"link_end",link_end,constr_dist
5555 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5556 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5557 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5558 c & " link_end_peak",link_end_peak
5559 if (link_end.eq.0.and.link_end_peak.eq.0) return
5560 do i=link_start_peak,link_end_peak
5562 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5563 c & ipeak(1,i),ipeak(2,i)
5564 do ip=ipeak(1,i),ipeak(2,i)
5569 C iii and jjj point to the residues for which the distance is assigned.
5570 c if (ii.gt.nres) then
5577 if (ii.gt.nres) then
5582 if (jj.gt.nres) then
5587 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5588 aux=dexp(-scal_peak*aux)
5589 ehpb_peak=ehpb_peak+aux
5590 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5591 & forcon_peak(ip))*aux/dd
5593 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5595 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5596 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5597 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5599 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5600 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5601 do ip=ipeak(1,i),ipeak(2,i)
5604 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5608 C iii and jjj point to the residues for which the distance is assigned.
5609 c if (ii.gt.nres) then
5616 if (ii.gt.nres) then
5621 if (jj.gt.nres) then
5628 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5633 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5637 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5638 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5642 do i=link_start,link_end
5643 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5644 C CA-CA distance used in regularization of structure.
5647 C iii and jjj point to the residues for which the distance is assigned.
5648 if (ii.gt.nres) then
5653 if (jj.gt.nres) then
5658 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5659 c & dhpb(i),dhpb1(i),forcon(i)
5660 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5661 C distance and angle dependent SS bond potential.
5662 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5663 C & iabs(itype(jjj)).eq.1) then
5664 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5665 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5666 if (.not.dyn_ss .and. i.le.nss) then
5667 C 15/02/13 CC dynamic SSbond - additional check
5668 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5669 & iabs(itype(jjj)).eq.1) then
5670 call ssbond_ene(iii,jjj,eij)
5673 cd write (iout,*) "eij",eij
5674 cd & ' waga=',waga,' fac=',fac
5675 ! else if (ii.gt.nres .and. jj.gt.nres) then
5677 C Calculate the distance between the two points and its difference from the
5680 if (irestr_type(i).eq.11) then
5681 ehpb=ehpb+fordepth(i)!**4.0d0
5682 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5683 fac=fordepth(i)!**4.0d0
5684 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5685 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5686 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5687 & ehpb,irestr_type(i)
5688 else if (irestr_type(i).eq.10) then
5689 c AL 6//19/2018 cross-link restraints
5690 xdis = 0.5d0*(dd/forcon(i))**2
5691 expdis = dexp(-xdis)
5692 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5693 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5694 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5695 c & " wboltzd",wboltzd
5696 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5697 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5698 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5699 & *expdis/(aux*forcon(i)**2)
5700 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5701 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5702 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5703 else if (irestr_type(i).eq.2) then
5704 c Quartic restraints
5705 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5706 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5707 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5708 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5709 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5711 c Quadratic restraints
5713 C Get the force constant corresponding to this distance.
5715 C Calculate the contribution to energy.
5716 ehpb=ehpb+0.5d0*waga*rdis*rdis
5717 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5718 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5719 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5721 C Evaluate gradient.
5725 c Calculate Cartesian gradient
5727 ggg(j)=fac*(c(j,jj)-c(j,ii))
5729 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5730 C If this is a SC-SC distance, we need to calculate the contributions to the
5731 C Cartesian gradient in the SC vectors (ghpbx).
5734 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5739 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5743 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5744 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5750 C--------------------------------------------------------------------------
5751 subroutine ssbond_ene(i,j,eij)
5753 C Calculate the distance and angle dependent SS-bond potential energy
5754 C using a free-energy function derived based on RHF/6-31G** ab initio
5755 C calculations of diethyl disulfide.
5757 C A. Liwo and U. Kozlowska, 11/24/03
5759 implicit real*8 (a-h,o-z)
5760 include 'DIMENSIONS'
5761 include 'COMMON.SBRIDGE'
5762 include 'COMMON.CHAIN'
5763 include 'COMMON.DERIV'
5764 include 'COMMON.LOCAL'
5765 include 'COMMON.INTERACT'
5766 include 'COMMON.VAR'
5767 include 'COMMON.IOUNITS'
5768 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5769 itypi=iabs(itype(i))
5773 dxi=dc_norm(1,nres+i)
5774 dyi=dc_norm(2,nres+i)
5775 dzi=dc_norm(3,nres+i)
5776 c dsci_inv=dsc_inv(itypi)
5777 dsci_inv=vbld_inv(nres+i)
5778 itypj=iabs(itype(j))
5779 c dscj_inv=dsc_inv(itypj)
5780 dscj_inv=vbld_inv(nres+j)
5784 dxj=dc_norm(1,nres+j)
5785 dyj=dc_norm(2,nres+j)
5786 dzj=dc_norm(3,nres+j)
5787 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5792 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5793 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5794 om12=dxi*dxj+dyi*dyj+dzi*dzj
5796 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5797 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5803 deltat12=om2-om1+2.0d0
5805 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5806 & +akct*deltad*deltat12
5807 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5808 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5809 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5810 c & " deltat12",deltat12," eij",eij
5811 ed=2*akcm*deltad+akct*deltat12
5813 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5814 eom1=-2*akth*deltat1-pom1-om2*pom2
5815 eom2= 2*akth*deltat2+pom1-om1*pom2
5818 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5819 ghpbx(k,i)=ghpbx(k,i)-ggk
5820 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5821 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5822 ghpbx(k,j)=ghpbx(k,j)+ggk
5823 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5824 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5825 ghpbc(k,i)=ghpbc(k,i)-ggk
5826 ghpbc(k,j)=ghpbc(k,j)+ggk
5829 C Calculate the components of the gradient in DC and X
5833 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5838 C--------------------------------------------------------------------------
5839 subroutine ebond(estr)
5841 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5843 implicit real*8 (a-h,o-z)
5844 include 'DIMENSIONS'
5845 include 'COMMON.LOCAL'
5846 include 'COMMON.GEO'
5847 include 'COMMON.INTERACT'
5848 include 'COMMON.DERIV'
5849 include 'COMMON.VAR'
5850 include 'COMMON.CHAIN'
5851 include 'COMMON.IOUNITS'
5852 include 'COMMON.NAMES'
5853 include 'COMMON.FFIELD'
5854 include 'COMMON.CONTROL'
5855 include 'COMMON.SETUP'
5856 double precision u(3),ud(3)
5859 do i=ibondp_start,ibondp_end
5860 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5863 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5864 diff = vbld(i)-vbldp0
5866 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5867 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5869 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5870 c & *dc(j,i-1)/vbld(i)
5872 c if (energy_dec) write(iout,*)
5873 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5875 C Checking if it involves dummy (NH3+ or COO-) group
5876 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5877 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5878 diff = vbld(i)-vbldpDUM
5879 if (energy_dec) write(iout,*) "dum_bond",i,diff
5881 C NO vbldp0 is the equlibrium length of spring for peptide group
5882 diff = vbld(i)-vbldp0
5885 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5886 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5889 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5891 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5895 estr=0.5d0*AKP*estr+estr1
5897 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5899 do i=ibond_start,ibond_end
5901 if (iti.ne.10 .and. iti.ne.ntyp1) then
5904 diff=vbld(i+nres)-vbldsc0(1,iti)
5905 if (energy_dec) write (iout,*)
5906 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5907 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5908 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5910 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5914 diff=vbld(i+nres)-vbldsc0(j,iti)
5915 ud(j)=aksc(j,iti)*diff
5916 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5930 uprod2=uprod2*u(k)*u(k)
5934 usumsqder=usumsqder+ud(j)*uprod2
5936 estr=estr+uprod/usum
5938 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5946 C--------------------------------------------------------------------------
5947 subroutine ebend(etheta)
5949 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5950 C angles gamma and its derivatives in consecutive thetas and gammas.
5952 implicit real*8 (a-h,o-z)
5953 include 'DIMENSIONS'
5954 include 'COMMON.LOCAL'
5955 include 'COMMON.GEO'
5956 include 'COMMON.INTERACT'
5957 include 'COMMON.DERIV'
5958 include 'COMMON.VAR'
5959 include 'COMMON.CHAIN'
5960 include 'COMMON.IOUNITS'
5961 include 'COMMON.NAMES'
5962 include 'COMMON.FFIELD'
5963 include 'COMMON.CONTROL'
5964 include 'COMMON.TORCNSTR'
5965 common /calcthet/ term1,term2,termm,diffak,ratak,
5966 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5967 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5968 double precision y(2),z(2)
5970 c time11=dexp(-2*time)
5973 c write (*,'(a,i2)') 'EBEND ICG=',icg
5974 do i=ithet_start,ithet_end
5975 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5976 & .or.itype(i).eq.ntyp1) cycle
5977 C Zero the energy function and its derivative at 0 or pi.
5978 call splinthet(theta(i),0.5d0*delta,ss,ssd)
5980 ichir1=isign(1,itype(i-2))
5981 ichir2=isign(1,itype(i))
5982 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5983 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5984 if (itype(i-1).eq.10) then
5985 itype1=isign(10,itype(i-2))
5986 ichir11=isign(1,itype(i-2))
5987 ichir12=isign(1,itype(i-2))
5988 itype2=isign(10,itype(i))
5989 ichir21=isign(1,itype(i))
5990 ichir22=isign(1,itype(i))
5993 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5996 if (phii.ne.phii) phii=150.0
6006 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6009 if (phii1.ne.phii1) phii1=150.0
6021 C Calculate the "mean" value of theta from the part of the distribution
6022 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6023 C In following comments this theta will be referred to as t_c.
6024 thet_pred_mean=0.0d0
6026 athetk=athet(k,it,ichir1,ichir2)
6027 bthetk=bthet(k,it,ichir1,ichir2)
6029 athetk=athet(k,itype1,ichir11,ichir12)
6030 bthetk=bthet(k,itype2,ichir21,ichir22)
6032 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6033 c write(iout,*) 'chuj tu', y(k),z(k)
6035 dthett=thet_pred_mean*ssd
6036 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6037 C Derivatives of the "mean" values in gamma1 and gamma2.
6038 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6039 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6040 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6041 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6043 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6044 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6045 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6046 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6048 if (theta(i).gt.pi-delta) then
6049 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6051 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6052 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6053 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6055 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6057 else if (theta(i).lt.delta) then
6058 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6059 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6060 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6062 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6063 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6066 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6069 etheta=etheta+ethetai
6070 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6071 & 'ebend',i,ethetai,theta(i),itype(i)
6072 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6073 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6074 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6077 C Ufff.... We've done all this!!!
6080 C---------------------------------------------------------------------------
6081 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6083 implicit real*8 (a-h,o-z)
6084 include 'DIMENSIONS'
6085 include 'COMMON.LOCAL'
6086 include 'COMMON.IOUNITS'
6087 common /calcthet/ term1,term2,termm,diffak,ratak,
6088 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6089 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6090 C Calculate the contributions to both Gaussian lobes.
6091 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6092 C The "polynomial part" of the "standard deviation" of this part of
6093 C the distributioni.
6094 ccc write (iout,*) thetai,thet_pred_mean
6097 sig=sig*thet_pred_mean+polthet(j,it)
6099 C Derivative of the "interior part" of the "standard deviation of the"
6100 C gamma-dependent Gaussian lobe in t_c.
6101 sigtc=3*polthet(3,it)
6103 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6106 C Set the parameters of both Gaussian lobes of the distribution.
6107 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6108 fac=sig*sig+sigc0(it)
6111 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6112 sigsqtc=-4.0D0*sigcsq*sigtc
6113 c print *,i,sig,sigtc,sigsqtc
6114 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6115 sigtc=-sigtc/(fac*fac)
6116 C Following variable is sigma(t_c)**(-2)
6117 sigcsq=sigcsq*sigcsq
6119 sig0inv=1.0D0/sig0i**2
6120 delthec=thetai-thet_pred_mean
6121 delthe0=thetai-theta0i
6122 term1=-0.5D0*sigcsq*delthec*delthec
6123 term2=-0.5D0*sig0inv*delthe0*delthe0
6124 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6125 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6126 C NaNs in taking the logarithm. We extract the largest exponent which is added
6127 C to the energy (this being the log of the distribution) at the end of energy
6128 C term evaluation for this virtual-bond angle.
6129 if (term1.gt.term2) then
6131 term2=dexp(term2-termm)
6135 term1=dexp(term1-termm)
6138 C The ratio between the gamma-independent and gamma-dependent lobes of
6139 C the distribution is a Gaussian function of thet_pred_mean too.
6140 diffak=gthet(2,it)-thet_pred_mean
6141 ratak=diffak/gthet(3,it)**2
6142 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6143 C Let's differentiate it in thet_pred_mean NOW.
6145 C Now put together the distribution terms to make complete distribution.
6146 termexp=term1+ak*term2
6147 termpre=sigc+ak*sig0i
6148 C Contribution of the bending energy from this theta is just the -log of
6149 C the sum of the contributions from the two lobes and the pre-exponential
6150 C factor. Simple enough, isn't it?
6151 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6152 C write (iout,*) 'termexp',termexp,termm,termpre,i
6153 C NOW the derivatives!!!
6154 C 6/6/97 Take into account the deformation.
6155 E_theta=(delthec*sigcsq*term1
6156 & +ak*delthe0*sig0inv*term2)/termexp
6157 E_tc=((sigtc+aktc*sig0i)/termpre
6158 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6159 & aktc*term2)/termexp)
6162 c-----------------------------------------------------------------------------
6163 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6164 implicit real*8 (a-h,o-z)
6165 include 'DIMENSIONS'
6166 include 'COMMON.LOCAL'
6167 include 'COMMON.IOUNITS'
6168 common /calcthet/ term1,term2,termm,diffak,ratak,
6169 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6170 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6171 delthec=thetai-thet_pred_mean
6172 delthe0=thetai-theta0i
6173 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6174 t3 = thetai-thet_pred_mean
6178 t14 = t12+t6*sigsqtc
6180 t21 = thetai-theta0i
6186 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6187 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6188 & *(-t12*t9-ak*sig0inv*t27)
6192 C--------------------------------------------------------------------------
6193 subroutine ebend(etheta)
6195 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6196 C angles gamma and its derivatives in consecutive thetas and gammas.
6197 C ab initio-derived potentials from
6198 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6200 implicit real*8 (a-h,o-z)
6201 include 'DIMENSIONS'
6202 include 'COMMON.LOCAL'
6203 include 'COMMON.GEO'
6204 include 'COMMON.INTERACT'
6205 include 'COMMON.DERIV'
6206 include 'COMMON.VAR'
6207 include 'COMMON.CHAIN'
6208 include 'COMMON.IOUNITS'
6209 include 'COMMON.NAMES'
6210 include 'COMMON.FFIELD'
6211 include 'COMMON.CONTROL'
6212 include 'COMMON.TORCNSTR'
6213 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6214 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6215 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6216 & sinph1ph2(maxdouble,maxdouble)
6217 logical lprn /.false./, lprn1 /.false./
6219 do i=ithet_start,ithet_end
6220 c print *,i,itype(i-1),itype(i),itype(i-2)
6221 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6222 & .or.itype(i).eq.ntyp1) cycle
6223 C print *,i,theta(i)
6224 if (iabs(itype(i+1)).eq.20) iblock=2
6225 if (iabs(itype(i+1)).ne.20) iblock=1
6229 theti2=0.5d0*theta(i)
6230 ityp2=ithetyp((itype(i-1)))
6232 coskt(k)=dcos(k*theti2)
6233 sinkt(k)=dsin(k*theti2)
6236 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6239 if (phii.ne.phii) phii=150.0
6243 ityp1=ithetyp((itype(i-2)))
6244 C propagation of chirality for glycine type
6246 cosph1(k)=dcos(k*phii)
6247 sinph1(k)=dsin(k*phii)
6252 ityp1=ithetyp((itype(i-2)))
6257 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6260 if (phii1.ne.phii1) phii1=150.0
6265 ityp3=ithetyp((itype(i)))
6267 cosph2(k)=dcos(k*phii1)
6268 sinph2(k)=dsin(k*phii1)
6272 ityp3=ithetyp((itype(i)))
6278 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6281 ccl=cosph1(l)*cosph2(k-l)
6282 ssl=sinph1(l)*sinph2(k-l)
6283 scl=sinph1(l)*cosph2(k-l)
6284 csl=cosph1(l)*sinph2(k-l)
6285 cosph1ph2(l,k)=ccl-ssl
6286 cosph1ph2(k,l)=ccl+ssl
6287 sinph1ph2(l,k)=scl+csl
6288 sinph1ph2(k,l)=scl-csl
6292 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6293 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6294 write (iout,*) "coskt and sinkt"
6296 write (iout,*) k,coskt(k),sinkt(k)
6300 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6301 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6304 & write (iout,*) "k",k,"
6305 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6306 & " ethetai",ethetai
6309 write (iout,*) "cosph and sinph"
6311 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6313 write (iout,*) "cosph1ph2 and sinph2ph2"
6316 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6317 & sinph1ph2(l,k),sinph1ph2(k,l)
6320 write(iout,*) "ethetai",ethetai
6325 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6326 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6327 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6328 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6329 ethetai=ethetai+sinkt(m)*aux
6330 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6331 dephii=dephii+k*sinkt(m)*(
6332 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6333 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6334 dephii1=dephii1+k*sinkt(m)*(
6335 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6336 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6338 & write (iout,*) "m",m," k",k," bbthet",
6339 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6340 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6341 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6342 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6343 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6346 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6347 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6348 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6349 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6351 & write(iout,*) "ethetai",ethetai
6352 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6356 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6357 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6358 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6359 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6360 ethetai=ethetai+sinkt(m)*aux
6361 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6362 dephii=dephii+l*sinkt(m)*(
6363 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6364 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6365 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6366 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6367 dephii1=dephii1+(k-l)*sinkt(m)*(
6368 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6369 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6370 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6371 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6373 write (iout,*) "m",m," k",k," l",l," ffthet",
6374 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6375 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6376 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6377 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6378 & " ethetai",ethetai
6379 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6380 & cosph1ph2(k,l)*sinkt(m),
6381 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6390 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6391 & i,theta(i)*rad2deg,phii*rad2deg,
6392 & phii1*rad2deg,ethetai
6394 etheta=etheta+ethetai
6395 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6396 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6397 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6404 c-----------------------------------------------------------------------------
6405 subroutine esc(escloc)
6406 C Calculate the local energy of a side chain and its derivatives in the
6407 C corresponding virtual-bond valence angles THETA and the spherical angles
6409 implicit real*8 (a-h,o-z)
6410 include 'DIMENSIONS'
6411 include 'COMMON.GEO'
6412 include 'COMMON.LOCAL'
6413 include 'COMMON.VAR'
6414 include 'COMMON.INTERACT'
6415 include 'COMMON.DERIV'
6416 include 'COMMON.CHAIN'
6417 include 'COMMON.IOUNITS'
6418 include 'COMMON.NAMES'
6419 include 'COMMON.FFIELD'
6420 include 'COMMON.CONTROL'
6421 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6422 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6423 common /sccalc/ time11,time12,time112,theti,it,nlobit
6426 c write (iout,'(a)') 'ESC'
6427 do i=loc_start,loc_end
6429 if (it.eq.ntyp1) cycle
6430 if (it.eq.10) goto 1
6431 nlobit=nlob(iabs(it))
6432 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6433 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6434 theti=theta(i+1)-pipol
6439 if (x(2).gt.pi-delta) then
6443 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6445 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6446 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6448 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6449 & ddersc0(1),dersc(1))
6450 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6451 & ddersc0(3),dersc(3))
6453 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6455 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6456 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6457 & dersc0(2),esclocbi,dersc02)
6458 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6460 call splinthet(x(2),0.5d0*delta,ss,ssd)
6465 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6467 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6468 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6470 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6472 c write (iout,*) escloci
6473 else if (x(2).lt.delta) then
6477 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6479 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6480 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6482 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6483 & ddersc0(1),dersc(1))
6484 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6485 & ddersc0(3),dersc(3))
6487 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6489 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6490 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6491 & dersc0(2),esclocbi,dersc02)
6492 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6497 call splinthet(x(2),0.5d0*delta,ss,ssd)
6499 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6501 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6502 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6504 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6505 c write (iout,*) escloci
6507 call enesc(x,escloci,dersc,ddummy,.false.)
6510 escloc=escloc+escloci
6511 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6512 & 'escloc',i,escloci
6513 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6515 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6517 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6518 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6523 C---------------------------------------------------------------------------
6524 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6525 implicit real*8 (a-h,o-z)
6526 include 'DIMENSIONS'
6527 include 'COMMON.GEO'
6528 include 'COMMON.LOCAL'
6529 include 'COMMON.IOUNITS'
6530 common /sccalc/ time11,time12,time112,theti,it,nlobit
6531 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6532 double precision contr(maxlob,-1:1)
6534 c write (iout,*) 'it=',it,' nlobit=',nlobit
6538 if (mixed) ddersc(j)=0.0d0
6542 C Because of periodicity of the dependence of the SC energy in omega we have
6543 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6544 C To avoid underflows, first compute & store the exponents.
6552 z(k)=x(k)-censc(k,j,it)
6557 Axk=Axk+gaussc(l,k,j,it)*z(l)
6563 expfac=expfac+Ax(k,j,iii)*z(k)
6571 C As in the case of ebend, we want to avoid underflows in exponentiation and
6572 C subsequent NaNs and INFs in energy calculation.
6573 C Find the largest exponent
6577 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6581 cd print *,'it=',it,' emin=',emin
6583 C Compute the contribution to SC energy and derivatives
6588 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6589 if(adexp.ne.adexp) adexp=1.0
6592 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6594 cd print *,'j=',j,' expfac=',expfac
6595 escloc_i=escloc_i+expfac
6597 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6601 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6602 & +gaussc(k,2,j,it))*expfac
6609 dersc(1)=dersc(1)/cos(theti)**2
6610 ddersc(1)=ddersc(1)/cos(theti)**2
6613 escloci=-(dlog(escloc_i)-emin)
6615 dersc(j)=dersc(j)/escloc_i
6619 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6624 C------------------------------------------------------------------------------
6625 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6626 implicit real*8 (a-h,o-z)
6627 include 'DIMENSIONS'
6628 include 'COMMON.GEO'
6629 include 'COMMON.LOCAL'
6630 include 'COMMON.IOUNITS'
6631 common /sccalc/ time11,time12,time112,theti,it,nlobit
6632 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6633 double precision contr(maxlob)
6644 z(k)=x(k)-censc(k,j,it)
6650 Axk=Axk+gaussc(l,k,j,it)*z(l)
6656 expfac=expfac+Ax(k,j)*z(k)
6661 C As in the case of ebend, we want to avoid underflows in exponentiation and
6662 C subsequent NaNs and INFs in energy calculation.
6663 C Find the largest exponent
6666 if (emin.gt.contr(j)) emin=contr(j)
6670 C Compute the contribution to SC energy and derivatives
6674 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6675 escloc_i=escloc_i+expfac
6677 dersc(k)=dersc(k)+Ax(k,j)*expfac
6679 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6680 & +gaussc(1,2,j,it))*expfac
6684 dersc(1)=dersc(1)/cos(theti)**2
6685 dersc12=dersc12/cos(theti)**2
6686 escloci=-(dlog(escloc_i)-emin)
6688 dersc(j)=dersc(j)/escloc_i
6690 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6694 c----------------------------------------------------------------------------------
6695 subroutine esc(escloc)
6696 C Calculate the local energy of a side chain and its derivatives in the
6697 C corresponding virtual-bond valence angles THETA and the spherical angles
6698 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6699 C added by Urszula Kozlowska. 07/11/2007
6701 implicit real*8 (a-h,o-z)
6702 include 'DIMENSIONS'
6703 include 'COMMON.GEO'
6704 include 'COMMON.LOCAL'
6705 include 'COMMON.VAR'
6706 include 'COMMON.SCROT'
6707 include 'COMMON.INTERACT'
6708 include 'COMMON.DERIV'
6709 include 'COMMON.CHAIN'
6710 include 'COMMON.IOUNITS'
6711 include 'COMMON.NAMES'
6712 include 'COMMON.FFIELD'
6713 include 'COMMON.CONTROL'
6714 include 'COMMON.VECTORS'
6715 double precision x_prime(3),y_prime(3),z_prime(3)
6716 & , sumene,dsc_i,dp2_i,x(65),
6717 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6718 & de_dxx,de_dyy,de_dzz,de_dt
6719 double precision s1_t,s1_6_t,s2_t,s2_6_t
6721 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6722 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6723 & dt_dCi(3),dt_dCi1(3)
6724 common /sccalc/ time11,time12,time112,theti,it,nlobit
6727 do i=loc_start,loc_end
6728 if (itype(i).eq.ntyp1) cycle
6729 costtab(i+1) =dcos(theta(i+1))
6730 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6731 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6732 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6733 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6734 cosfac=dsqrt(cosfac2)
6735 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6736 sinfac=dsqrt(sinfac2)
6738 if (it.eq.10) goto 1
6740 C Compute the axes of tghe local cartesian coordinates system; store in
6741 c x_prime, y_prime and z_prime
6748 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6749 C & dc_norm(3,i+nres)
6751 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6752 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6755 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6758 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6759 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6760 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6761 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6762 c & " xy",scalar(x_prime(1),y_prime(1)),
6763 c & " xz",scalar(x_prime(1),z_prime(1)),
6764 c & " yy",scalar(y_prime(1),y_prime(1)),
6765 c & " yz",scalar(y_prime(1),z_prime(1)),
6766 c & " zz",scalar(z_prime(1),z_prime(1))
6768 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6769 C to local coordinate system. Store in xx, yy, zz.
6775 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6776 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6777 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6784 C Compute the energy of the ith side cbain
6786 c write (2,*) "xx",xx," yy",yy," zz",zz
6789 x(j) = sc_parmin(j,it)
6792 Cc diagnostics - remove later
6794 yy1 = dsin(alph(2))*dcos(omeg(2))
6795 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6796 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6797 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6799 C," --- ", xx_w,yy_w,zz_w
6802 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6803 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6805 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6806 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6808 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6809 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6810 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6811 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6812 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6814 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6815 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6816 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6817 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6818 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6820 dsc_i = 0.743d0+x(61)
6822 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6823 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6824 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6825 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6826 s1=(1+x(63))/(0.1d0 + dscp1)
6827 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6828 s2=(1+x(65))/(0.1d0 + dscp2)
6829 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6830 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6831 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6832 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6834 c & dscp1,dscp2,sumene
6835 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6836 escloc = escloc + sumene
6837 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6838 & " escloc",sumene,escloc,it,itype(i)
6843 C This section to check the numerical derivatives of the energy of ith side
6844 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6845 C #define DEBUG in the code to turn it on.
6847 write (2,*) "sumene =",sumene
6851 write (2,*) xx,yy,zz
6852 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6853 de_dxx_num=(sumenep-sumene)/aincr
6855 write (2,*) "xx+ sumene from enesc=",sumenep
6858 write (2,*) xx,yy,zz
6859 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6860 de_dyy_num=(sumenep-sumene)/aincr
6862 write (2,*) "yy+ sumene from enesc=",sumenep
6865 write (2,*) xx,yy,zz
6866 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6867 de_dzz_num=(sumenep-sumene)/aincr
6869 write (2,*) "zz+ sumene from enesc=",sumenep
6870 costsave=cost2tab(i+1)
6871 sintsave=sint2tab(i+1)
6872 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6873 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6874 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6875 de_dt_num=(sumenep-sumene)/aincr
6876 write (2,*) " t+ sumene from enesc=",sumenep
6877 cost2tab(i+1)=costsave
6878 sint2tab(i+1)=sintsave
6879 C End of diagnostics section.
6882 C Compute the gradient of esc
6884 c zz=zz*dsign(1.0,dfloat(itype(i)))
6885 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6886 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6887 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6888 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6889 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6890 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6891 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6892 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6893 pom1=(sumene3*sint2tab(i+1)+sumene1)
6894 & *(pom_s1/dscp1+pom_s16*dscp1**4)
6895 pom2=(sumene4*cost2tab(i+1)+sumene2)
6896 & *(pom_s2/dscp2+pom_s26*dscp2**4)
6897 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6898 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6899 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6901 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6902 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6903 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6905 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6906 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6907 & +(pom1+pom2)*pom_dx
6909 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6912 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6913 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6914 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6916 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6917 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6918 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6919 & +x(59)*zz**2 +x(60)*xx*zz
6920 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6921 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6922 & +(pom1-pom2)*pom_dy
6924 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6927 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6928 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6929 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6930 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
6931 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
6932 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6933 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6934 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
6936 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6939 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6940 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6941 & +pom1*pom_dt1+pom2*pom_dt2
6943 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6948 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6949 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6950 cosfac2xx=cosfac2*xx
6951 sinfac2yy=sinfac2*yy
6953 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6955 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6957 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6958 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6959 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6960 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6961 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6962 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6963 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6964 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6965 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6966 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6970 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6971 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6972 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6973 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6976 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6977 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6978 dZZ_XYZ(k)=vbld_inv(i+nres)*
6979 & (z_prime(k)-zz*dC_norm(k,i+nres))
6981 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6982 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6986 dXX_Ctab(k,i)=dXX_Ci(k)
6987 dXX_C1tab(k,i)=dXX_Ci1(k)
6988 dYY_Ctab(k,i)=dYY_Ci(k)
6989 dYY_C1tab(k,i)=dYY_Ci1(k)
6990 dZZ_Ctab(k,i)=dZZ_Ci(k)
6991 dZZ_C1tab(k,i)=dZZ_Ci1(k)
6992 dXX_XYZtab(k,i)=dXX_XYZ(k)
6993 dYY_XYZtab(k,i)=dYY_XYZ(k)
6994 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6998 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6999 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7000 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7001 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7002 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7004 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7005 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7006 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7007 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7008 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7009 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7010 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7011 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7013 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7014 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7016 C to check gradient call subroutine check_grad
7022 c------------------------------------------------------------------------------
7023 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7025 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7026 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7027 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7028 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7030 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7031 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7033 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7034 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7035 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7036 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7037 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7039 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7040 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7041 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7042 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7043 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7045 dsc_i = 0.743d0+x(61)
7047 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7048 & *(xx*cost2+yy*sint2))
7049 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7050 & *(xx*cost2-yy*sint2))
7051 s1=(1+x(63))/(0.1d0 + dscp1)
7052 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7053 s2=(1+x(65))/(0.1d0 + dscp2)
7054 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7055 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7056 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7061 c------------------------------------------------------------------------------
7062 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7064 C This procedure calculates two-body contact function g(rij) and its derivative:
7067 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7070 C where x=(rij-r0ij)/delta
7072 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7075 double precision rij,r0ij,eps0ij,fcont,fprimcont
7076 double precision x,x2,x4,delta
7080 if (x.lt.-1.0D0) then
7083 else if (x.le.1.0D0) then
7086 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7087 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7094 c------------------------------------------------------------------------------
7095 subroutine splinthet(theti,delta,ss,ssder)
7096 implicit real*8 (a-h,o-z)
7097 include 'DIMENSIONS'
7098 include 'COMMON.VAR'
7099 include 'COMMON.GEO'
7102 if (theti.gt.pipol) then
7103 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7105 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7110 c------------------------------------------------------------------------------
7111 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7113 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7114 double precision ksi,ksi2,ksi3,a1,a2,a3
7115 a1=fprim0*delta/(f1-f0)
7121 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7122 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7125 c------------------------------------------------------------------------------
7126 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7128 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7129 double precision ksi,ksi2,ksi3,a1,a2,a3
7134 a2=3*(f1x-f0x)-2*fprim0x*delta
7135 a3=fprim0x*delta-2*(f1x-f0x)
7136 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7139 C-----------------------------------------------------------------------------
7141 C-----------------------------------------------------------------------------
7142 subroutine etor(etors)
7143 implicit real*8 (a-h,o-z)
7144 include 'DIMENSIONS'
7145 include 'COMMON.VAR'
7146 include 'COMMON.GEO'
7147 include 'COMMON.LOCAL'
7148 include 'COMMON.TORSION'
7149 include 'COMMON.INTERACT'
7150 include 'COMMON.DERIV'
7151 include 'COMMON.CHAIN'
7152 include 'COMMON.NAMES'
7153 include 'COMMON.IOUNITS'
7154 include 'COMMON.FFIELD'
7155 include 'COMMON.TORCNSTR'
7156 include 'COMMON.CONTROL'
7158 C Set lprn=.true. for debugging
7162 do i=iphi_start,iphi_end
7164 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7165 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7166 itori=itortyp(itype(i-2))
7167 itori1=itortyp(itype(i-1))
7170 C Proline-Proline pair is a special case...
7171 if (itori.eq.3 .and. itori1.eq.3) then
7172 if (phii.gt.-dwapi3) then
7174 fac=1.0D0/(1.0D0-cosphi)
7175 etorsi=v1(1,3,3)*fac
7176 etorsi=etorsi+etorsi
7177 etors=etors+etorsi-v1(1,3,3)
7178 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7179 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7182 v1ij=v1(j+1,itori,itori1)
7183 v2ij=v2(j+1,itori,itori1)
7186 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7187 if (energy_dec) etors_ii=etors_ii+
7188 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7189 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7193 v1ij=v1(j,itori,itori1)
7194 v2ij=v2(j,itori,itori1)
7197 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7198 if (energy_dec) etors_ii=etors_ii+
7199 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7200 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7203 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7206 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7207 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7208 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7209 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7210 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7214 c------------------------------------------------------------------------------
7215 subroutine etor_d(etors_d)
7219 c----------------------------------------------------------------------------
7220 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7221 subroutine e_modeller(ehomology_constr)
7222 ehomology_constr=0.0d0
7223 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7226 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7228 c------------------------------------------------------------------------------
7229 subroutine etor_d(etors_d)
7233 c----------------------------------------------------------------------------
7235 subroutine etor(etors)
7236 implicit real*8 (a-h,o-z)
7237 include 'DIMENSIONS'
7238 include 'COMMON.VAR'
7239 include 'COMMON.GEO'
7240 include 'COMMON.LOCAL'
7241 include 'COMMON.TORSION'
7242 include 'COMMON.INTERACT'
7243 include 'COMMON.DERIV'
7244 include 'COMMON.CHAIN'
7245 include 'COMMON.NAMES'
7246 include 'COMMON.IOUNITS'
7247 include 'COMMON.FFIELD'
7248 include 'COMMON.TORCNSTR'
7249 include 'COMMON.CONTROL'
7251 C Set lprn=.true. for debugging
7255 do i=iphi_start,iphi_end
7256 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7257 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7258 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7259 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7260 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7261 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7262 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7263 C For introducing the NH3+ and COO- group please check the etor_d for reference
7266 if (iabs(itype(i)).eq.20) then
7271 itori=itortyp(itype(i-2))
7272 itori1=itortyp(itype(i-1))
7275 C Regular cosine and sine terms
7276 do j=1,nterm(itori,itori1,iblock)
7277 v1ij=v1(j,itori,itori1,iblock)
7278 v2ij=v2(j,itori,itori1,iblock)
7281 etors=etors+v1ij*cosphi+v2ij*sinphi
7282 if (energy_dec) etors_ii=etors_ii+
7283 & v1ij*cosphi+v2ij*sinphi
7284 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7288 C E = SUM ----------------------------------- - v1
7289 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7291 cosphi=dcos(0.5d0*phii)
7292 sinphi=dsin(0.5d0*phii)
7293 do j=1,nlor(itori,itori1,iblock)
7294 vl1ij=vlor1(j,itori,itori1)
7295 vl2ij=vlor2(j,itori,itori1)
7296 vl3ij=vlor3(j,itori,itori1)
7297 pom=vl2ij*cosphi+vl3ij*sinphi
7298 pom1=1.0d0/(pom*pom+1.0d0)
7299 etors=etors+vl1ij*pom1
7300 if (energy_dec) etors_ii=etors_ii+
7303 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7305 C Subtract the constant term
7306 etors=etors-v0(itori,itori1,iblock)
7307 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7308 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7310 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7311 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7312 & (v1(j,itori,itori1,iblock),j=1,6),
7313 & (v2(j,itori,itori1,iblock),j=1,6)
7314 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7315 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7319 c----------------------------------------------------------------------------
7320 subroutine etor_d(etors_d)
7321 C 6/23/01 Compute double torsional energy
7322 implicit real*8 (a-h,o-z)
7323 include 'DIMENSIONS'
7324 include 'COMMON.VAR'
7325 include 'COMMON.GEO'
7326 include 'COMMON.LOCAL'
7327 include 'COMMON.TORSION'
7328 include 'COMMON.INTERACT'
7329 include 'COMMON.DERIV'
7330 include 'COMMON.CHAIN'
7331 include 'COMMON.NAMES'
7332 include 'COMMON.IOUNITS'
7333 include 'COMMON.FFIELD'
7334 include 'COMMON.TORCNSTR'
7336 C Set lprn=.true. for debugging
7340 c write(iout,*) "a tu??"
7341 do i=iphid_start,iphid_end
7342 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7343 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7344 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7345 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7346 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7347 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7348 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7349 & (itype(i+1).eq.ntyp1)) cycle
7350 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7351 itori=itortyp(itype(i-2))
7352 itori1=itortyp(itype(i-1))
7353 itori2=itortyp(itype(i))
7359 if (iabs(itype(i+1)).eq.20) iblock=2
7360 C Iblock=2 Proline type
7361 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7362 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7363 C if (itype(i+1).eq.ntyp1) iblock=3
7364 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7365 C IS or IS NOT need for this
7366 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7367 C is (itype(i-3).eq.ntyp1) ntblock=2
7368 C ntblock is N-terminal blocking group
7370 C Regular cosine and sine terms
7371 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7372 C Example of changes for NH3+ blocking group
7373 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7374 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7375 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7376 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7377 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7378 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7379 cosphi1=dcos(j*phii)
7380 sinphi1=dsin(j*phii)
7381 cosphi2=dcos(j*phii1)
7382 sinphi2=dsin(j*phii1)
7383 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7384 & v2cij*cosphi2+v2sij*sinphi2
7385 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7386 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7388 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7390 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7391 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7392 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7393 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7394 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7395 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7396 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7397 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7398 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7399 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7400 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7401 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7402 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7403 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7406 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7407 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7412 C----------------------------------------------------------------------------------
7413 C The rigorous attempt to derive energy function
7414 subroutine etor_kcc(etors)
7415 implicit real*8 (a-h,o-z)
7416 include 'DIMENSIONS'
7417 include 'COMMON.VAR'
7418 include 'COMMON.GEO'
7419 include 'COMMON.LOCAL'
7420 include 'COMMON.TORSION'
7421 include 'COMMON.INTERACT'
7422 include 'COMMON.DERIV'
7423 include 'COMMON.CHAIN'
7424 include 'COMMON.NAMES'
7425 include 'COMMON.IOUNITS'
7426 include 'COMMON.FFIELD'
7427 include 'COMMON.TORCNSTR'
7428 include 'COMMON.CONTROL'
7429 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7431 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7432 C Set lprn=.true. for debugging
7435 C print *,"wchodze kcc"
7436 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7438 do i=iphi_start,iphi_end
7439 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7440 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7441 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7442 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7443 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7444 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7445 itori=itortyp(itype(i-2))
7446 itori1=itortyp(itype(i-1))
7451 C to avoid multiple devision by 2
7452 c theti22=0.5d0*theta(i)
7453 C theta 12 is the theta_1 /2
7454 C theta 22 is theta_2 /2
7455 c theti12=0.5d0*theta(i-1)
7456 C and appropriate sinus function
7457 sinthet1=dsin(theta(i-1))
7458 sinthet2=dsin(theta(i))
7459 costhet1=dcos(theta(i-1))
7460 costhet2=dcos(theta(i))
7461 C to speed up lets store its mutliplication
7462 sint1t2=sinthet2*sinthet1
7464 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7465 C +d_n*sin(n*gamma)) *
7466 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7467 C we have two sum 1) Non-Chebyshev which is with n and gamma
7468 nval=nterm_kcc_Tb(itori,itori1)
7474 c1(j)=c1(j-1)*costhet1
7475 c2(j)=c2(j-1)*costhet2
7478 do j=1,nterm_kcc(itori,itori1)
7482 sint1t2n=sint1t2n*sint1t2
7488 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7489 gradvalct1=gradvalct1+
7490 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7491 gradvalct2=gradvalct2+
7492 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7495 gradvalct1=-gradvalct1*sinthet1
7496 gradvalct2=-gradvalct2*sinthet2
7502 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7503 gradvalst1=gradvalst1+
7504 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7505 gradvalst2=gradvalst2+
7506 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7509 gradvalst1=-gradvalst1*sinthet1
7510 gradvalst2=-gradvalst2*sinthet2
7511 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7512 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7513 C glocig is the gradient local i site in gamma
7514 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7515 C now gradient over theta_1
7516 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7517 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7518 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7519 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7522 C derivative over gamma
7523 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7524 C derivative over theta1
7525 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7526 C now derivative over theta2
7527 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7529 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7530 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7531 write (iout,*) "c1",(c1(k),k=0,nval),
7532 & " c2",(c2(k),k=0,nval)
7537 c---------------------------------------------------------------------------------------------
7538 subroutine etor_constr(edihcnstr)
7539 implicit real*8 (a-h,o-z)
7540 include 'DIMENSIONS'
7541 include 'COMMON.VAR'
7542 include 'COMMON.GEO'
7543 include 'COMMON.LOCAL'
7544 include 'COMMON.TORSION'
7545 include 'COMMON.INTERACT'
7546 include 'COMMON.DERIV'
7547 include 'COMMON.CHAIN'
7548 include 'COMMON.NAMES'
7549 include 'COMMON.IOUNITS'
7550 include 'COMMON.FFIELD'
7551 include 'COMMON.TORCNSTR'
7552 include 'COMMON.BOUNDS'
7553 include 'COMMON.CONTROL'
7554 ! 6/20/98 - dihedral angle constraints
7556 c do i=1,ndih_constr
7557 if (raw_psipred) then
7558 do i=idihconstr_start,idihconstr_end
7559 itori=idih_constr(i)
7561 gaudih_i=vpsipred(1,i)
7565 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7566 dexpcos_i=dexp(-cos_i*cos_i)
7567 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7568 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7569 & *cos_i*dexpcos_i/s**2
7571 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7572 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7574 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7575 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7576 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7577 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7578 & -wdihc*dlog(gaudih_i)
7582 do i=idihconstr_start,idihconstr_end
7583 itori=idih_constr(i)
7585 difi=pinorm(phii-phi0(i))
7586 if (difi.gt.drange(i)) then
7588 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7589 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7590 else if (difi.lt.-drange(i)) then
7592 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7593 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7603 c----------------------------------------------------------------------------
7604 c MODELLER restraint function
7605 subroutine e_modeller(ehomology_constr)
7607 include 'DIMENSIONS'
7609 double precision ehomology_constr
7610 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7611 integer katy, odleglosci, test7
7612 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7614 real*8 distance(max_template),distancek(max_template),
7615 & min_odl,godl(max_template),dih_diff(max_template)
7618 c FP - 30/10/2014 Temporary specifications for homology restraints
7620 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7622 double precision, dimension (maxres) :: guscdiff,usc_diff
7623 double precision, dimension (max_template) ::
7624 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7626 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7627 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7628 & betai,sum_sgodl,dij
7629 double precision dist,pinorm
7631 include 'COMMON.SBRIDGE'
7632 include 'COMMON.CHAIN'
7633 include 'COMMON.GEO'
7634 include 'COMMON.DERIV'
7635 include 'COMMON.LOCAL'
7636 include 'COMMON.INTERACT'
7637 include 'COMMON.VAR'
7638 include 'COMMON.IOUNITS'
7639 c include 'COMMON.MD'
7640 include 'COMMON.CONTROL'
7641 include 'COMMON.HOMOLOGY'
7642 include 'COMMON.QRESTR'
7644 c From subroutine Econstr_back
7646 include 'COMMON.NAMES'
7647 include 'COMMON.TIME1'
7652 distancek(i)=9999999.9
7658 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7660 C AL 5/2/14 - Introduce list of restraints
7661 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7663 write(iout,*) "------- dist restrs start -------"
7665 do ii = link_start_homo,link_end_homo
7669 c write (iout,*) "dij(",i,j,") =",dij
7671 do k=1,constr_homology
7672 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7673 if(.not.l_homo(k,ii)) then
7677 distance(k)=odl(k,ii)-dij
7678 c write (iout,*) "distance(",k,") =",distance(k)
7680 c For Gaussian-type Urestr
7682 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7683 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7684 c write (iout,*) "distancek(",k,") =",distancek(k)
7685 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7687 c For Lorentzian-type Urestr
7689 if (waga_dist.lt.0.0d0) then
7690 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7691 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7692 & (distance(k)**2+sigma_odlir(k,ii)**2))
7696 c min_odl=minval(distancek)
7700 do kk=1,constr_homology
7701 if(l_homo(kk,ii)) then
7702 min_odl=distancek(kk)
7706 do kk=1,constr_homology
7707 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7708 & min_odl=distancek(kk)
7712 c write (iout,* )"min_odl",min_odl
7714 write (iout,*) "ij dij",i,j,dij
7715 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7716 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7717 write (iout,* )"min_odl",min_odl
7722 if (waga_dist.ge.0.0d0) then
7728 do k=1,constr_homology
7729 c Nie wiem po co to liczycie jeszcze raz!
7730 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7731 c & (2*(sigma_odl(i,j,k))**2))
7732 if(.not.l_homo(k,ii)) cycle
7733 if (waga_dist.ge.0.0d0) then
7735 c For Gaussian-type Urestr
7737 godl(k)=dexp(-distancek(k)+min_odl)
7738 odleg2=odleg2+godl(k)
7740 c For Lorentzian-type Urestr
7743 odleg2=odleg2+distancek(k)
7746 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7747 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7748 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7749 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7752 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7753 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7755 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7756 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7758 if (waga_dist.ge.0.0d0) then
7760 c For Gaussian-type Urestr
7762 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7764 c For Lorentzian-type Urestr
7767 odleg=odleg+odleg2/constr_homology
7770 c write (iout,*) "odleg",odleg ! sum of -ln-s
7773 c For Gaussian-type Urestr
7775 if (waga_dist.ge.0.0d0) sum_godl=odleg2
7777 do k=1,constr_homology
7778 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7779 c & *waga_dist)+min_odl
7780 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7782 if(.not.l_homo(k,ii)) cycle
7783 if (waga_dist.ge.0.0d0) then
7784 c For Gaussian-type Urestr
7786 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7788 c For Lorentzian-type Urestr
7791 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7792 & sigma_odlir(k,ii)**2)**2)
7794 sum_sgodl=sum_sgodl+sgodl
7796 c sgodl2=sgodl2+sgodl
7797 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7798 c write(iout,*) "constr_homology=",constr_homology
7799 c write(iout,*) i, j, k, "TEST K"
7801 if (waga_dist.ge.0.0d0) then
7803 c For Gaussian-type Urestr
7805 grad_odl3=waga_homology(iset)*waga_dist
7806 & *sum_sgodl/(sum_godl*dij)
7808 c For Lorentzian-type Urestr
7811 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7812 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7813 grad_odl3=-waga_homology(iset)*waga_dist*
7814 & sum_sgodl/(constr_homology*dij)
7817 c grad_odl3=sum_sgodl/(sum_godl*dij)
7820 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7821 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7822 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7824 ccc write(iout,*) godl, sgodl, grad_odl3
7826 c grad_odl=grad_odl+grad_odl3
7829 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7830 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7831 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7832 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7833 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7834 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7835 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7836 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7837 c if (i.eq.25.and.j.eq.27) then
7838 c write(iout,*) "jik",jik,"i",i,"j",j
7839 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7840 c write(iout,*) "grad_odl3",grad_odl3
7841 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7842 c write(iout,*) "ggodl",ggodl
7843 c write(iout,*) "ghpbc(",jik,i,")",
7844 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
7848 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7849 ccc & dLOG(odleg2),"-odleg=", -odleg
7851 enddo ! ii-loop for dist
7853 write(iout,*) "------- dist restrs end -------"
7854 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7855 c & waga_d.eq.1.0d0) call sum_gradient
7857 c Pseudo-energy and gradient from dihedral-angle restraints from
7858 c homology templates
7859 c write (iout,*) "End of distance loop"
7862 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7864 write(iout,*) "------- dih restrs start -------"
7865 do i=idihconstr_start_homo,idihconstr_end_homo
7866 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7869 do i=idihconstr_start_homo,idihconstr_end_homo
7871 c betai=beta(i,i+1,i+2,i+3)
7873 c write (iout,*) "betai =",betai
7874 do k=1,constr_homology
7875 dih_diff(k)=pinorm(dih(k,i)-betai)
7876 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7877 cd & ,sigma_dih(k,i)
7878 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7879 c & -(6.28318-dih_diff(i,k))
7880 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7881 c & 6.28318+dih_diff(i,k)
7883 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7885 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7887 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7890 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7893 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7894 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7896 write (iout,*) "i",i," betai",betai," kat2",kat2
7897 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7899 if (kat2.le.1.0d-14) cycle
7900 kat=kat-dLOG(kat2/constr_homology)
7901 c write (iout,*) "kat",kat ! sum of -ln-s
7903 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7904 ccc & dLOG(kat2), "-kat=", -kat
7906 c ----------------------------------------------------------------------
7908 c ----------------------------------------------------------------------
7912 do k=1,constr_homology
7914 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
7916 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
7918 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7919 sum_sgdih=sum_sgdih+sgdih
7921 c grad_dih3=sum_sgdih/sum_gdih
7922 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7924 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7925 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7926 ccc & gloc(nphi+i-3,icg)
7927 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7929 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7931 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7932 ccc & gloc(nphi+i-3,icg)
7934 enddo ! i-loop for dih
7936 write(iout,*) "------- dih restrs end -------"
7939 c Pseudo-energy and gradient for theta angle restraints from
7940 c homology templates
7941 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7945 c For constr_homology reference structures (FP)
7947 c Uconst_back_tot=0.0d0
7950 c Econstr_back legacy
7952 c do i=ithet_start,ithet_end
7955 c do i=loc_start,loc_end
7958 duscdiffx(j,i)=0.0d0
7963 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7964 c write (iout,*) "waga_theta",waga_theta
7965 if (waga_theta.gt.0.0d0) then
7967 write (iout,*) "usampl",usampl
7968 write(iout,*) "------- theta restrs start -------"
7969 c do i=ithet_start,ithet_end
7970 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7973 c write (iout,*) "maxres",maxres,"nres",nres
7975 do i=ithet_start,ithet_end
7978 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7980 c Deviation of theta angles wrt constr_homology ref structures
7982 utheta_i=0.0d0 ! argument of Gaussian for single k
7983 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7984 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7985 c over residues in a fragment
7986 c write (iout,*) "theta(",i,")=",theta(i)
7987 do k=1,constr_homology
7989 c dtheta_i=theta(j)-thetaref(j,iref)
7990 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7991 theta_diff(k)=thetatpl(k,i)-theta(i)
7992 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7993 cd & ,sigma_theta(k,i)
7996 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7997 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7998 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7999 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8000 c Gradient for single Gaussian restraint in subr Econstr_back
8001 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8004 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8005 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8008 c Gradient for multiple Gaussian restraint
8009 sum_gtheta=gutheta_i
8011 do k=1,constr_homology
8012 c New generalized expr for multiple Gaussian from Econstr_back
8013 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8015 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8016 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8018 c Final value of gradient using same var as in Econstr_back
8019 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8020 & +sum_sgtheta/sum_gtheta*waga_theta
8021 & *waga_homology(iset)
8022 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8023 c & *waga_homology(iset)
8024 c dutheta(i)=sum_sgtheta/sum_gtheta
8026 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8027 Eval=Eval-dLOG(gutheta_i/constr_homology)
8028 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8029 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8030 c Uconst_back=Uconst_back+utheta(i)
8031 enddo ! (i-loop for theta)
8033 write(iout,*) "------- theta restrs end -------"
8037 c Deviation of local SC geometry
8039 c Separation of two i-loops (instructed by AL - 11/3/2014)
8041 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8042 c write (iout,*) "waga_d",waga_d
8045 write(iout,*) "------- SC restrs start -------"
8046 write (iout,*) "Initial duscdiff,duscdiffx"
8047 do i=loc_start,loc_end
8048 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8049 & (duscdiffx(jik,i),jik=1,3)
8052 do i=loc_start,loc_end
8053 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8054 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8055 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8056 c write(iout,*) "xxtab, yytab, zztab"
8057 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8058 do k=1,constr_homology
8060 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8061 c Original sign inverted for calc of gradients (s. Econstr_back)
8062 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8063 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8064 c write(iout,*) "dxx, dyy, dzz"
8065 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8067 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8068 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8069 c uscdiffk(k)=usc_diff(i)
8070 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8071 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8072 c & " guscdiff2",guscdiff2(k)
8073 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8074 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8075 c & xxref(j),yyref(j),zzref(j)
8080 c Generalized expression for multiple Gaussian acc to that for a single
8081 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8083 c Original implementation
8084 c sum_guscdiff=guscdiff(i)
8086 c sum_sguscdiff=0.0d0
8087 c do k=1,constr_homology
8088 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8089 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8090 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8093 c Implementation of new expressions for gradient (Jan. 2015)
8095 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8096 do k=1,constr_homology
8098 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8099 c before. Now the drivatives should be correct
8101 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8102 c Original sign inverted for calc of gradients (s. Econstr_back)
8103 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8104 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8106 c New implementation
8108 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8109 & sigma_d(k,i) ! for the grad wrt r'
8110 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8113 c New implementation
8114 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8116 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8117 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8118 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8119 duscdiff(jik,i)=duscdiff(jik,i)+
8120 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8121 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8122 duscdiffx(jik,i)=duscdiffx(jik,i)+
8123 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8124 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8127 write(iout,*) "jik",jik,"i",i
8128 write(iout,*) "dxx, dyy, dzz"
8129 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8130 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8131 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8132 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8133 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8134 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8135 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8136 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8137 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8138 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8139 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8140 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8141 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8142 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8143 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8149 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8150 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8152 c write (iout,*) i," uscdiff",uscdiff(i)
8154 c Put together deviations from local geometry
8156 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8157 c & wfrag_back(3,i,iset)*uscdiff(i)
8158 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8159 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8160 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8161 c Uconst_back=Uconst_back+usc_diff(i)
8163 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8165 c New implment: multiplied by sum_sguscdiff
8168 enddo ! (i-loop for dscdiff)
8173 write(iout,*) "------- SC restrs end -------"
8174 write (iout,*) "------ After SC loop in e_modeller ------"
8175 do i=loc_start,loc_end
8176 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8177 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8179 if (waga_theta.eq.1.0d0) then
8180 write (iout,*) "in e_modeller after SC restr end: dutheta"
8181 do i=ithet_start,ithet_end
8182 write (iout,*) i,dutheta(i)
8185 if (waga_d.eq.1.0d0) then
8186 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8188 write (iout,*) i,(duscdiff(j,i),j=1,3)
8189 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8194 c Total energy from homology restraints
8196 write (iout,*) "odleg",odleg," kat",kat
8199 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8201 c ehomology_constr=odleg+kat
8203 c For Lorentzian-type Urestr
8206 if (waga_dist.ge.0.0d0) then
8208 c For Gaussian-type Urestr
8210 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8211 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8212 c write (iout,*) "ehomology_constr=",ehomology_constr
8215 c For Lorentzian-type Urestr
8217 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8218 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8219 c write (iout,*) "ehomology_constr=",ehomology_constr
8222 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8223 & "Eval",waga_theta,eval,
8224 & "Erot",waga_d,Erot
8225 write (iout,*) "ehomology_constr",ehomology_constr
8231 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8232 747 format(a12,i4,i4,i4,f8.3,f8.3)
8233 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8234 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8235 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8236 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8238 c----------------------------------------------------------------------------
8239 C The rigorous attempt to derive energy function
8240 subroutine ebend_kcc(etheta)
8242 implicit real*8 (a-h,o-z)
8243 include 'DIMENSIONS'
8244 include 'COMMON.VAR'
8245 include 'COMMON.GEO'
8246 include 'COMMON.LOCAL'
8247 include 'COMMON.TORSION'
8248 include 'COMMON.INTERACT'
8249 include 'COMMON.DERIV'
8250 include 'COMMON.CHAIN'
8251 include 'COMMON.NAMES'
8252 include 'COMMON.IOUNITS'
8253 include 'COMMON.FFIELD'
8254 include 'COMMON.TORCNSTR'
8255 include 'COMMON.CONTROL'
8257 double precision thybt1(maxang_kcc)
8258 C Set lprn=.true. for debugging
8261 C print *,"wchodze kcc"
8262 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8264 do i=ithet_start,ithet_end
8265 c print *,i,itype(i-1),itype(i),itype(i-2)
8266 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8267 & .or.itype(i).eq.ntyp1) cycle
8268 iti=iabs(itortyp(itype(i-1)))
8269 sinthet=dsin(theta(i))
8270 costhet=dcos(theta(i))
8271 do j=1,nbend_kcc_Tb(iti)
8272 thybt1(j)=v1bend_chyb(j,iti)
8274 sumth1thyb=v1bend_chyb(0,iti)+
8275 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8276 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8278 ihelp=nbend_kcc_Tb(iti)-1
8279 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8280 etheta=etheta+sumth1thyb
8281 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8282 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8286 c-------------------------------------------------------------------------------------
8287 subroutine etheta_constr(ethetacnstr)
8289 implicit real*8 (a-h,o-z)
8290 include 'DIMENSIONS'
8291 include 'COMMON.VAR'
8292 include 'COMMON.GEO'
8293 include 'COMMON.LOCAL'
8294 include 'COMMON.TORSION'
8295 include 'COMMON.INTERACT'
8296 include 'COMMON.DERIV'
8297 include 'COMMON.CHAIN'
8298 include 'COMMON.NAMES'
8299 include 'COMMON.IOUNITS'
8300 include 'COMMON.FFIELD'
8301 include 'COMMON.TORCNSTR'
8302 include 'COMMON.CONTROL'
8304 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8305 do i=ithetaconstr_start,ithetaconstr_end
8306 itheta=itheta_constr(i)
8307 thetiii=theta(itheta)
8308 difi=pinorm(thetiii-theta_constr0(i))
8309 if (difi.gt.theta_drange(i)) then
8310 difi=difi-theta_drange(i)
8311 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8312 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8313 & +for_thet_constr(i)*difi**3
8314 else if (difi.lt.-drange(i)) then
8316 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8317 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8318 & +for_thet_constr(i)*difi**3
8322 if (energy_dec) then
8323 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8324 & i,itheta,rad2deg*thetiii,
8325 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8326 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8327 & gloc(itheta+nphi-2,icg)
8332 c------------------------------------------------------------------------------
8333 subroutine eback_sc_corr(esccor)
8334 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8335 c conformational states; temporarily implemented as differences
8336 c between UNRES torsional potentials (dependent on three types of
8337 c residues) and the torsional potentials dependent on all 20 types
8338 c of residues computed from AM1 energy surfaces of terminally-blocked
8339 c amino-acid residues.
8340 implicit real*8 (a-h,o-z)
8341 include 'DIMENSIONS'
8342 include 'COMMON.VAR'
8343 include 'COMMON.GEO'
8344 include 'COMMON.LOCAL'
8345 include 'COMMON.TORSION'
8346 include 'COMMON.SCCOR'
8347 include 'COMMON.INTERACT'
8348 include 'COMMON.DERIV'
8349 include 'COMMON.CHAIN'
8350 include 'COMMON.NAMES'
8351 include 'COMMON.IOUNITS'
8352 include 'COMMON.FFIELD'
8353 include 'COMMON.CONTROL'
8355 C Set lprn=.true. for debugging
8358 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8360 do i=itau_start,itau_end
8361 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8363 isccori=isccortyp(itype(i-2))
8364 isccori1=isccortyp(itype(i-1))
8365 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8367 do intertyp=1,3 !intertyp
8368 cc Added 09 May 2012 (Adasko)
8369 cc Intertyp means interaction type of backbone mainchain correlation:
8370 c 1 = SC...Ca...Ca...Ca
8371 c 2 = Ca...Ca...Ca...SC
8372 c 3 = SC...Ca...Ca...SCi
8374 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8375 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8376 & (itype(i-1).eq.ntyp1)))
8377 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8378 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8379 & .or.(itype(i).eq.ntyp1)))
8380 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8381 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8382 & (itype(i-3).eq.ntyp1)))) cycle
8383 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8384 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8386 do j=1,nterm_sccor(isccori,isccori1)
8387 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8388 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8389 cosphi=dcos(j*tauangle(intertyp,i))
8390 sinphi=dsin(j*tauangle(intertyp,i))
8391 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8392 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8394 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8395 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8397 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8398 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8399 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8400 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8401 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8408 c----------------------------------------------------------------------------
8409 subroutine multibody(ecorr)
8410 C This subroutine calculates multi-body contributions to energy following
8411 C the idea of Skolnick et al. If side chains I and J make a contact and
8412 C at the same time side chains I+1 and J+1 make a contact, an extra
8413 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8414 implicit real*8 (a-h,o-z)
8415 include 'DIMENSIONS'
8416 include 'COMMON.IOUNITS'
8417 include 'COMMON.DERIV'
8418 include 'COMMON.INTERACT'
8419 include 'COMMON.CONTACTS'
8420 include 'COMMON.CONTMAT'
8421 include 'COMMON.CORRMAT'
8422 double precision gx(3),gx1(3)
8425 C Set lprn=.true. for debugging
8429 write (iout,'(a)') 'Contact function values:'
8431 write (iout,'(i2,20(1x,i2,f10.5))')
8432 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8447 num_conti=num_cont(i)
8448 num_conti1=num_cont(i1)
8453 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8454 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8455 cd & ' ishift=',ishift
8456 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8457 C The system gains extra energy.
8458 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8459 endif ! j1==j+-ishift
8468 c------------------------------------------------------------------------------
8469 double precision function esccorr(i,j,k,l,jj,kk)
8470 implicit real*8 (a-h,o-z)
8471 include 'DIMENSIONS'
8472 include 'COMMON.IOUNITS'
8473 include 'COMMON.DERIV'
8474 include 'COMMON.INTERACT'
8475 include 'COMMON.CONTACTS'
8476 include 'COMMON.CONTMAT'
8477 include 'COMMON.CORRMAT'
8478 include 'COMMON.SHIELD'
8479 double precision gx(3),gx1(3)
8484 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8485 C Calculate the multi-body contribution to energy.
8486 C Calculate multi-body contributions to the gradient.
8487 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8488 cd & k,l,(gacont(m,kk,k),m=1,3)
8490 gx(m) =ekl*gacont(m,jj,i)
8491 gx1(m)=eij*gacont(m,kk,k)
8492 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8493 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8494 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8495 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8499 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8504 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8510 c------------------------------------------------------------------------------
8511 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8512 C This subroutine calculates multi-body contributions to hydrogen-bonding
8513 implicit real*8 (a-h,o-z)
8514 include 'DIMENSIONS'
8515 include 'COMMON.IOUNITS'
8518 parameter (max_cont=maxconts)
8519 parameter (max_dim=26)
8520 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8521 double precision zapas(max_dim,maxconts,max_fg_procs),
8522 & zapas_recv(max_dim,maxconts,max_fg_procs)
8523 common /przechowalnia/ zapas
8524 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8525 & status_array(MPI_STATUS_SIZE,maxconts*2)
8527 include 'COMMON.SETUP'
8528 include 'COMMON.FFIELD'
8529 include 'COMMON.DERIV'
8530 include 'COMMON.INTERACT'
8531 include 'COMMON.CONTACTS'
8532 include 'COMMON.CONTMAT'
8533 include 'COMMON.CORRMAT'
8534 include 'COMMON.CONTROL'
8535 include 'COMMON.LOCAL'
8536 double precision gx(3),gx1(3),time00
8539 C Set lprn=.true. for debugging
8544 if (nfgtasks.le.1) goto 30
8546 write (iout,'(a)') 'Contact function values before RECEIVE:'
8548 write (iout,'(2i3,50(1x,i2,f5.2))')
8549 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8550 & j=1,num_cont_hb(i))
8554 do i=1,ntask_cont_from
8557 do i=1,ntask_cont_to
8560 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8562 C Make the list of contacts to send to send to other procesors
8563 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8565 do i=iturn3_start,iturn3_end
8566 c write (iout,*) "make contact list turn3",i," num_cont",
8568 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8570 do i=iturn4_start,iturn4_end
8571 c write (iout,*) "make contact list turn4",i," num_cont",
8573 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8577 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8579 do j=1,num_cont_hb(i)
8582 iproc=iint_sent_local(k,jjc,ii)
8583 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8584 if (iproc.gt.0) then
8585 ncont_sent(iproc)=ncont_sent(iproc)+1
8586 nn=ncont_sent(iproc)
8588 zapas(2,nn,iproc)=jjc
8589 zapas(3,nn,iproc)=facont_hb(j,i)
8590 zapas(4,nn,iproc)=ees0p(j,i)
8591 zapas(5,nn,iproc)=ees0m(j,i)
8592 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8593 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8594 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8595 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8596 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8597 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8598 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8599 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8600 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8601 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8602 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8603 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8604 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8605 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8606 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8607 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8608 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8609 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8610 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8611 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8612 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8619 & "Numbers of contacts to be sent to other processors",
8620 & (ncont_sent(i),i=1,ntask_cont_to)
8621 write (iout,*) "Contacts sent"
8622 do ii=1,ntask_cont_to
8624 iproc=itask_cont_to(ii)
8625 write (iout,*) nn," contacts to processor",iproc,
8626 & " of CONT_TO_COMM group"
8628 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8636 CorrelID1=nfgtasks+fg_rank+1
8638 C Receive the numbers of needed contacts from other processors
8639 do ii=1,ntask_cont_from
8640 iproc=itask_cont_from(ii)
8642 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8643 & FG_COMM,req(ireq),IERR)
8645 c write (iout,*) "IRECV ended"
8647 C Send the number of contacts needed by other processors
8648 do ii=1,ntask_cont_to
8649 iproc=itask_cont_to(ii)
8651 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8652 & FG_COMM,req(ireq),IERR)
8654 c write (iout,*) "ISEND ended"
8655 c write (iout,*) "number of requests (nn)",ireq
8658 & call MPI_Waitall(ireq,req,status_array,ierr)
8660 c & "Numbers of contacts to be received from other processors",
8661 c & (ncont_recv(i),i=1,ntask_cont_from)
8665 do ii=1,ntask_cont_from
8666 iproc=itask_cont_from(ii)
8668 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8669 c & " of CONT_TO_COMM group"
8673 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8674 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8675 c write (iout,*) "ireq,req",ireq,req(ireq)
8678 C Send the contacts to processors that need them
8679 do ii=1,ntask_cont_to
8680 iproc=itask_cont_to(ii)
8682 c write (iout,*) nn," contacts to processor",iproc,
8683 c & " of CONT_TO_COMM group"
8686 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8687 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8688 c write (iout,*) "ireq,req",ireq,req(ireq)
8690 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8694 c write (iout,*) "number of requests (contacts)",ireq
8695 c write (iout,*) "req",(req(i),i=1,4)
8698 & call MPI_Waitall(ireq,req,status_array,ierr)
8699 do iii=1,ntask_cont_from
8700 iproc=itask_cont_from(iii)
8703 write (iout,*) "Received",nn," contacts from processor",iproc,
8704 & " of CONT_FROM_COMM group"
8707 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8712 ii=zapas_recv(1,i,iii)
8713 c Flag the received contacts to prevent double-counting
8714 jj=-zapas_recv(2,i,iii)
8715 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8717 nnn=num_cont_hb(ii)+1
8720 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8721 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8722 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8723 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8724 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8725 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8726 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8727 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8728 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8729 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8730 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8731 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8732 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8733 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8734 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8735 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8736 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8737 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8738 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8739 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8740 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8741 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8742 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8743 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8747 write (iout,'(a)') 'Contact function values after receive:'
8749 write (iout,'(2i3,50(1x,i3,f5.2))')
8750 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8751 & j=1,num_cont_hb(i))
8758 write (iout,'(a)') 'Contact function values:'
8760 write (iout,'(2i3,50(1x,i3,f5.2))')
8761 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8762 & j=1,num_cont_hb(i))
8767 C Remove the loop below after debugging !!!
8774 C Calculate the local-electrostatic correlation terms
8775 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8777 num_conti=num_cont_hb(i)
8778 num_conti1=num_cont_hb(i+1)
8785 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8786 c & ' jj=',jj,' kk=',kk
8788 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8789 & .or. j.lt.0 .and. j1.gt.0) .and.
8790 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8791 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8792 C The system gains extra energy.
8793 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8794 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8795 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8797 else if (j1.eq.j) then
8798 C Contacts I-J and I-(J+1) occur simultaneously.
8799 C The system loses extra energy.
8800 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8805 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8806 c & ' jj=',jj,' kk=',kk
8808 C Contacts I-J and (I+1)-J occur simultaneously.
8809 C The system loses extra energy.
8810 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8817 c------------------------------------------------------------------------------
8818 subroutine add_hb_contact(ii,jj,itask)
8819 implicit real*8 (a-h,o-z)
8820 include "DIMENSIONS"
8821 include "COMMON.IOUNITS"
8824 parameter (max_cont=maxconts)
8825 parameter (max_dim=26)
8826 include "COMMON.CONTACTS"
8827 include 'COMMON.CONTMAT'
8828 include 'COMMON.CORRMAT'
8829 double precision zapas(max_dim,maxconts,max_fg_procs),
8830 & zapas_recv(max_dim,maxconts,max_fg_procs)
8831 common /przechowalnia/ zapas
8832 integer i,j,ii,jj,iproc,itask(4),nn
8833 c write (iout,*) "itask",itask
8836 if (iproc.gt.0) then
8837 do j=1,num_cont_hb(ii)
8839 c write (iout,*) "i",ii," j",jj," jjc",jjc
8841 ncont_sent(iproc)=ncont_sent(iproc)+1
8842 nn=ncont_sent(iproc)
8843 zapas(1,nn,iproc)=ii
8844 zapas(2,nn,iproc)=jjc
8845 zapas(3,nn,iproc)=facont_hb(j,ii)
8846 zapas(4,nn,iproc)=ees0p(j,ii)
8847 zapas(5,nn,iproc)=ees0m(j,ii)
8848 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8849 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8850 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8851 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8852 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8853 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8854 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8855 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8856 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8857 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8858 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8859 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8860 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8861 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8862 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8863 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8864 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8865 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8866 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8867 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8868 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8876 c------------------------------------------------------------------------------
8877 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8879 C This subroutine calculates multi-body contributions to hydrogen-bonding
8880 implicit real*8 (a-h,o-z)
8881 include 'DIMENSIONS'
8882 include 'COMMON.IOUNITS'
8885 parameter (max_cont=maxconts)
8886 parameter (max_dim=70)
8887 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8888 double precision zapas(max_dim,maxconts,max_fg_procs),
8889 & zapas_recv(max_dim,maxconts,max_fg_procs)
8890 common /przechowalnia/ zapas
8891 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8892 & status_array(MPI_STATUS_SIZE,maxconts*2)
8894 include 'COMMON.SETUP'
8895 include 'COMMON.FFIELD'
8896 include 'COMMON.DERIV'
8897 include 'COMMON.LOCAL'
8898 include 'COMMON.INTERACT'
8899 include 'COMMON.CONTACTS'
8900 include 'COMMON.CONTMAT'
8901 include 'COMMON.CORRMAT'
8902 include 'COMMON.CHAIN'
8903 include 'COMMON.CONTROL'
8904 include 'COMMON.SHIELD'
8905 double precision gx(3),gx1(3)
8906 integer num_cont_hb_old(maxres)
8908 double precision eello4,eello5,eelo6,eello_turn6
8909 external eello4,eello5,eello6,eello_turn6
8910 C Set lprn=.true. for debugging
8915 num_cont_hb_old(i)=num_cont_hb(i)
8919 if (nfgtasks.le.1) goto 30
8921 write (iout,'(a)') 'Contact function values before RECEIVE:'
8923 write (iout,'(2i3,50(1x,i2,f5.2))')
8924 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8925 & j=1,num_cont_hb(i))
8928 do i=1,ntask_cont_from
8931 do i=1,ntask_cont_to
8934 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8936 C Make the list of contacts to send to send to other procesors
8937 do i=iturn3_start,iturn3_end
8938 c write (iout,*) "make contact list turn3",i," num_cont",
8940 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8942 do i=iturn4_start,iturn4_end
8943 c write (iout,*) "make contact list turn4",i," num_cont",
8945 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8949 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8951 do j=1,num_cont_hb(i)
8954 iproc=iint_sent_local(k,jjc,ii)
8955 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8956 if (iproc.ne.0) then
8957 ncont_sent(iproc)=ncont_sent(iproc)+1
8958 nn=ncont_sent(iproc)
8960 zapas(2,nn,iproc)=jjc
8961 zapas(3,nn,iproc)=d_cont(j,i)
8965 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8970 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8978 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8989 & "Numbers of contacts to be sent to other processors",
8990 & (ncont_sent(i),i=1,ntask_cont_to)
8991 write (iout,*) "Contacts sent"
8992 do ii=1,ntask_cont_to
8994 iproc=itask_cont_to(ii)
8995 write (iout,*) nn," contacts to processor",iproc,
8996 & " of CONT_TO_COMM group"
8998 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9006 CorrelID1=nfgtasks+fg_rank+1
9008 C Receive the numbers of needed contacts from other processors
9009 do ii=1,ntask_cont_from
9010 iproc=itask_cont_from(ii)
9012 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9013 & FG_COMM,req(ireq),IERR)
9015 c write (iout,*) "IRECV ended"
9017 C Send the number of contacts needed by other processors
9018 do ii=1,ntask_cont_to
9019 iproc=itask_cont_to(ii)
9021 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9022 & FG_COMM,req(ireq),IERR)
9024 c write (iout,*) "ISEND ended"
9025 c write (iout,*) "number of requests (nn)",ireq
9028 & call MPI_Waitall(ireq,req,status_array,ierr)
9030 c & "Numbers of contacts to be received from other processors",
9031 c & (ncont_recv(i),i=1,ntask_cont_from)
9035 do ii=1,ntask_cont_from
9036 iproc=itask_cont_from(ii)
9038 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9039 c & " of CONT_TO_COMM group"
9043 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9044 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9045 c write (iout,*) "ireq,req",ireq,req(ireq)
9048 C Send the contacts to processors that need them
9049 do ii=1,ntask_cont_to
9050 iproc=itask_cont_to(ii)
9052 c write (iout,*) nn," contacts to processor",iproc,
9053 c & " of CONT_TO_COMM group"
9056 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9057 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9058 c write (iout,*) "ireq,req",ireq,req(ireq)
9060 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9064 c write (iout,*) "number of requests (contacts)",ireq
9065 c write (iout,*) "req",(req(i),i=1,4)
9068 & call MPI_Waitall(ireq,req,status_array,ierr)
9069 do iii=1,ntask_cont_from
9070 iproc=itask_cont_from(iii)
9073 write (iout,*) "Received",nn," contacts from processor",iproc,
9074 & " of CONT_FROM_COMM group"
9077 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9082 ii=zapas_recv(1,i,iii)
9083 c Flag the received contacts to prevent double-counting
9084 jj=-zapas_recv(2,i,iii)
9085 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9087 nnn=num_cont_hb(ii)+1
9090 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9094 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9099 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9107 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9115 write (iout,'(a)') 'Contact function values after receive:'
9117 write (iout,'(2i3,50(1x,i3,5f6.3))')
9118 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9119 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9126 write (iout,'(a)') 'Contact function values:'
9128 write (iout,'(2i3,50(1x,i2,5f6.3))')
9129 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9130 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9136 C Remove the loop below after debugging !!!
9143 C Calculate the dipole-dipole interaction energies
9144 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9145 do i=iatel_s,iatel_e+1
9146 num_conti=num_cont_hb(i)
9155 C Calculate the local-electrostatic correlation terms
9156 c write (iout,*) "gradcorr5 in eello5 before loop"
9158 c write (iout,'(i5,3f10.5)')
9159 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9161 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9162 c write (iout,*) "corr loop i",i
9164 num_conti=num_cont_hb(i)
9165 num_conti1=num_cont_hb(i+1)
9172 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9173 c & ' jj=',jj,' kk=',kk
9174 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9175 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9176 & .or. j.lt.0 .and. j1.gt.0) .and.
9177 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9178 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9179 C The system gains extra energy.
9181 sqd1=dsqrt(d_cont(jj,i))
9182 sqd2=dsqrt(d_cont(kk,i1))
9183 sred_geom = sqd1*sqd2
9184 IF (sred_geom.lt.cutoff_corr) THEN
9185 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9187 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9188 cd & ' jj=',jj,' kk=',kk
9189 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9190 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9192 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9193 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9196 cd write (iout,*) 'sred_geom=',sred_geom,
9197 cd & ' ekont=',ekont,' fprim=',fprimcont,
9198 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9199 cd write (iout,*) "g_contij",g_contij
9200 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9201 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9202 call calc_eello(i,jp,i+1,jp1,jj,kk)
9203 if (wcorr4.gt.0.0d0)
9204 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9205 CC & *fac_shield(i)**2*fac_shield(j)**2
9206 if (energy_dec.and.wcorr4.gt.0.0d0)
9207 1 write (iout,'(a6,4i5,0pf7.3)')
9208 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9209 c write (iout,*) "gradcorr5 before eello5"
9211 c write (iout,'(i5,3f10.5)')
9212 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9214 if (wcorr5.gt.0.0d0)
9215 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9216 c write (iout,*) "gradcorr5 after eello5"
9218 c write (iout,'(i5,3f10.5)')
9219 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9221 if (energy_dec.and.wcorr5.gt.0.0d0)
9222 1 write (iout,'(a6,4i5,0pf7.3)')
9223 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9224 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9225 cd write(2,*)'ijkl',i,jp,i+1,jp1
9226 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9227 & .or. wturn6.eq.0.0d0))then
9228 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9229 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9230 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9231 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9232 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9233 cd & 'ecorr6=',ecorr6
9234 cd write (iout,'(4e15.5)') sred_geom,
9235 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9236 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9237 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9238 else if (wturn6.gt.0.0d0
9239 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9240 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9241 eturn6=eturn6+eello_turn6(i,jj,kk)
9242 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9243 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9244 cd write (2,*) 'multibody_eello:eturn6',eturn6
9253 num_cont_hb(i)=num_cont_hb_old(i)
9255 c write (iout,*) "gradcorr5 in eello5"
9257 c write (iout,'(i5,3f10.5)')
9258 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9262 c------------------------------------------------------------------------------
9263 subroutine add_hb_contact_eello(ii,jj,itask)
9264 implicit real*8 (a-h,o-z)
9265 include "DIMENSIONS"
9266 include "COMMON.IOUNITS"
9269 parameter (max_cont=maxconts)
9270 parameter (max_dim=70)
9271 include "COMMON.CONTACTS"
9272 include 'COMMON.CONTMAT'
9273 include 'COMMON.CORRMAT'
9274 double precision zapas(max_dim,maxconts,max_fg_procs),
9275 & zapas_recv(max_dim,maxconts,max_fg_procs)
9276 common /przechowalnia/ zapas
9277 integer i,j,ii,jj,iproc,itask(4),nn
9278 c write (iout,*) "itask",itask
9281 if (iproc.gt.0) then
9282 do j=1,num_cont_hb(ii)
9284 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9286 ncont_sent(iproc)=ncont_sent(iproc)+1
9287 nn=ncont_sent(iproc)
9288 zapas(1,nn,iproc)=ii
9289 zapas(2,nn,iproc)=jjc
9290 zapas(3,nn,iproc)=d_cont(j,ii)
9294 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9299 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9307 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9319 c------------------------------------------------------------------------------
9320 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9321 implicit real*8 (a-h,o-z)
9322 include 'DIMENSIONS'
9323 include 'COMMON.IOUNITS'
9324 include 'COMMON.DERIV'
9325 include 'COMMON.INTERACT'
9326 include 'COMMON.CONTACTS'
9327 include 'COMMON.CONTMAT'
9328 include 'COMMON.CORRMAT'
9329 include 'COMMON.SHIELD'
9330 include 'COMMON.CONTROL'
9331 double precision gx(3),gx1(3)
9334 C print *,"wchodze",fac_shield(i),shield_mode
9342 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9344 C & fac_shield(i)**2*fac_shield(j)**2
9345 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9346 C Following 4 lines for diagnostics.
9351 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9352 c & 'Contacts ',i,j,
9353 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9354 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9356 C Calculate the multi-body contribution to energy.
9357 C ecorr=ecorr+ekont*ees
9358 C Calculate multi-body contributions to the gradient.
9359 coeffpees0pij=coeffp*ees0pij
9360 coeffmees0mij=coeffm*ees0mij
9361 coeffpees0pkl=coeffp*ees0pkl
9362 coeffmees0mkl=coeffm*ees0mkl
9364 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9365 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9366 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9367 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9368 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9369 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9370 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9371 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9372 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9373 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9374 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9375 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9376 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9377 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9378 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9379 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9380 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9381 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9382 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9383 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9384 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9385 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9386 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9387 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9388 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9393 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9394 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9395 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9396 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9401 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9402 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9403 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9404 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9407 c write (iout,*) "ehbcorr",ekont*ees
9408 C print *,ekont,ees,i,k
9410 C now gradient over shielding
9412 if (shield_mode.gt.0) then
9415 C print *,i,j,fac_shield(i),fac_shield(j),
9416 C &fac_shield(k),fac_shield(l)
9417 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9418 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9419 do ilist=1,ishield_list(i)
9420 iresshield=shield_list(ilist,i)
9422 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9424 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9426 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9427 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9431 do ilist=1,ishield_list(j)
9432 iresshield=shield_list(ilist,j)
9434 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9436 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9438 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9439 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9444 do ilist=1,ishield_list(k)
9445 iresshield=shield_list(ilist,k)
9447 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9449 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9451 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9452 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9456 do ilist=1,ishield_list(l)
9457 iresshield=shield_list(ilist,l)
9459 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9461 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9463 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9464 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9468 C print *,gshieldx(m,iresshield)
9470 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9471 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9472 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9473 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9474 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9475 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9476 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9477 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9479 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9480 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9481 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9482 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9483 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9484 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9485 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9486 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9494 C---------------------------------------------------------------------------
9495 subroutine dipole(i,j,jj)
9496 implicit real*8 (a-h,o-z)
9497 include 'DIMENSIONS'
9498 include 'COMMON.IOUNITS'
9499 include 'COMMON.CHAIN'
9500 include 'COMMON.FFIELD'
9501 include 'COMMON.DERIV'
9502 include 'COMMON.INTERACT'
9503 include 'COMMON.CONTACTS'
9504 include 'COMMON.CONTMAT'
9505 include 'COMMON.CORRMAT'
9506 include 'COMMON.TORSION'
9507 include 'COMMON.VAR'
9508 include 'COMMON.GEO'
9509 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9511 iti1 = itortyp(itype(i+1))
9512 if (j.lt.nres-1) then
9513 itj1 = itype2loc(itype(j+1))
9518 dipi(iii,1)=Ub2(iii,i)
9519 dipderi(iii)=Ub2der(iii,i)
9520 dipi(iii,2)=b1(iii,i+1)
9521 dipj(iii,1)=Ub2(iii,j)
9522 dipderj(iii)=Ub2der(iii,j)
9523 dipj(iii,2)=b1(iii,j+1)
9527 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9530 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9537 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9541 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9546 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9547 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9549 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9551 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9553 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9558 C---------------------------------------------------------------------------
9559 subroutine calc_eello(i,j,k,l,jj,kk)
9561 C This subroutine computes matrices and vectors needed to calculate
9562 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9564 implicit real*8 (a-h,o-z)
9565 include 'DIMENSIONS'
9566 include 'COMMON.IOUNITS'
9567 include 'COMMON.CHAIN'
9568 include 'COMMON.DERIV'
9569 include 'COMMON.INTERACT'
9570 include 'COMMON.CONTACTS'
9571 include 'COMMON.CONTMAT'
9572 include 'COMMON.CORRMAT'
9573 include 'COMMON.TORSION'
9574 include 'COMMON.VAR'
9575 include 'COMMON.GEO'
9576 include 'COMMON.FFIELD'
9577 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9578 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9581 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9582 cd & ' jj=',jj,' kk=',kk
9583 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9584 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9585 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9588 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9589 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9592 call transpose2(aa1(1,1),aa1t(1,1))
9593 call transpose2(aa2(1,1),aa2t(1,1))
9596 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9597 & aa1tder(1,1,lll,kkk))
9598 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9599 & aa2tder(1,1,lll,kkk))
9603 C parallel orientation of the two CA-CA-CA frames.
9605 iti=itype2loc(itype(i))
9609 itk1=itype2loc(itype(k+1))
9610 itj=itype2loc(itype(j))
9611 if (l.lt.nres-1) then
9612 itl1=itype2loc(itype(l+1))
9616 C A1 kernel(j+1) A2T
9618 cd write (iout,'(3f10.5,5x,3f10.5)')
9619 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9621 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9622 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9623 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9624 C Following matrices are needed only for 6-th order cumulants
9625 IF (wcorr6.gt.0.0d0) THEN
9626 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9627 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9628 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9629 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9630 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9631 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9632 & ADtEAderx(1,1,1,1,1,1))
9634 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9635 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9636 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9637 & ADtEA1derx(1,1,1,1,1,1))
9639 C End 6-th order cumulants
9642 cd write (2,*) 'In calc_eello6'
9644 cd write (2,*) 'iii=',iii
9646 cd write (2,*) 'kkk=',kkk
9648 cd write (2,'(3(2f10.5),5x)')
9649 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9654 call transpose2(EUgder(1,1,k),auxmat(1,1))
9655 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9656 call transpose2(EUg(1,1,k),auxmat(1,1))
9657 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9658 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9659 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9660 c in theta; to be sriten later.
9662 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9663 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9664 c call transpose2(EUg(1,1,k),auxmat(1,1))
9665 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9670 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9671 & EAEAderx(1,1,lll,kkk,iii,1))
9675 C A1T kernel(i+1) A2
9676 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9677 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9678 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9679 C Following matrices are needed only for 6-th order cumulants
9680 IF (wcorr6.gt.0.0d0) THEN
9681 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9682 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9683 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9684 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9685 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9686 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9687 & ADtEAderx(1,1,1,1,1,2))
9688 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9689 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9690 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9691 & ADtEA1derx(1,1,1,1,1,2))
9693 C End 6-th order cumulants
9694 call transpose2(EUgder(1,1,l),auxmat(1,1))
9695 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9696 call transpose2(EUg(1,1,l),auxmat(1,1))
9697 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9698 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9702 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9703 & EAEAderx(1,1,lll,kkk,iii,2))
9708 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9709 C They are needed only when the fifth- or the sixth-order cumulants are
9711 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9712 call transpose2(AEA(1,1,1),auxmat(1,1))
9713 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9714 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9715 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9716 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9717 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9718 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9719 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9720 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9721 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9722 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9723 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9724 call transpose2(AEA(1,1,2),auxmat(1,1))
9725 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9726 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9727 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9728 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9729 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9730 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9731 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9732 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9733 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9734 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9735 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9736 C Calculate the Cartesian derivatives of the vectors.
9740 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9741 call matvec2(auxmat(1,1),b1(1,i),
9742 & AEAb1derx(1,lll,kkk,iii,1,1))
9743 call matvec2(auxmat(1,1),Ub2(1,i),
9744 & AEAb2derx(1,lll,kkk,iii,1,1))
9745 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9746 & AEAb1derx(1,lll,kkk,iii,2,1))
9747 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9748 & AEAb2derx(1,lll,kkk,iii,2,1))
9749 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9750 call matvec2(auxmat(1,1),b1(1,j),
9751 & AEAb1derx(1,lll,kkk,iii,1,2))
9752 call matvec2(auxmat(1,1),Ub2(1,j),
9753 & AEAb2derx(1,lll,kkk,iii,1,2))
9754 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9755 & AEAb1derx(1,lll,kkk,iii,2,2))
9756 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9757 & AEAb2derx(1,lll,kkk,iii,2,2))
9764 C Antiparallel orientation of the two CA-CA-CA frames.
9766 iti=itype2loc(itype(i))
9770 itk1=itype2loc(itype(k+1))
9771 itl=itype2loc(itype(l))
9772 itj=itype2loc(itype(j))
9773 if (j.lt.nres-1) then
9774 itj1=itype2loc(itype(j+1))
9778 C A2 kernel(j-1)T A1T
9779 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9780 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9781 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9782 C Following matrices are needed only for 6-th order cumulants
9783 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9784 & j.eq.i+4 .and. l.eq.i+3)) THEN
9785 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9786 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9787 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9788 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9789 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9790 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9791 & ADtEAderx(1,1,1,1,1,1))
9792 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9793 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9794 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9795 & ADtEA1derx(1,1,1,1,1,1))
9797 C End 6-th order cumulants
9798 call transpose2(EUgder(1,1,k),auxmat(1,1))
9799 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9800 call transpose2(EUg(1,1,k),auxmat(1,1))
9801 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9802 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9806 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9807 & EAEAderx(1,1,lll,kkk,iii,1))
9811 C A2T kernel(i+1)T A1
9812 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9813 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9814 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9815 C Following matrices are needed only for 6-th order cumulants
9816 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9817 & j.eq.i+4 .and. l.eq.i+3)) THEN
9818 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9819 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9820 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9821 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9822 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9823 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9824 & ADtEAderx(1,1,1,1,1,2))
9825 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9826 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9827 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9828 & ADtEA1derx(1,1,1,1,1,2))
9830 C End 6-th order cumulants
9831 call transpose2(EUgder(1,1,j),auxmat(1,1))
9832 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9833 call transpose2(EUg(1,1,j),auxmat(1,1))
9834 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9835 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9839 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9840 & EAEAderx(1,1,lll,kkk,iii,2))
9845 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9846 C They are needed only when the fifth- or the sixth-order cumulants are
9848 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9849 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9850 call transpose2(AEA(1,1,1),auxmat(1,1))
9851 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9852 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9853 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9854 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9855 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9856 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9857 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9858 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9859 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9860 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9861 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9862 call transpose2(AEA(1,1,2),auxmat(1,1))
9863 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9864 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9865 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9866 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9867 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9868 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9869 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9870 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9871 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9872 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9873 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9874 C Calculate the Cartesian derivatives of the vectors.
9878 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9879 call matvec2(auxmat(1,1),b1(1,i),
9880 & AEAb1derx(1,lll,kkk,iii,1,1))
9881 call matvec2(auxmat(1,1),Ub2(1,i),
9882 & AEAb2derx(1,lll,kkk,iii,1,1))
9883 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9884 & AEAb1derx(1,lll,kkk,iii,2,1))
9885 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9886 & AEAb2derx(1,lll,kkk,iii,2,1))
9887 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9888 call matvec2(auxmat(1,1),b1(1,l),
9889 & AEAb1derx(1,lll,kkk,iii,1,2))
9890 call matvec2(auxmat(1,1),Ub2(1,l),
9891 & AEAb2derx(1,lll,kkk,iii,1,2))
9892 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9893 & AEAb1derx(1,lll,kkk,iii,2,2))
9894 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9895 & AEAb2derx(1,lll,kkk,iii,2,2))
9904 C---------------------------------------------------------------------------
9905 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9906 & KK,KKderg,AKA,AKAderg,AKAderx)
9910 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9911 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9912 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9917 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9919 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9922 cd if (lprn) write (2,*) 'In kernel'
9924 cd if (lprn) write (2,*) 'kkk=',kkk
9926 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9927 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9929 cd write (2,*) 'lll=',lll
9930 cd write (2,*) 'iii=1'
9932 cd write (2,'(3(2f10.5),5x)')
9933 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9936 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9937 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9939 cd write (2,*) 'lll=',lll
9940 cd write (2,*) 'iii=2'
9942 cd write (2,'(3(2f10.5),5x)')
9943 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9950 C---------------------------------------------------------------------------
9951 double precision function eello4(i,j,k,l,jj,kk)
9952 implicit real*8 (a-h,o-z)
9953 include 'DIMENSIONS'
9954 include 'COMMON.IOUNITS'
9955 include 'COMMON.CHAIN'
9956 include 'COMMON.DERIV'
9957 include 'COMMON.INTERACT'
9958 include 'COMMON.CONTACTS'
9959 include 'COMMON.CONTMAT'
9960 include 'COMMON.CORRMAT'
9961 include 'COMMON.TORSION'
9962 include 'COMMON.VAR'
9963 include 'COMMON.GEO'
9964 double precision pizda(2,2),ggg1(3),ggg2(3)
9965 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9969 cd print *,'eello4:',i,j,k,l,jj,kk
9970 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9971 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9972 cold eij=facont_hb(jj,i)
9973 cold ekl=facont_hb(kk,k)
9975 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9976 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9977 gcorr_loc(k-1)=gcorr_loc(k-1)
9978 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9980 gcorr_loc(l-1)=gcorr_loc(l-1)
9981 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9982 C Al 4/16/16: Derivatives in theta, to be added later.
9984 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9985 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9988 gcorr_loc(j-1)=gcorr_loc(j-1)
9989 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9991 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9992 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9998 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9999 & -EAEAderx(2,2,lll,kkk,iii,1)
10000 cd derx(lll,kkk,iii)=0.0d0
10004 cd gcorr_loc(l-1)=0.0d0
10005 cd gcorr_loc(j-1)=0.0d0
10006 cd gcorr_loc(k-1)=0.0d0
10008 cd write (iout,*)'Contacts have occurred for peptide groups',
10009 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10010 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10011 if (j.lt.nres-1) then
10018 if (l.lt.nres-1) then
10026 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10027 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10028 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10029 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10030 cgrad ghalf=0.5d0*ggg1(ll)
10031 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10032 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10033 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10034 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10035 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10036 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10037 cgrad ghalf=0.5d0*ggg2(ll)
10038 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10039 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10040 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10041 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10042 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10043 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10047 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10052 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10057 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10062 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10066 cd write (2,*) iii,gcorr_loc(iii)
10069 cd write (2,*) 'ekont',ekont
10070 cd write (iout,*) 'eello4',ekont*eel4
10073 C---------------------------------------------------------------------------
10074 double precision function eello5(i,j,k,l,jj,kk)
10075 implicit real*8 (a-h,o-z)
10076 include 'DIMENSIONS'
10077 include 'COMMON.IOUNITS'
10078 include 'COMMON.CHAIN'
10079 include 'COMMON.DERIV'
10080 include 'COMMON.INTERACT'
10081 include 'COMMON.CONTACTS'
10082 include 'COMMON.CONTMAT'
10083 include 'COMMON.CORRMAT'
10084 include 'COMMON.TORSION'
10085 include 'COMMON.VAR'
10086 include 'COMMON.GEO'
10087 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10088 double precision ggg1(3),ggg2(3)
10089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10091 C Parallel chains C
10094 C /l\ / \ \ / \ / \ / C
10095 C / \ / \ \ / \ / \ / C
10096 C j| o |l1 | o | o| o | | o |o C
10097 C \ |/k\| |/ \| / |/ \| |/ \| C
10098 C \i/ \ / \ / / \ / \ C
10100 C (I) (II) (III) (IV) C
10102 C eello5_1 eello5_2 eello5_3 eello5_4 C
10104 C Antiparallel chains C
10107 C /j\ / \ \ / \ / \ / C
10108 C / \ / \ \ / \ / \ / C
10109 C j1| o |l | o | o| o | | o |o C
10110 C \ |/k\| |/ \| / |/ \| |/ \| C
10111 C \i/ \ / \ / / \ / \ C
10113 C (I) (II) (III) (IV) C
10115 C eello5_1 eello5_2 eello5_3 eello5_4 C
10117 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10120 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10125 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10127 itk=itype2loc(itype(k))
10128 itl=itype2loc(itype(l))
10129 itj=itype2loc(itype(j))
10134 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10135 cd & eel5_3_num,eel5_4_num)
10139 derx(lll,kkk,iii)=0.0d0
10143 cd eij=facont_hb(jj,i)
10144 cd ekl=facont_hb(kk,k)
10146 cd write (iout,*)'Contacts have occurred for peptide groups',
10147 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10149 C Contribution from the graph I.
10150 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10151 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10152 call transpose2(EUg(1,1,k),auxmat(1,1))
10153 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10154 vv(1)=pizda(1,1)-pizda(2,2)
10155 vv(2)=pizda(1,2)+pizda(2,1)
10156 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10157 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10158 C Explicit gradient in virtual-dihedral angles.
10159 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10160 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10161 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10162 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10163 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10164 vv(1)=pizda(1,1)-pizda(2,2)
10165 vv(2)=pizda(1,2)+pizda(2,1)
10166 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10167 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10168 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10169 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10170 vv(1)=pizda(1,1)-pizda(2,2)
10171 vv(2)=pizda(1,2)+pizda(2,1)
10173 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10174 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10175 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10177 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10178 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10179 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10181 C Cartesian gradient
10185 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10187 vv(1)=pizda(1,1)-pizda(2,2)
10188 vv(2)=pizda(1,2)+pizda(2,1)
10189 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10190 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10191 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10197 C Contribution from graph II
10198 call transpose2(EE(1,1,k),auxmat(1,1))
10199 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10200 vv(1)=pizda(1,1)+pizda(2,2)
10201 vv(2)=pizda(2,1)-pizda(1,2)
10202 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10203 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10204 C Explicit gradient in virtual-dihedral angles.
10205 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10206 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10207 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10208 vv(1)=pizda(1,1)+pizda(2,2)
10209 vv(2)=pizda(2,1)-pizda(1,2)
10211 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10212 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10213 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10215 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10216 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10217 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10219 C Cartesian gradient
10223 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10225 vv(1)=pizda(1,1)+pizda(2,2)
10226 vv(2)=pizda(2,1)-pizda(1,2)
10227 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10228 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10229 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10237 C Parallel orientation
10238 C Contribution from graph III
10239 call transpose2(EUg(1,1,l),auxmat(1,1))
10240 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10241 vv(1)=pizda(1,1)-pizda(2,2)
10242 vv(2)=pizda(1,2)+pizda(2,1)
10243 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10244 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10245 C Explicit gradient in virtual-dihedral angles.
10246 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10247 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10248 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10249 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10250 vv(1)=pizda(1,1)-pizda(2,2)
10251 vv(2)=pizda(1,2)+pizda(2,1)
10252 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10253 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10254 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10255 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10256 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10257 vv(1)=pizda(1,1)-pizda(2,2)
10258 vv(2)=pizda(1,2)+pizda(2,1)
10259 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10260 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10261 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10262 C Cartesian gradient
10266 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10268 vv(1)=pizda(1,1)-pizda(2,2)
10269 vv(2)=pizda(1,2)+pizda(2,1)
10270 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10271 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10272 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10277 C Contribution from graph IV
10279 call transpose2(EE(1,1,l),auxmat(1,1))
10280 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10281 vv(1)=pizda(1,1)+pizda(2,2)
10282 vv(2)=pizda(2,1)-pizda(1,2)
10283 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10284 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10285 C Explicit gradient in virtual-dihedral angles.
10286 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10287 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10288 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10289 vv(1)=pizda(1,1)+pizda(2,2)
10290 vv(2)=pizda(2,1)-pizda(1,2)
10291 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10292 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10293 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10294 C Cartesian gradient
10298 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10300 vv(1)=pizda(1,1)+pizda(2,2)
10301 vv(2)=pizda(2,1)-pizda(1,2)
10302 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10303 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10304 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10309 C Antiparallel orientation
10310 C Contribution from graph III
10312 call transpose2(EUg(1,1,j),auxmat(1,1))
10313 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10314 vv(1)=pizda(1,1)-pizda(2,2)
10315 vv(2)=pizda(1,2)+pizda(2,1)
10316 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10317 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10318 C Explicit gradient in virtual-dihedral angles.
10319 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10320 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10321 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10322 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10323 vv(1)=pizda(1,1)-pizda(2,2)
10324 vv(2)=pizda(1,2)+pizda(2,1)
10325 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10326 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10327 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10328 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10329 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10330 vv(1)=pizda(1,1)-pizda(2,2)
10331 vv(2)=pizda(1,2)+pizda(2,1)
10332 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10333 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10334 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10335 C Cartesian gradient
10339 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10341 vv(1)=pizda(1,1)-pizda(2,2)
10342 vv(2)=pizda(1,2)+pizda(2,1)
10343 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10344 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10345 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10350 C Contribution from graph IV
10352 call transpose2(EE(1,1,j),auxmat(1,1))
10353 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10354 vv(1)=pizda(1,1)+pizda(2,2)
10355 vv(2)=pizda(2,1)-pizda(1,2)
10356 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10357 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10358 C Explicit gradient in virtual-dihedral angles.
10359 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10360 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10361 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10362 vv(1)=pizda(1,1)+pizda(2,2)
10363 vv(2)=pizda(2,1)-pizda(1,2)
10364 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10365 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10366 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10367 C Cartesian gradient
10371 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10373 vv(1)=pizda(1,1)+pizda(2,2)
10374 vv(2)=pizda(2,1)-pizda(1,2)
10375 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10376 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10377 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10383 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10384 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10385 cd write (2,*) 'ijkl',i,j,k,l
10386 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10387 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10389 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10390 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10391 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10392 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10393 if (j.lt.nres-1) then
10400 if (l.lt.nres-1) then
10410 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10411 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10412 C summed up outside the subrouine as for the other subroutines
10413 C handling long-range interactions. The old code is commented out
10414 C with "cgrad" to keep track of changes.
10416 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10417 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10418 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10419 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10420 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10421 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10422 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10423 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10424 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10425 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10427 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10428 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10429 cgrad ghalf=0.5d0*ggg1(ll)
10431 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10432 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10433 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10434 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10435 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10436 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10437 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10438 cgrad ghalf=0.5d0*ggg2(ll)
10440 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10441 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10442 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10443 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10444 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10445 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10450 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10451 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10456 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10457 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10463 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10468 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10472 cd write (2,*) iii,g_corr5_loc(iii)
10475 cd write (2,*) 'ekont',ekont
10476 cd write (iout,*) 'eello5',ekont*eel5
10479 c--------------------------------------------------------------------------
10480 double precision function eello6(i,j,k,l,jj,kk)
10481 implicit real*8 (a-h,o-z)
10482 include 'DIMENSIONS'
10483 include 'COMMON.IOUNITS'
10484 include 'COMMON.CHAIN'
10485 include 'COMMON.DERIV'
10486 include 'COMMON.INTERACT'
10487 include 'COMMON.CONTACTS'
10488 include 'COMMON.CONTMAT'
10489 include 'COMMON.CORRMAT'
10490 include 'COMMON.TORSION'
10491 include 'COMMON.VAR'
10492 include 'COMMON.GEO'
10493 include 'COMMON.FFIELD'
10494 double precision ggg1(3),ggg2(3)
10495 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10500 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10508 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10509 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10513 derx(lll,kkk,iii)=0.0d0
10517 cd eij=facont_hb(jj,i)
10518 cd ekl=facont_hb(kk,k)
10524 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10525 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10526 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10527 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10528 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10529 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10531 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10532 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10533 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10534 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10535 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10536 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10540 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10542 C If turn contributions are considered, they will be handled separately.
10543 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10544 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10545 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10546 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10547 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10548 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10549 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10551 if (j.lt.nres-1) then
10558 if (l.lt.nres-1) then
10566 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10567 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10568 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10569 cgrad ghalf=0.5d0*ggg1(ll)
10571 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10572 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10573 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10574 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10575 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10576 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10577 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10578 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10579 cgrad ghalf=0.5d0*ggg2(ll)
10580 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10582 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10583 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10584 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10585 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10586 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10587 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10592 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10593 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10598 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10599 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10605 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10610 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10614 cd write (2,*) iii,g_corr6_loc(iii)
10617 cd write (2,*) 'ekont',ekont
10618 cd write (iout,*) 'eello6',ekont*eel6
10621 c--------------------------------------------------------------------------
10622 double precision function eello6_graph1(i,j,k,l,imat,swap)
10623 implicit real*8 (a-h,o-z)
10624 include 'DIMENSIONS'
10625 include 'COMMON.IOUNITS'
10626 include 'COMMON.CHAIN'
10627 include 'COMMON.DERIV'
10628 include 'COMMON.INTERACT'
10629 include 'COMMON.CONTACTS'
10630 include 'COMMON.CONTMAT'
10631 include 'COMMON.CORRMAT'
10632 include 'COMMON.TORSION'
10633 include 'COMMON.VAR'
10634 include 'COMMON.GEO'
10635 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10638 common /kutas/ lprn
10639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10641 C Parallel Antiparallel C
10647 C \ j|/k\| / \ |/k\|l / C
10648 C \ / \ / \ / \ / C
10652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10653 itk=itype2loc(itype(k))
10654 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10655 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10656 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10657 call transpose2(EUgC(1,1,k),auxmat(1,1))
10658 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10659 vv1(1)=pizda1(1,1)-pizda1(2,2)
10660 vv1(2)=pizda1(1,2)+pizda1(2,1)
10661 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10662 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10663 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10664 s5=scalar2(vv(1),Dtobr2(1,i))
10665 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10666 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10667 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10668 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10669 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10670 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10671 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10672 & +scalar2(vv(1),Dtobr2der(1,i)))
10673 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10674 vv1(1)=pizda1(1,1)-pizda1(2,2)
10675 vv1(2)=pizda1(1,2)+pizda1(2,1)
10676 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10677 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10679 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10680 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10681 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10682 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10683 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10685 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10686 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10687 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10688 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10689 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10691 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10692 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10693 vv1(1)=pizda1(1,1)-pizda1(2,2)
10694 vv1(2)=pizda1(1,2)+pizda1(2,1)
10695 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10696 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10697 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10698 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10707 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10708 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10709 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10710 call transpose2(EUgC(1,1,k),auxmat(1,1))
10711 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10713 vv1(1)=pizda1(1,1)-pizda1(2,2)
10714 vv1(2)=pizda1(1,2)+pizda1(2,1)
10715 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10716 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10717 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10718 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10719 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10720 s5=scalar2(vv(1),Dtobr2(1,i))
10721 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10727 c----------------------------------------------------------------------------
10728 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10729 implicit real*8 (a-h,o-z)
10730 include 'DIMENSIONS'
10731 include 'COMMON.IOUNITS'
10732 include 'COMMON.CHAIN'
10733 include 'COMMON.DERIV'
10734 include 'COMMON.INTERACT'
10735 include 'COMMON.CONTACTS'
10736 include 'COMMON.CONTMAT'
10737 include 'COMMON.CORRMAT'
10738 include 'COMMON.TORSION'
10739 include 'COMMON.VAR'
10740 include 'COMMON.GEO'
10742 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10743 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10745 common /kutas/ lprn
10746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10748 C Parallel Antiparallel C
10754 C \ j|/k\| \ |/k\|l C
10759 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10760 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10761 C AL 7/4/01 s1 would occur in the sixth-order moment,
10762 C but not in a cluster cumulant
10764 s1=dip(1,jj,i)*dip(1,kk,k)
10766 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10767 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10768 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10769 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10770 call transpose2(EUg(1,1,k),auxmat(1,1))
10771 call matmat2(ADtEA1(1,1,1),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 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10775 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10777 eello6_graph2=-(s1+s2+s3+s4)
10779 eello6_graph2=-(s2+s3+s4)
10781 c eello6_graph2=-s3
10782 C Derivatives in gamma(i-1)
10785 s1=dipderg(1,jj,i)*dip(1,kk,k)
10787 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10788 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10789 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10790 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10792 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10794 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10796 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10798 C Derivatives in gamma(k-1)
10800 s1=dip(1,jj,i)*dipderg(1,kk,k)
10802 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10803 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10804 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10805 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10806 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10807 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10808 vv(1)=pizda(1,1)-pizda(2,2)
10809 vv(2)=pizda(1,2)+pizda(2,1)
10810 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10812 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10814 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10816 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10817 C Derivatives in gamma(j-1) or gamma(l-1)
10820 s1=dipderg(3,jj,i)*dip(1,kk,k)
10822 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10823 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10824 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10825 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10826 vv(1)=pizda(1,1)-pizda(2,2)
10827 vv(2)=pizda(1,2)+pizda(2,1)
10828 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10831 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10833 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10836 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10837 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10839 C Derivatives in gamma(l-1) or gamma(j-1)
10842 s1=dip(1,jj,i)*dipderg(3,kk,k)
10844 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10845 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10846 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10847 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10848 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10849 vv(1)=pizda(1,1)-pizda(2,2)
10850 vv(2)=pizda(1,2)+pizda(2,1)
10851 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10854 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10856 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10859 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10860 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10862 C Cartesian derivatives.
10864 write (2,*) 'In eello6_graph2'
10866 write (2,*) 'iii=',iii
10868 write (2,*) 'kkk=',kkk
10870 write (2,'(3(2f10.5),5x)')
10871 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10881 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10883 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10886 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10888 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10889 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10891 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10892 call transpose2(EUg(1,1,k),auxmat(1,1))
10893 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10895 vv(1)=pizda(1,1)-pizda(2,2)
10896 vv(2)=pizda(1,2)+pizda(2,1)
10897 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10898 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10900 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10902 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10905 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10907 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10914 c----------------------------------------------------------------------------
10915 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10916 implicit real*8 (a-h,o-z)
10917 include 'DIMENSIONS'
10918 include 'COMMON.IOUNITS'
10919 include 'COMMON.CHAIN'
10920 include 'COMMON.DERIV'
10921 include 'COMMON.INTERACT'
10922 include 'COMMON.CONTACTS'
10923 include 'COMMON.CONTMAT'
10924 include 'COMMON.CORRMAT'
10925 include 'COMMON.TORSION'
10926 include 'COMMON.VAR'
10927 include 'COMMON.GEO'
10928 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10932 C Parallel Antiparallel C
10937 C /| o |o o| o |\ C
10938 C j|/k\| / |/k\|l / C
10943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10945 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10946 C energy moment and not to the cluster cumulant.
10947 iti=itortyp(itype(i))
10948 if (j.lt.nres-1) then
10949 itj1=itype2loc(itype(j+1))
10953 itk=itype2loc(itype(k))
10954 itk1=itype2loc(itype(k+1))
10955 if (l.lt.nres-1) then
10956 itl1=itype2loc(itype(l+1))
10961 s1=dip(4,jj,i)*dip(4,kk,k)
10963 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10964 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10965 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10966 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10967 call transpose2(EE(1,1,k),auxmat(1,1))
10968 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10969 vv(1)=pizda(1,1)+pizda(2,2)
10970 vv(2)=pizda(2,1)-pizda(1,2)
10971 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10972 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10973 cd & "sum",-(s2+s3+s4)
10975 eello6_graph3=-(s1+s2+s3+s4)
10977 eello6_graph3=-(s2+s3+s4)
10979 c eello6_graph3=-s4
10980 C Derivatives in gamma(k-1)
10981 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10982 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10983 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10984 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10985 C Derivatives in gamma(l-1)
10986 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10987 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10988 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10989 vv(1)=pizda(1,1)+pizda(2,2)
10990 vv(2)=pizda(2,1)-pizda(1,2)
10991 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10992 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10993 C Cartesian derivatives.
10999 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11001 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11004 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11006 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11007 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11009 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11010 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11012 vv(1)=pizda(1,1)+pizda(2,2)
11013 vv(2)=pizda(2,1)-pizda(1,2)
11014 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11016 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11018 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11021 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11023 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11025 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11031 c----------------------------------------------------------------------------
11032 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11033 implicit real*8 (a-h,o-z)
11034 include 'DIMENSIONS'
11035 include 'COMMON.IOUNITS'
11036 include 'COMMON.CHAIN'
11037 include 'COMMON.DERIV'
11038 include 'COMMON.INTERACT'
11039 include 'COMMON.CONTACTS'
11040 include 'COMMON.CONTMAT'
11041 include 'COMMON.CORRMAT'
11042 include 'COMMON.TORSION'
11043 include 'COMMON.VAR'
11044 include 'COMMON.GEO'
11045 include 'COMMON.FFIELD'
11046 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11047 & auxvec1(2),auxmat1(2,2)
11049 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11051 C Parallel Antiparallel C
11056 C /| o |o o| o |\ C
11057 C \ j|/k\| \ |/k\|l C
11062 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11064 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11065 C energy moment and not to the cluster cumulant.
11066 cd write (2,*) 'eello_graph4: wturn6',wturn6
11067 iti=itype2loc(itype(i))
11068 itj=itype2loc(itype(j))
11069 if (j.lt.nres-1) then
11070 itj1=itype2loc(itype(j+1))
11074 itk=itype2loc(itype(k))
11075 if (k.lt.nres-1) then
11076 itk1=itype2loc(itype(k+1))
11080 itl=itype2loc(itype(l))
11081 if (l.lt.nres-1) then
11082 itl1=itype2loc(itype(l+1))
11086 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11087 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11088 cd & ' itl',itl,' itl1',itl1
11090 if (imat.eq.1) then
11091 s1=dip(3,jj,i)*dip(3,kk,k)
11093 s1=dip(2,jj,j)*dip(2,kk,l)
11096 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11097 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11099 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11100 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11102 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11103 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11105 call transpose2(EUg(1,1,k),auxmat(1,1))
11106 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11107 vv(1)=pizda(1,1)-pizda(2,2)
11108 vv(2)=pizda(2,1)+pizda(1,2)
11109 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11110 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11112 eello6_graph4=-(s1+s2+s3+s4)
11114 eello6_graph4=-(s2+s3+s4)
11116 C Derivatives in gamma(i-1)
11119 if (imat.eq.1) then
11120 s1=dipderg(2,jj,i)*dip(3,kk,k)
11122 s1=dipderg(4,jj,j)*dip(2,kk,l)
11125 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11127 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11128 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11130 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11131 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11133 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11134 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11135 cd write (2,*) 'turn6 derivatives'
11137 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11139 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11143 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11145 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11149 C Derivatives in gamma(k-1)
11151 if (imat.eq.1) then
11152 s1=dip(3,jj,i)*dipderg(2,kk,k)
11154 s1=dip(2,jj,j)*dipderg(4,kk,l)
11157 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11158 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11160 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11161 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11163 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11164 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11166 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11167 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11168 vv(1)=pizda(1,1)-pizda(2,2)
11169 vv(2)=pizda(2,1)+pizda(1,2)
11170 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11171 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11173 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11175 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11179 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11181 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11184 C Derivatives in gamma(j-1) or gamma(l-1)
11185 if (l.eq.j+1 .and. l.gt.1) then
11186 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11187 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11188 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11189 vv(1)=pizda(1,1)-pizda(2,2)
11190 vv(2)=pizda(2,1)+pizda(1,2)
11191 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11192 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11193 else if (j.gt.1) then
11194 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11195 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11196 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11197 vv(1)=pizda(1,1)-pizda(2,2)
11198 vv(2)=pizda(2,1)+pizda(1,2)
11199 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11200 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11201 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11203 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11206 C Cartesian derivatives.
11212 if (imat.eq.1) then
11213 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11215 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11218 if (imat.eq.1) then
11219 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11221 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11225 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11227 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11229 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11230 & b1(1,j+1),auxvec(1))
11231 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11233 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11234 & b1(1,l+1),auxvec(1))
11235 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11237 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11239 vv(1)=pizda(1,1)-pizda(2,2)
11240 vv(2)=pizda(2,1)+pizda(1,2)
11241 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11243 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11245 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11248 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11251 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11254 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11256 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11258 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11262 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11264 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11267 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11269 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11277 c----------------------------------------------------------------------------
11278 double precision function eello_turn6(i,jj,kk)
11279 implicit real*8 (a-h,o-z)
11280 include 'DIMENSIONS'
11281 include 'COMMON.IOUNITS'
11282 include 'COMMON.CHAIN'
11283 include 'COMMON.DERIV'
11284 include 'COMMON.INTERACT'
11285 include 'COMMON.CONTACTS'
11286 include 'COMMON.CONTMAT'
11287 include 'COMMON.CORRMAT'
11288 include 'COMMON.TORSION'
11289 include 'COMMON.VAR'
11290 include 'COMMON.GEO'
11291 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11292 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11294 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11295 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11296 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11297 C the respective energy moment and not to the cluster cumulant.
11306 iti=itype2loc(itype(i))
11307 itk=itype2loc(itype(k))
11308 itk1=itype2loc(itype(k+1))
11309 itl=itype2loc(itype(l))
11310 itj=itype2loc(itype(j))
11311 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11312 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11313 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11318 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11320 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11324 derx_turn(lll,kkk,iii)=0.0d0
11331 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11333 cd write (2,*) 'eello6_5',eello6_5
11335 call transpose2(AEA(1,1,1),auxmat(1,1))
11336 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11337 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11338 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11340 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11341 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11342 s2 = scalar2(b1(1,k),vtemp1(1))
11344 call transpose2(AEA(1,1,2),atemp(1,1))
11345 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11346 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11347 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11349 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11350 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11351 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11353 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11354 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11355 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11356 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11357 ss13 = scalar2(b1(1,k),vtemp4(1))
11358 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11360 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11366 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11367 C Derivatives in gamma(i+2)
11371 call transpose2(AEA(1,1,1),auxmatd(1,1))
11372 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11373 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11374 call transpose2(AEAderg(1,1,2),atempd(1,1))
11375 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11376 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11378 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11379 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11380 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11386 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11387 C Derivatives in gamma(i+3)
11389 call transpose2(AEA(1,1,1),auxmatd(1,1))
11390 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11391 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11392 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11394 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11395 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11396 s2d = scalar2(b1(1,k),vtemp1d(1))
11398 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11399 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11401 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11403 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11404 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11405 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11413 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11414 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11416 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11417 & -0.5d0*ekont*(s2d+s12d)
11419 C Derivatives in gamma(i+4)
11420 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11421 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11422 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11424 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11425 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11426 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11434 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11436 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11438 C Derivatives in gamma(i+5)
11440 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11441 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11442 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11444 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11445 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11446 s2d = scalar2(b1(1,k),vtemp1d(1))
11448 call transpose2(AEA(1,1,2),atempd(1,1))
11449 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11450 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11452 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11453 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11455 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11456 ss13d = scalar2(b1(1,k),vtemp4d(1))
11457 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11465 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11466 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11468 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11469 & -0.5d0*ekont*(s2d+s12d)
11471 C Cartesian derivatives
11476 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11477 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11478 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11480 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11481 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11483 s2d = scalar2(b1(1,k),vtemp1d(1))
11485 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11486 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11487 s8d = -(atempd(1,1)+atempd(2,2))*
11488 & scalar2(cc(1,1,l),vtemp2(1))
11490 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11492 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11493 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11500 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11501 & - 0.5d0*(s1d+s2d)
11503 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11507 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11508 & - 0.5d0*(s8d+s12d)
11510 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11519 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11520 & achuj_tempd(1,1))
11521 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11522 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11523 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11524 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11525 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11527 ss13d = scalar2(b1(1,k),vtemp4d(1))
11528 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11529 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11533 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11534 cd & 16*eel_turn6_num
11536 if (j.lt.nres-1) then
11543 if (l.lt.nres-1) then
11551 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11552 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11553 cgrad ghalf=0.5d0*ggg1(ll)
11555 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11556 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11557 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11558 & +ekont*derx_turn(ll,2,1)
11559 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11560 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11561 & +ekont*derx_turn(ll,4,1)
11562 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11563 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11564 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11565 cgrad ghalf=0.5d0*ggg2(ll)
11567 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11568 & +ekont*derx_turn(ll,2,2)
11569 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11570 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11571 & +ekont*derx_turn(ll,4,2)
11572 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11573 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11574 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11579 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11584 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11590 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11595 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11599 cd write (2,*) iii,g_corr6_loc(iii)
11601 eello_turn6=ekont*eel_turn6
11602 cd write (2,*) 'ekont',ekont
11603 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11606 C-----------------------------------------------------------------------------
11608 double precision function scalar(u,v)
11609 !DIR$ INLINEALWAYS scalar
11611 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11614 double precision u(3),v(3)
11615 cd double precision sc
11623 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11626 crc-------------------------------------------------
11627 SUBROUTINE MATVEC2(A1,V1,V2)
11628 !DIR$ INLINEALWAYS MATVEC2
11630 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11632 implicit real*8 (a-h,o-z)
11633 include 'DIMENSIONS'
11634 DIMENSION A1(2,2),V1(2),V2(2)
11638 c 3 VI=VI+A1(I,K)*V1(K)
11642 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11643 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11648 C---------------------------------------
11649 SUBROUTINE MATMAT2(A1,A2,A3)
11651 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11653 implicit real*8 (a-h,o-z)
11654 include 'DIMENSIONS'
11655 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11656 c DIMENSION AI3(2,2)
11660 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11666 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11667 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11668 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11669 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11677 c-------------------------------------------------------------------------
11678 double precision function scalar2(u,v)
11679 !DIR$ INLINEALWAYS scalar2
11681 double precision u(2),v(2)
11682 double precision sc
11684 scalar2=u(1)*v(1)+u(2)*v(2)
11688 C-----------------------------------------------------------------------------
11690 subroutine transpose2(a,at)
11691 !DIR$ INLINEALWAYS transpose2
11693 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11696 double precision a(2,2),at(2,2)
11703 c--------------------------------------------------------------------------
11704 subroutine transpose(n,a,at)
11707 double precision a(n,n),at(n,n)
11715 C---------------------------------------------------------------------------
11716 subroutine prodmat3(a1,a2,kk,transp,prod)
11717 !DIR$ INLINEALWAYS prodmat3
11719 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11723 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11725 crc double precision auxmat(2,2),prod_(2,2)
11728 crc call transpose2(kk(1,1),auxmat(1,1))
11729 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11730 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11732 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11733 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11734 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11735 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11736 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11737 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11738 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11739 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11742 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11743 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11745 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11746 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11747 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11748 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11749 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11750 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11751 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11752 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11755 c call transpose2(a2(1,1),a2t(1,1))
11758 crc print *,((prod_(i,j),i=1,2),j=1,2)
11759 crc print *,((prod(i,j),i=1,2),j=1,2)
11763 CCC----------------------------------------------
11764 subroutine Eliptransfer(eliptran)
11765 implicit real*8 (a-h,o-z)
11766 include 'DIMENSIONS'
11767 include 'COMMON.GEO'
11768 include 'COMMON.VAR'
11769 include 'COMMON.LOCAL'
11770 include 'COMMON.CHAIN'
11771 include 'COMMON.DERIV'
11772 include 'COMMON.NAMES'
11773 include 'COMMON.INTERACT'
11774 include 'COMMON.IOUNITS'
11775 include 'COMMON.CALC'
11776 include 'COMMON.CONTROL'
11777 include 'COMMON.SPLITELE'
11778 include 'COMMON.SBRIDGE'
11779 C this is done by Adasko
11780 C print *,"wchodze"
11781 C structure of box:
11783 C--bordliptop-- buffore starts
11784 C--bufliptop--- here true lipid starts
11786 C--buflipbot--- lipid ends buffore starts
11787 C--bordlipbot--buffore ends
11789 do i=ilip_start,ilip_end
11791 if (itype(i).eq.ntyp1) cycle
11793 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11794 if (positi.le.0.0) positi=positi+boxzsize
11796 C first for peptide groups
11797 c for each residue check if it is in lipid or lipid water border area
11798 if ((positi.gt.bordlipbot)
11799 &.and.(positi.lt.bordliptop)) then
11800 C the energy transfer exist
11801 if (positi.lt.buflipbot) then
11802 C what fraction I am in
11804 & ((positi-bordlipbot)/lipbufthick)
11805 C lipbufthick is thickenes of lipid buffore
11806 sslip=sscalelip(fracinbuf)
11807 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11808 eliptran=eliptran+sslip*pepliptran
11809 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11810 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11811 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11813 C print *,"doing sccale for lower part"
11814 C print *,i,sslip,fracinbuf,ssgradlip
11815 elseif (positi.gt.bufliptop) then
11816 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11817 sslip=sscalelip(fracinbuf)
11818 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11819 eliptran=eliptran+sslip*pepliptran
11820 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11821 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11822 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11823 C print *, "doing sscalefor top part"
11824 C print *,i,sslip,fracinbuf,ssgradlip
11826 eliptran=eliptran+pepliptran
11827 C print *,"I am in true lipid"
11830 C eliptran=elpitran+0.0 ! I am in water
11833 C print *, "nic nie bylo w lipidzie?"
11834 C now multiply all by the peptide group transfer factor
11835 C eliptran=eliptran*pepliptran
11836 C now the same for side chains
11838 do i=ilip_start,ilip_end
11839 if (itype(i).eq.ntyp1) cycle
11840 positi=(mod(c(3,i+nres),boxzsize))
11841 if (positi.le.0) positi=positi+boxzsize
11842 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11843 c for each residue check if it is in lipid or lipid water border area
11844 C respos=mod(c(3,i+nres),boxzsize)
11845 C print *,positi,bordlipbot,buflipbot
11846 if ((positi.gt.bordlipbot)
11847 & .and.(positi.lt.bordliptop)) then
11848 C the energy transfer exist
11849 if (positi.lt.buflipbot) then
11851 & ((positi-bordlipbot)/lipbufthick)
11852 C lipbufthick is thickenes of lipid buffore
11853 sslip=sscalelip(fracinbuf)
11854 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11855 eliptran=eliptran+sslip*liptranene(itype(i))
11856 gliptranx(3,i)=gliptranx(3,i)
11857 &+ssgradlip*liptranene(itype(i))
11858 gliptranc(3,i-1)= gliptranc(3,i-1)
11859 &+ssgradlip*liptranene(itype(i))
11860 C print *,"doing sccale for lower part"
11861 elseif (positi.gt.bufliptop) then
11863 &((bordliptop-positi)/lipbufthick)
11864 sslip=sscalelip(fracinbuf)
11865 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11866 eliptran=eliptran+sslip*liptranene(itype(i))
11867 gliptranx(3,i)=gliptranx(3,i)
11868 &+ssgradlip*liptranene(itype(i))
11869 gliptranc(3,i-1)= gliptranc(3,i-1)
11870 &+ssgradlip*liptranene(itype(i))
11871 C print *, "doing sscalefor top part",sslip,fracinbuf
11873 eliptran=eliptran+liptranene(itype(i))
11874 C print *,"I am in true lipid"
11876 endif ! if in lipid or buffor
11878 C eliptran=elpitran+0.0 ! I am in water
11882 C---------------------------------------------------------
11883 C AFM soubroutine for constant force
11884 subroutine AFMforce(Eafmforce)
11885 implicit real*8 (a-h,o-z)
11886 include 'DIMENSIONS'
11887 include 'COMMON.GEO'
11888 include 'COMMON.VAR'
11889 include 'COMMON.LOCAL'
11890 include 'COMMON.CHAIN'
11891 include 'COMMON.DERIV'
11892 include 'COMMON.NAMES'
11893 include 'COMMON.INTERACT'
11894 include 'COMMON.IOUNITS'
11895 include 'COMMON.CALC'
11896 include 'COMMON.CONTROL'
11897 include 'COMMON.SPLITELE'
11898 include 'COMMON.SBRIDGE'
11903 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11904 dist=dist+diffafm(i)**2
11907 Eafmforce=-forceAFMconst*(dist-distafminit)
11909 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11910 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11912 C print *,'AFM',Eafmforce
11915 C---------------------------------------------------------
11916 C AFM subroutine with pseudoconstant velocity
11917 subroutine AFMvel(Eafmforce)
11918 implicit real*8 (a-h,o-z)
11919 include 'DIMENSIONS'
11920 include 'COMMON.GEO'
11921 include 'COMMON.VAR'
11922 include 'COMMON.LOCAL'
11923 include 'COMMON.CHAIN'
11924 include 'COMMON.DERIV'
11925 include 'COMMON.NAMES'
11926 include 'COMMON.INTERACT'
11927 include 'COMMON.IOUNITS'
11928 include 'COMMON.CALC'
11929 include 'COMMON.CONTROL'
11930 include 'COMMON.SPLITELE'
11931 include 'COMMON.SBRIDGE'
11933 C Only for check grad COMMENT if not used for checkgrad
11935 C--------------------------------------------------------
11936 C print *,"wchodze"
11940 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11941 dist=dist+diffafm(i)**2
11944 Eafmforce=0.5d0*forceAFMconst
11945 & *(distafminit+totTafm*velAFMconst-dist)**2
11946 C Eafmforce=-forceAFMconst*(dist-distafminit)
11948 gradafm(i,afmend-1)=-forceAFMconst*
11949 &(distafminit+totTafm*velAFMconst-dist)
11951 gradafm(i,afmbeg-1)=forceAFMconst*
11952 &(distafminit+totTafm*velAFMconst-dist)
11955 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11958 C-----------------------------------------------------------
11959 C first for shielding is setting of function of side-chains
11960 subroutine set_shield_fac
11961 implicit real*8 (a-h,o-z)
11962 include 'DIMENSIONS'
11963 include 'COMMON.CHAIN'
11964 include 'COMMON.DERIV'
11965 include 'COMMON.IOUNITS'
11966 include 'COMMON.SHIELD'
11967 include 'COMMON.INTERACT'
11968 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11969 double precision div77_81/0.974996043d0/,
11970 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11972 C the vector between center of side_chain and peptide group
11973 double precision pep_side(3),long,side_calf(3),
11974 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11975 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11976 C the line belowe needs to be changed for FGPROC>1
11978 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11980 Cif there two consequtive dummy atoms there is no peptide group between them
11981 C the line below has to be changed for FGPROC>1
11984 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11988 C first lets set vector conecting the ithe side-chain with kth side-chain
11989 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11990 C pep_side(j)=2.0d0
11991 C and vector conecting the side-chain with its proper calfa
11992 side_calf(j)=c(j,k+nres)-c(j,k)
11993 C side_calf(j)=2.0d0
11994 pept_group(j)=c(j,i)-c(j,i+1)
11995 C lets have their lenght
11996 dist_pep_side=pep_side(j)**2+dist_pep_side
11997 dist_side_calf=dist_side_calf+side_calf(j)**2
11998 dist_pept_group=dist_pept_group+pept_group(j)**2
12000 dist_pep_side=dsqrt(dist_pep_side)
12001 dist_pept_group=dsqrt(dist_pept_group)
12002 dist_side_calf=dsqrt(dist_side_calf)
12004 pep_side_norm(j)=pep_side(j)/dist_pep_side
12005 side_calf_norm(j)=dist_side_calf
12007 C now sscale fraction
12008 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12009 C print *,buff_shield,"buff"
12011 if (sh_frac_dist.le.0.0) cycle
12012 C If we reach here it means that this side chain reaches the shielding sphere
12013 C Lets add him to the list for gradient
12014 ishield_list(i)=ishield_list(i)+1
12015 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12016 C this list is essential otherwise problem would be O3
12017 shield_list(ishield_list(i),i)=k
12018 C Lets have the sscale value
12019 if (sh_frac_dist.gt.1.0) then
12020 scale_fac_dist=1.0d0
12022 sh_frac_dist_grad(j)=0.0d0
12025 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12026 & *(2.0*sh_frac_dist-3.0d0)
12027 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12028 & /dist_pep_side/buff_shield*0.5
12029 C remember for the final gradient multiply sh_frac_dist_grad(j)
12030 C for side_chain by factor -2 !
12032 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12033 C print *,"jestem",scale_fac_dist,fac_help_scale,
12034 C & sh_frac_dist_grad(j)
12037 C if ((i.eq.3).and.(k.eq.2)) then
12038 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12042 C this is what is now we have the distance scaling now volume...
12043 short=short_r_sidechain(itype(k))
12044 long=long_r_sidechain(itype(k))
12045 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12048 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12049 C costhet_fac=0.0d0
12051 costhet_grad(j)=costhet_fac*pep_side(j)
12053 C remember for the final gradient multiply costhet_grad(j)
12054 C for side_chain by factor -2 !
12055 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12056 C pep_side0pept_group is vector multiplication
12057 pep_side0pept_group=0.0
12059 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12061 cosalfa=(pep_side0pept_group/
12062 & (dist_pep_side*dist_side_calf))
12063 fac_alfa_sin=1.0-cosalfa**2
12064 fac_alfa_sin=dsqrt(fac_alfa_sin)
12065 rkprim=fac_alfa_sin*(long-short)+short
12067 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12068 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12071 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12072 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12073 &*(long-short)/fac_alfa_sin*cosalfa/
12074 &((dist_pep_side*dist_side_calf))*
12075 &((side_calf(j))-cosalfa*
12076 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12078 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12079 &*(long-short)/fac_alfa_sin*cosalfa
12080 &/((dist_pep_side*dist_side_calf))*
12082 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12085 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12088 C now the gradient...
12089 C grad_shield is gradient of Calfa for peptide groups
12090 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12092 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12093 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12095 grad_shield(j,i)=grad_shield(j,i)
12096 C gradient po skalowaniu
12097 & +(sh_frac_dist_grad(j)
12098 C gradient po costhet
12099 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12100 &-scale_fac_dist*(cosphi_grad_long(j))
12101 &/(1.0-cosphi) )*div77_81
12103 C grad_shield_side is Cbeta sidechain gradient
12104 grad_shield_side(j,ishield_list(i),i)=
12105 & (sh_frac_dist_grad(j)*(-2.0d0)
12106 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12107 & +scale_fac_dist*(cosphi_grad_long(j))
12108 & *2.0d0/(1.0-cosphi))
12109 & *div77_81*VofOverlap
12111 grad_shield_loc(j,ishield_list(i),i)=
12112 & scale_fac_dist*cosphi_grad_loc(j)
12113 & *2.0d0/(1.0-cosphi)
12114 & *div77_81*VofOverlap
12116 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12118 fac_shield(i)=VolumeTotal*div77_81+div4_81
12119 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12123 C--------------------------------------------------------------------------
12124 double precision function tschebyshev(m,n,x,y)
12126 include "DIMENSIONS"
12128 double precision x(n),y,yy(0:maxvar),aux
12129 c Tschebyshev polynomial. Note that the first term is omitted
12130 c m=0: the constant term is included
12131 c m=1: the constant term is not included
12135 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12144 C--------------------------------------------------------------------------
12145 double precision function gradtschebyshev(m,n,x,y)
12147 include "DIMENSIONS"
12149 double precision x(n+1),y,yy(0:maxvar),aux
12150 c Tschebyshev polynomial. Note that the first term is omitted
12151 c m=0: the constant term is included
12152 c m=1: the constant term is not included
12156 yy(i)=2*y*yy(i-1)-yy(i-2)
12160 aux=aux+x(i+1)*yy(i)*(i+1)
12161 C print *, x(i+1),yy(i),i
12163 gradtschebyshev=aux
12166 C------------------------------------------------------------------------
12167 C first for shielding is setting of function of side-chains
12168 subroutine set_shield_fac2
12169 implicit real*8 (a-h,o-z)
12170 include 'DIMENSIONS'
12171 include 'COMMON.CHAIN'
12172 include 'COMMON.DERIV'
12173 include 'COMMON.IOUNITS'
12174 include 'COMMON.SHIELD'
12175 include 'COMMON.INTERACT'
12176 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12177 double precision div77_81/0.974996043d0/,
12178 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12180 C the vector between center of side_chain and peptide group
12181 double precision pep_side(3),long,side_calf(3),
12182 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12183 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12184 C the line belowe needs to be changed for FGPROC>1
12186 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12188 Cif there two consequtive dummy atoms there is no peptide group between them
12189 C the line below has to be changed for FGPROC>1
12192 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12196 C first lets set vector conecting the ithe side-chain with kth side-chain
12197 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12198 C pep_side(j)=2.0d0
12199 C and vector conecting the side-chain with its proper calfa
12200 side_calf(j)=c(j,k+nres)-c(j,k)
12201 C side_calf(j)=2.0d0
12202 pept_group(j)=c(j,i)-c(j,i+1)
12203 C lets have their lenght
12204 dist_pep_side=pep_side(j)**2+dist_pep_side
12205 dist_side_calf=dist_side_calf+side_calf(j)**2
12206 dist_pept_group=dist_pept_group+pept_group(j)**2
12208 dist_pep_side=dsqrt(dist_pep_side)
12209 dist_pept_group=dsqrt(dist_pept_group)
12210 dist_side_calf=dsqrt(dist_side_calf)
12212 pep_side_norm(j)=pep_side(j)/dist_pep_side
12213 side_calf_norm(j)=dist_side_calf
12215 C now sscale fraction
12216 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12217 C print *,buff_shield,"buff"
12219 if (sh_frac_dist.le.0.0) cycle
12220 C If we reach here it means that this side chain reaches the shielding sphere
12221 C Lets add him to the list for gradient
12222 ishield_list(i)=ishield_list(i)+1
12223 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12224 C this list is essential otherwise problem would be O3
12225 shield_list(ishield_list(i),i)=k
12226 C Lets have the sscale value
12227 if (sh_frac_dist.gt.1.0) then
12228 scale_fac_dist=1.0d0
12230 sh_frac_dist_grad(j)=0.0d0
12233 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12234 & *(2.0d0*sh_frac_dist-3.0d0)
12235 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12236 & /dist_pep_side/buff_shield*0.5d0
12237 C remember for the final gradient multiply sh_frac_dist_grad(j)
12238 C for side_chain by factor -2 !
12240 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12241 C sh_frac_dist_grad(j)=0.0d0
12242 C scale_fac_dist=1.0d0
12243 C print *,"jestem",scale_fac_dist,fac_help_scale,
12244 C & sh_frac_dist_grad(j)
12247 C this is what is now we have the distance scaling now volume...
12248 short=short_r_sidechain(itype(k))
12249 long=long_r_sidechain(itype(k))
12250 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12251 sinthet=short/dist_pep_side*costhet
12255 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12256 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12257 C & -short/dist_pep_side**2/costhet)
12258 C costhet_fac=0.0d0
12260 costhet_grad(j)=costhet_fac*pep_side(j)
12262 C remember for the final gradient multiply costhet_grad(j)
12263 C for side_chain by factor -2 !
12264 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12265 C pep_side0pept_group is vector multiplication
12266 pep_side0pept_group=0.0d0
12268 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12270 cosalfa=(pep_side0pept_group/
12271 & (dist_pep_side*dist_side_calf))
12272 fac_alfa_sin=1.0d0-cosalfa**2
12273 fac_alfa_sin=dsqrt(fac_alfa_sin)
12274 rkprim=fac_alfa_sin*(long-short)+short
12278 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12280 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12281 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12282 & dist_pep_side**2)
12285 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12286 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12287 &*(long-short)/fac_alfa_sin*cosalfa/
12288 &((dist_pep_side*dist_side_calf))*
12289 &((side_calf(j))-cosalfa*
12290 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12291 C cosphi_grad_long(j)=0.0d0
12292 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12293 &*(long-short)/fac_alfa_sin*cosalfa
12294 &/((dist_pep_side*dist_side_calf))*
12296 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12297 C cosphi_grad_loc(j)=0.0d0
12299 C print *,sinphi,sinthet
12300 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12301 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12302 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12305 C now the gradient...
12307 grad_shield(j,i)=grad_shield(j,i)
12308 C gradient po skalowaniu
12309 & +(sh_frac_dist_grad(j)*VofOverlap
12310 C gradient po costhet
12311 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12312 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12313 & sinphi/sinthet*costhet*costhet_grad(j)
12314 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12316 C grad_shield_side is Cbeta sidechain gradient
12317 grad_shield_side(j,ishield_list(i),i)=
12318 & (sh_frac_dist_grad(j)*(-2.0d0)
12320 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12321 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12322 & sinphi/sinthet*costhet*costhet_grad(j)
12323 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12326 grad_shield_loc(j,ishield_list(i),i)=
12327 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12328 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12329 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12333 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12335 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12337 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12338 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12339 c & " wshield",wshield
12340 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12344 C-----------------------------------------------------------------------
12345 C-----------------------------------------------------------
12346 C This subroutine is to mimic the histone like structure but as well can be
12347 C utilizet to nanostructures (infinit) small modification has to be used to
12348 C make it finite (z gradient at the ends has to be changes as well as the x,y
12349 C gradient has to be modified at the ends
12350 C The energy function is Kihara potential
12351 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12352 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12353 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12354 C simple Kihara potential
12355 subroutine calctube(Etube)
12356 implicit real*8 (a-h,o-z)
12357 include 'DIMENSIONS'
12358 include 'COMMON.GEO'
12359 include 'COMMON.VAR'
12360 include 'COMMON.LOCAL'
12361 include 'COMMON.CHAIN'
12362 include 'COMMON.DERIV'
12363 include 'COMMON.NAMES'
12364 include 'COMMON.INTERACT'
12365 include 'COMMON.IOUNITS'
12366 include 'COMMON.CALC'
12367 include 'COMMON.CONTROL'
12368 include 'COMMON.SPLITELE'
12369 include 'COMMON.SBRIDGE'
12370 double precision tub_r,vectube(3),enetube(maxres*2)
12375 C first we calculate the distance from tube center
12376 C first sugare-phosphate group for NARES this would be peptide group
12379 C lets ommit dummy atoms for now
12380 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12381 C now calculate distance from center of tube and direction vectors
12382 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12383 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12384 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12385 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12386 vectube(1)=vectube(1)-tubecenter(1)
12387 vectube(2)=vectube(2)-tubecenter(2)
12389 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12390 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12392 C as the tube is infinity we do not calculate the Z-vector use of Z
12395 C now calculte the distance
12396 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12397 C now normalize vector
12398 vectube(1)=vectube(1)/tub_r
12399 vectube(2)=vectube(2)/tub_r
12400 C calculte rdiffrence between r and r0
12403 rdiff6=rdiff**6.0d0
12404 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12405 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12406 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12407 C print *,rdiff,rdiff6,pep_aa_tube
12408 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12409 C now we calculate gradient
12410 fac=(-12.0d0*pep_aa_tube/rdiff6+
12411 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12412 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12415 C now direction of gg_tube vector
12417 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12418 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12421 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12423 C Lets not jump over memory as we use many times iti
12425 C lets ommit dummy atoms for now
12427 C in UNRES uncomment the line below as GLY has no side-chain...
12430 vectube(1)=c(1,i+nres)
12431 vectube(1)=mod(vectube(1),boxxsize)
12432 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12433 vectube(2)=c(2,i+nres)
12434 vectube(2)=mod(vectube(2),boxxsize)
12435 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12437 vectube(1)=vectube(1)-tubecenter(1)
12438 vectube(2)=vectube(2)-tubecenter(2)
12440 C as the tube is infinity we do not calculate the Z-vector use of Z
12443 C now calculte the distance
12444 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12445 C now normalize vector
12446 vectube(1)=vectube(1)/tub_r
12447 vectube(2)=vectube(2)/tub_r
12448 C calculte rdiffrence between r and r0
12451 rdiff6=rdiff**6.0d0
12452 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12453 sc_aa_tube=sc_aa_tube_par(iti)
12454 sc_bb_tube=sc_bb_tube_par(iti)
12455 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12456 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12457 C now we calculate gradient
12458 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12459 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12460 C now direction of gg_tube vector
12462 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12463 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12467 Etube=Etube+enetube(i)
12469 C print *,"ETUBE", etube
12472 C TO DO 1) add to total energy
12473 C 2) add to gradient summation
12474 C 3) add reading parameters (AND of course oppening of PARAM file)
12475 C 4) add reading the center of tube
12477 C 6) add to zerograd
12479 C-----------------------------------------------------------------------
12480 C-----------------------------------------------------------
12481 C This subroutine is to mimic the histone like structure but as well can be
12482 C utilizet to nanostructures (infinit) small modification has to be used to
12483 C make it finite (z gradient at the ends has to be changes as well as the x,y
12484 C gradient has to be modified at the ends
12485 C The energy function is Kihara potential
12486 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12487 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12488 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12489 C simple Kihara potential
12490 subroutine calctube2(Etube)
12491 implicit real*8 (a-h,o-z)
12492 include 'DIMENSIONS'
12493 include 'COMMON.GEO'
12494 include 'COMMON.VAR'
12495 include 'COMMON.LOCAL'
12496 include 'COMMON.CHAIN'
12497 include 'COMMON.DERIV'
12498 include 'COMMON.NAMES'
12499 include 'COMMON.INTERACT'
12500 include 'COMMON.IOUNITS'
12501 include 'COMMON.CALC'
12502 include 'COMMON.CONTROL'
12503 include 'COMMON.SPLITELE'
12504 include 'COMMON.SBRIDGE'
12505 double precision tub_r,vectube(3),enetube(maxres*2)
12510 C first we calculate the distance from tube center
12511 C first sugare-phosphate group for NARES this would be peptide group
12514 C lets ommit dummy atoms for now
12515 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12516 C now calculate distance from center of tube and direction vectors
12517 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12518 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12519 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12520 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12521 vectube(1)=vectube(1)-tubecenter(1)
12522 vectube(2)=vectube(2)-tubecenter(2)
12524 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12525 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12527 C as the tube is infinity we do not calculate the Z-vector use of Z
12530 C now calculte the distance
12531 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12532 C now normalize vector
12533 vectube(1)=vectube(1)/tub_r
12534 vectube(2)=vectube(2)/tub_r
12535 C calculte rdiffrence between r and r0
12538 rdiff6=rdiff**6.0d0
12539 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12540 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12541 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12542 C print *,rdiff,rdiff6,pep_aa_tube
12543 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12544 C now we calculate gradient
12545 fac=(-12.0d0*pep_aa_tube/rdiff6+
12546 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12547 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12550 C now direction of gg_tube vector
12552 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12553 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12556 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12558 C Lets not jump over memory as we use many times iti
12560 C lets ommit dummy atoms for now
12562 C in UNRES uncomment the line below as GLY has no side-chain...
12565 vectube(1)=c(1,i+nres)
12566 vectube(1)=mod(vectube(1),boxxsize)
12567 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12568 vectube(2)=c(2,i+nres)
12569 vectube(2)=mod(vectube(2),boxxsize)
12570 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12572 vectube(1)=vectube(1)-tubecenter(1)
12573 vectube(2)=vectube(2)-tubecenter(2)
12574 C THIS FRAGMENT MAKES TUBE FINITE
12575 positi=(mod(c(3,i+nres),boxzsize))
12576 if (positi.le.0) positi=positi+boxzsize
12577 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12578 c for each residue check if it is in lipid or lipid water border area
12579 C respos=mod(c(3,i+nres),boxzsize)
12580 print *,positi,bordtubebot,buftubebot,bordtubetop
12581 if ((positi.gt.bordtubebot)
12582 & .and.(positi.lt.bordtubetop)) then
12583 C the energy transfer exist
12584 if (positi.lt.buftubebot) then
12586 & ((positi-bordtubebot)/tubebufthick)
12587 C lipbufthick is thickenes of lipid buffore
12588 sstube=sscalelip(fracinbuf)
12589 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12590 print *,ssgradtube, sstube,tubetranene(itype(i))
12591 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12592 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12593 &+ssgradtube*tubetranene(itype(i))
12594 gg_tube(3,i-1)= gg_tube(3,i-1)
12595 &+ssgradtube*tubetranene(itype(i))
12596 C print *,"doing sccale for lower part"
12597 elseif (positi.gt.buftubetop) then
12599 &((bordtubetop-positi)/tubebufthick)
12600 sstube=sscalelip(fracinbuf)
12601 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12602 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12603 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12604 C &+ssgradtube*tubetranene(itype(i))
12605 C gg_tube(3,i-1)= gg_tube(3,i-1)
12606 C &+ssgradtube*tubetranene(itype(i))
12607 C print *, "doing sscalefor top part",sslip,fracinbuf
12611 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12612 C print *,"I am in true lipid"
12618 endif ! if in lipid or buffor
12619 CEND OF FINITE FRAGMENT
12620 C as the tube is infinity we do not calculate the Z-vector use of Z
12623 C now calculte the distance
12624 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12625 C now normalize vector
12626 vectube(1)=vectube(1)/tub_r
12627 vectube(2)=vectube(2)/tub_r
12628 C calculte rdiffrence between r and r0
12631 rdiff6=rdiff**6.0d0
12632 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12633 sc_aa_tube=sc_aa_tube_par(iti)
12634 sc_bb_tube=sc_bb_tube_par(iti)
12635 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12636 & *sstube+enetube(i+nres)
12637 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12638 C now we calculate gradient
12639 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12640 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12641 C now direction of gg_tube vector
12643 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12644 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12646 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12647 &+ssgradtube*enetube(i+nres)/sstube
12648 gg_tube(3,i-1)= gg_tube(3,i-1)
12649 &+ssgradtube*enetube(i+nres)/sstube
12653 Etube=Etube+enetube(i)
12655 C print *,"ETUBE", etube
12658 C TO DO 1) add to total energy
12659 C 2) add to gradient summation
12660 C 3) add reading parameters (AND of course oppening of PARAM file)
12661 C 4) add reading the center of tube
12663 C 6) add to zerograd
12664 c----------------------------------------------------------------------------
12665 subroutine e_saxs(Esaxs_constr)
12667 include 'DIMENSIONS'
12670 include "COMMON.SETUP"
12673 include 'COMMON.SBRIDGE'
12674 include 'COMMON.CHAIN'
12675 include 'COMMON.GEO'
12676 include 'COMMON.DERIV'
12677 include 'COMMON.LOCAL'
12678 include 'COMMON.INTERACT'
12679 include 'COMMON.VAR'
12680 include 'COMMON.IOUNITS'
12681 c include 'COMMON.MD'
12684 include 'COMMON.LANGEVIN.lang0.5diag'
12686 include 'COMMON.LANGEVIN.lang0'
12689 include 'COMMON.LANGEVIN'
12691 include 'COMMON.CONTROL'
12692 include 'COMMON.SAXS'
12693 include 'COMMON.NAMES'
12694 include 'COMMON.TIME1'
12695 include 'COMMON.FFIELD'
12697 double precision Esaxs_constr
12698 integer i,iint,j,k,l
12699 double precision PgradC(maxSAXS,3,maxres),
12700 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12702 double precision PgradC_(maxSAXS,3,maxres),
12703 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12705 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12706 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12707 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12708 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12709 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12710 double precision dist,mygauss,mygaussder
12712 integer llicz,lllicz
12713 double precision time01
12714 c SAXS restraint penalty function
12716 write(iout,*) "------- SAXS penalty function start -------"
12717 write (iout,*) "nsaxs",nsaxs
12718 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12719 write (iout,*) "Psaxs"
12721 write (iout,'(i5,e15.5)') i, Psaxs(i)
12727 Esaxs_constr = 0.0d0
12732 PgradC(k,l,j)=0.0d0
12733 PgradX(k,l,j)=0.0d0
12738 do i=iatsc_s,iatsc_e
12739 if (itype(i).eq.ntyp1) cycle
12740 do iint=1,nint_gr(i)
12741 do j=istart(i,iint),iend(i,iint)
12742 if (itype(j).eq.ntyp1) cycle
12745 dijCASC=dist(i,j+nres)
12746 dijSCCA=dist(i+nres,j)
12747 dijSCSC=dist(i+nres,j+nres)
12748 sigma2CACA=2.0d0/(pstok**2)
12749 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12750 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12751 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12754 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12755 if (itype(j).ne.10) then
12756 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12760 if (itype(i).ne.10) then
12761 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12765 if (itype(i).ne.10 .and. itype(j).ne.10) then
12766 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12770 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12772 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12774 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12775 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12776 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12777 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12780 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12781 PgradC(k,l,i) = PgradC(k,l,i)-aux
12782 PgradC(k,l,j) = PgradC(k,l,j)+aux
12784 if (itype(j).ne.10) then
12785 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12786 PgradC(k,l,i) = PgradC(k,l,i)-aux
12787 PgradC(k,l,j) = PgradC(k,l,j)+aux
12788 PgradX(k,l,j) = PgradX(k,l,j)+aux
12791 if (itype(i).ne.10) then
12792 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12793 PgradX(k,l,i) = PgradX(k,l,i)-aux
12794 PgradC(k,l,i) = PgradC(k,l,i)-aux
12795 PgradC(k,l,j) = PgradC(k,l,j)+aux
12798 if (itype(i).ne.10 .and. itype(j).ne.10) then
12799 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12800 PgradC(k,l,i) = PgradC(k,l,i)-aux
12801 PgradC(k,l,j) = PgradC(k,l,j)+aux
12802 PgradX(k,l,i) = PgradX(k,l,i)-aux
12803 PgradX(k,l,j) = PgradX(k,l,j)+aux
12809 sigma2CACA=scal_rad**2*0.25d0/
12810 & (restok(itype(j))**2+restok(itype(i))**2)
12811 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12812 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12814 sigmaCACA=dsqrt(sigma2CACA)
12815 threesig=3.0d0/sigmaCACA
12819 if (dabs(dijCACA-dk).ge.threesig) cycle
12822 aux = sigmaCACA*(dijCACA-dk)
12823 expCACA = mygauss(aux)
12824 c if (expcaca.eq.0.0d0) cycle
12825 Pcalc(k) = Pcalc(k)+expCACA
12826 CACAgrad = -sigmaCACA*mygaussder(aux)
12827 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12829 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12830 PgradC(k,l,i) = PgradC(k,l,i)-aux
12831 PgradC(k,l,j) = PgradC(k,l,j)+aux
12834 c write (iout,*) "i",i," j",j," llicz",llicz
12836 IF (saxs_cutoff.eq.0) THEN
12839 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12840 Pcalc(k) = Pcalc(k)+expCACA
12841 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12843 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12844 PgradC(k,l,i) = PgradC(k,l,i)-aux
12845 PgradC(k,l,j) = PgradC(k,l,j)+aux
12849 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12852 c write (2,*) "ijk",i,j,k
12853 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12854 if (sss2.eq.0.0d0) cycle
12855 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12856 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12857 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12858 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
12860 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12861 Pcalc(k) = Pcalc(k)+expCACA
12863 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12865 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12866 & ssgrad2*expCACA/sss2
12869 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12870 PgradC(k,l,i) = PgradC(k,l,i)+aux
12871 PgradC(k,l,j) = PgradC(k,l,j)-aux
12881 c time_SAXS=time_SAXS+MPI_Wtime()-time01
12883 c write (iout,*) "lllicz",lllicz
12885 c time01=MPI_Wtime()
12888 if (nfgtasks.gt.1) then
12889 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12890 & MPI_SUM,FG_COMM,IERR)
12891 c if (fg_rank.eq.king) then
12893 Pcalc(k) = Pcalc_(k)
12896 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12897 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12898 c if (fg_rank.eq.king) then
12902 c PgradC(k,l,i) = PgradC_(k,l,i)
12908 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12909 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12910 c if (fg_rank.eq.king) then
12914 c PgradX(k,l,i) = PgradX_(k,l,i)
12924 Cnorm = Cnorm + Pcalc(k)
12927 if (fg_rank.eq.king) then
12929 Esaxs_constr = dlog(Cnorm)-wsaxs0
12931 if (Pcalc(k).gt.0.0d0)
12932 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12934 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12938 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12953 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12954 auxC1 = auxC1+PgradC(k,l,i)
12956 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12957 auxX1 = auxX1+PgradX(k,l,i)
12960 gsaxsC(l,i) = auxC - auxC1/Cnorm
12962 gsaxsX(l,i) = auxX - auxX1/Cnorm
12964 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12965 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
12966 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12967 c * " gradX",wsaxs*gsaxsX(l,i)
12971 time_SAXS=time_SAXS+MPI_Wtime()-time01
12974 write (iout,*) "gsaxsc"
12976 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12984 c----------------------------------------------------------------------------
12985 subroutine e_saxsC(Esaxs_constr)
12987 include 'DIMENSIONS'
12990 include "COMMON.SETUP"
12993 include 'COMMON.SBRIDGE'
12994 include 'COMMON.CHAIN'
12995 include 'COMMON.GEO'
12996 include 'COMMON.DERIV'
12997 include 'COMMON.LOCAL'
12998 include 'COMMON.INTERACT'
12999 include 'COMMON.VAR'
13000 include 'COMMON.IOUNITS'
13001 c include 'COMMON.MD'
13004 include 'COMMON.LANGEVIN.lang0.5diag'
13006 include 'COMMON.LANGEVIN.lang0'
13009 include 'COMMON.LANGEVIN'
13011 include 'COMMON.CONTROL'
13012 include 'COMMON.SAXS'
13013 include 'COMMON.NAMES'
13014 include 'COMMON.TIME1'
13015 include 'COMMON.FFIELD'
13017 double precision Esaxs_constr
13018 integer i,iint,j,k,l
13019 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13021 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13023 double precision dk,dijCASPH,dijSCSPH,
13024 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13025 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13027 c SAXS restraint penalty function
13029 write(iout,*) "------- SAXS penalty function start -------"
13030 write (iout,*) "nsaxs",nsaxs
13033 print *,MyRank,"C",i,(C(j,i),j=1,3)
13036 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13039 Esaxs_constr = 0.0d0
13041 do j=isaxs_start,isaxs_end
13050 if (itype(i).eq.ntyp1) cycle
13054 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13056 if (itype(i).ne.10) then
13058 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13061 sigma2CA=2.0d0/pstok**2
13062 sigma2SC=4.0d0/restok(itype(i))**2
13063 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13064 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13065 Pcalc = Pcalc+expCASPH+expSCSPH
13067 write(*,*) "processor i j Pcalc",
13068 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13070 CASPHgrad = sigma2CA*expCASPH
13071 SCSPHgrad = sigma2SC*expSCSPH
13073 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13074 PgradX(l,i) = PgradX(l,i) + aux
13075 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13080 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13081 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13084 logPtot = logPtot - dlog(Pcalc)
13085 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13086 c & " logPtot",logPtot
13089 if (nfgtasks.gt.1) then
13090 c write (iout,*) "logPtot before reduction",logPtot
13091 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13092 & MPI_SUM,king,FG_COMM,IERR)
13094 c write (iout,*) "logPtot after reduction",logPtot
13095 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13096 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13097 if (fg_rank.eq.king) then
13100 gsaxsC(l,i) = gsaxsC_(l,i)
13104 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13105 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13106 if (fg_rank.eq.king) then
13109 gsaxsX(l,i) = gsaxsX_(l,i)
13115 Esaxs_constr = logPtot
13118 c----------------------------------------------------------------------------
13119 double precision function sscale2(r,r_cut,r0,rlamb)
13121 double precision r,gamm,r_cut,r0,rlamb,rr
13123 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13124 c write (2,*) "rr",rr
13125 if(rr.lt.r_cut-rlamb) then
13127 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13128 gamm=(rr-(r_cut-rlamb))/rlamb
13129 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13135 C-----------------------------------------------------------------------
13136 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13138 double precision r,gamm,r_cut,r0,rlamb,rr
13140 if(rr.lt.r_cut-rlamb) then
13142 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13143 gamm=(rr-(r_cut-rlamb))/rlamb
13145 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13147 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13154 c------------------------------------------------------------------------
13155 double precision function boxshift(x,boxsize)
13157 double precision x,boxsize
13158 double precision xtemp
13159 xtemp=dmod(x,boxsize)
13160 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13161 boxshift=xtemp-boxsize
13162 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13163 boxshift=xtemp+boxsize
13169 c--------------------------------------------------------------------------
13170 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13171 include 'DIMENSIONS'
13172 include 'COMMON.CHAIN'
13173 integer xshift,yshift,zshift,subchap
13174 double precision dist_init,xj_safe,yj_safe,zj_safe,
13175 & xj_temp,yj_temp,zj_temp,dist_temp
13179 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13184 xj=xj_safe+xshift*boxxsize
13185 yj=yj_safe+yshift*boxysize
13186 zj=zj_safe+zshift*boxzsize
13187 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13188 if(dist_temp.lt.dist_init) then
13189 dist_init=dist_temp
13198 if (subchap.eq.1) then
13209 c--------------------------------------------------------------------------
13210 subroutine to_box(xi,yi,zi)
13212 include 'DIMENSIONS'
13213 include 'COMMON.CHAIN'
13214 double precision xi,yi,zi
13215 xi=dmod(xi,boxxsize)
13216 if (xi.lt.0.0d0) xi=xi+boxxsize
13217 yi=dmod(yi,boxysize)
13218 if (yi.lt.0.0d0) yi=yi+boxysize
13219 zi=dmod(zi,boxzsize)
13220 if (zi.lt.0.0d0) zi=zi+boxzsize
13223 c--------------------------------------------------------------------------
13224 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13226 include 'DIMENSIONS'
13227 include 'COMMON.CHAIN'
13228 double precision xi,yi,zi,sslipi,ssgradlipi
13229 double precision fracinbuf
13230 double precision sscalelip,sscagradlip
13232 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13233 C the energy transfer exist
13234 if (zi.lt.buflipbot) then
13235 C what fraction I am in
13236 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13237 C lipbufthick is thickenes of lipid buffore
13238 sslipi=sscalelip(fracinbuf)
13239 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13240 elseif (zi.gt.bufliptop) then
13241 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13242 sslipi=sscalelip(fracinbuf)
13243 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick