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
2056 c for diagnostics; uncomment
2057 c rij_shift=1.2*sig0ij
2058 C I hate to put IF's in the loops, but here don't have another choice!!!!
2059 if (rij_shift.le.0.0D0) then
2061 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062 cd & restyp(itypi),i,restyp(itypj),j,
2063 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2067 c---------------------------------------------------------------
2068 rij_shift=1.0D0/rij_shift
2069 fac=rij_shift**expon
2070 C here to start with
2075 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2076 eps2der=evdwij*eps3rt
2077 eps3der=evdwij*eps2rt
2078 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2079 C &((sslipi+sslipj)/2.0d0+
2080 C &(2.0d0-sslipi-sslipj)/2.0d0)
2081 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2082 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2083 evdwij=evdwij*eps2rt*eps3rt
2084 evdw=evdw+evdwij*sss
2086 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2088 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2089 & restyp(itypi),i,restyp(itypj),j,
2090 & epsi,sigm,chi1,chi2,chip1,chip2,
2091 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2092 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2096 if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2097 & 'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2099 C Calculate gradient components.
2100 e1=e1*eps1*eps2rt**2*eps3rt**2
2101 fac=-expon*(e1+evdwij)*rij_shift
2104 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2105 c & evdwij,fac,sigma(itypi,itypj),expon
2106 fac=fac+evdwij*sssgrad/sss*rij
2108 C Calculate the radial part of the gradient
2109 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2110 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2111 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2112 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2113 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2114 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2120 C Calculate angular part of the gradient.
2121 c call sc_grad_scale(sss)
2130 c write (iout,*) "Number of loop steps in EGB:",ind
2131 cccc energy_dec=.false.
2134 C-----------------------------------------------------------------------------
2135 subroutine egbv(evdw)
2137 C This subroutine calculates the interaction energy of nonbonded side chains
2138 C assuming the Gay-Berne-Vorobjev potential of interaction.
2141 include 'DIMENSIONS'
2142 include 'COMMON.GEO'
2143 include 'COMMON.VAR'
2144 include 'COMMON.LOCAL'
2145 include 'COMMON.CHAIN'
2146 include 'COMMON.DERIV'
2147 include 'COMMON.NAMES'
2148 include 'COMMON.INTERACT'
2149 include 'COMMON.IOUNITS'
2150 include 'COMMON.CALC'
2151 include 'COMMON.SPLITELE'
2152 double precision boxshift
2154 common /srutu/ icall
2156 double precision evdw
2157 integer itypi,itypj,itypi1,iint,ind,ikont
2158 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2159 & xi,yi,zi,fac_augm,e_augm
2160 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2161 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2162 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2164 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2167 c if (icall.eq.0) lprn=.true.
2169 c do i=iatsc_s,iatsc_e
2170 do ikont=g_listscsc_start,g_listscsc_end
2171 i=newcontlisti(ikont)
2172 j=newcontlistj(ikont)
2173 itypi=iabs(itype(i))
2174 if (itypi.eq.ntyp1) cycle
2175 itypi1=iabs(itype(i+1))
2179 call to_box(xi,yi,zi)
2180 C define scaling factor for lipids
2182 C if (positi.le.0) positi=positi+boxzsize
2184 C first for peptide groups
2185 c for each residue check if it is in lipid or lipid water border area
2186 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2187 dxi=dc_norm(1,nres+i)
2188 dyi=dc_norm(2,nres+i)
2189 dzi=dc_norm(3,nres+i)
2190 c dsci_inv=dsc_inv(itypi)
2191 dsci_inv=vbld_inv(i+nres)
2193 C Calculate SC interaction energy.
2195 c do iint=1,nint_gr(i)
2196 c do j=istart(i,iint),iend(i,iint)
2198 itypj=iabs(itype(j))
2199 if (itypj.eq.ntyp1) cycle
2200 c dscj_inv=dsc_inv(itypj)
2201 dscj_inv=vbld_inv(j+nres)
2202 sig0ij=sigma(itypi,itypj)
2203 r0ij=r0(itypi,itypj)
2204 chi1=chi(itypi,itypj)
2205 chi2=chi(itypj,itypi)
2212 alf12=0.5D0*(alf1+alf2)
2213 C For diagnostics only!!!
2226 call to_box(xj,yj,zj)
2227 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2228 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2229 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2230 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2231 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2232 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2233 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2234 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2235 xj=boxshift(xj-xi,boxxsize)
2236 yj=boxshift(yj-yi,boxysize)
2237 zj=boxshift(zj-zi,boxzsize)
2238 dxj=dc_norm(1,nres+j)
2239 dyj=dc_norm(2,nres+j)
2240 dzj=dc_norm(3,nres+j)
2241 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2243 sss=sscale(1.0d0/rij,r_cut_int)
2244 if (sss.eq.0.0d0) cycle
2245 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2246 C Calculate angle-dependent terms of energy and contributions to their
2250 sig=sig0ij*dsqrt(sigsq)
2251 rij_shift=1.0D0/rij-sig+r0ij
2252 C I hate to put IF's in the loops, but here don't have another choice!!!!
2253 if (rij_shift.le.0.0D0) then
2258 c---------------------------------------------------------------
2259 rij_shift=1.0D0/rij_shift
2260 fac=rij_shift**expon
2263 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2264 eps2der=evdwij*eps3rt
2265 eps3der=evdwij*eps2rt
2266 fac_augm=rrij**expon
2267 e_augm=augm(itypi,itypj)*fac_augm
2268 evdwij=evdwij*eps2rt*eps3rt
2269 evdw=evdw+evdwij+e_augm
2271 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2273 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2274 & restyp(itypi),i,restyp(itypj),j,
2275 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2276 & chi1,chi2,chip1,chip2,
2277 & eps1,eps2rt**2,eps3rt**2,
2278 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2281 C Calculate gradient components.
2282 e1=e1*eps1*eps2rt**2*eps3rt**2
2283 fac=-expon*(e1+evdwij)*rij_shift
2285 fac=rij*fac-2*expon*rrij*e_augm
2286 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2287 C Calculate the radial part of the gradient
2291 C Calculate angular part of the gradient.
2292 c call sc_grad_scale(sss)
2298 C-----------------------------------------------------------------------------
2299 subroutine sc_angular
2300 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2301 C om12. Called by ebp, egb, and egbv.
2303 include 'COMMON.CALC'
2304 include 'COMMON.IOUNITS'
2308 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2309 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2310 om12=dxi*dxj+dyi*dyj+dzi*dzj
2312 C Calculate eps1(om12) and its derivative in om12
2313 faceps1=1.0D0-om12*chiom12
2314 faceps1_inv=1.0D0/faceps1
2315 eps1=dsqrt(faceps1_inv)
2316 C Following variable is eps1*deps1/dom12
2317 eps1_om12=faceps1_inv*chiom12
2322 c write (iout,*) "om12",om12," eps1",eps1
2323 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2328 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2329 sigsq=1.0D0-facsig*faceps1_inv
2330 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2331 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2332 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2338 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2339 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2341 C Calculate eps2 and its derivatives in om1, om2, and om12.
2344 chipom12=chip12*om12
2345 facp=1.0D0-om12*chipom12
2347 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2348 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2349 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2350 C Following variable is the square root of eps2
2351 eps2rt=1.0D0-facp1*facp_inv
2352 C Following three variables are the derivatives of the square root of eps
2353 C in om1, om2, and om12.
2354 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2355 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2356 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2357 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2358 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2359 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2360 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2361 c & " eps2rt_om12",eps2rt_om12
2362 C Calculate whole angle-dependent part of epsilon and contributions
2363 C to its derivatives
2366 C----------------------------------------------------------------------------
2368 implicit real*8 (a-h,o-z)
2369 include 'DIMENSIONS'
2370 include 'COMMON.CHAIN'
2371 include 'COMMON.DERIV'
2372 include 'COMMON.CALC'
2373 include 'COMMON.IOUNITS'
2374 double precision dcosom1(3),dcosom2(3)
2375 cc print *,'sss=',sss
2376 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2377 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2378 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2379 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2383 c eom12=evdwij*eps1_om12
2385 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2386 c & " sigder",sigder
2387 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2388 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2390 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2391 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2394 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2396 c write (iout,*) "gg",(gg(k),k=1,3)
2398 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2399 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2400 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2401 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2402 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2403 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2404 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2405 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2406 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2407 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2410 C Calculate the components of the gradient in DC and X
2414 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2418 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2419 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2423 C-----------------------------------------------------------------------
2424 subroutine e_softsphere(evdw)
2426 C This subroutine calculates the interaction energy of nonbonded side chains
2427 C assuming the LJ potential of interaction.
2429 implicit real*8 (a-h,o-z)
2430 include 'DIMENSIONS'
2431 parameter (accur=1.0d-10)
2432 include 'COMMON.GEO'
2433 include 'COMMON.VAR'
2434 include 'COMMON.LOCAL'
2435 include 'COMMON.CHAIN'
2436 include 'COMMON.DERIV'
2437 include 'COMMON.INTERACT'
2438 include 'COMMON.TORSION'
2439 include 'COMMON.SBRIDGE'
2440 include 'COMMON.NAMES'
2441 include 'COMMON.IOUNITS'
2442 c include 'COMMON.CONTACTS'
2444 double precision boxshift
2445 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2447 c do i=iatsc_s,iatsc_e
2448 do ikont=g_listscsc_start,g_listscsc_end
2449 i=newcontlisti(ikont)
2450 j=newcontlistj(ikont)
2451 itypi=iabs(itype(i))
2452 if (itypi.eq.ntyp1) cycle
2453 itypi1=iabs(itype(i+1))
2457 call to_box(xi,yi,zi)
2459 C Calculate SC interaction energy.
2461 c do iint=1,nint_gr(i)
2462 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2463 cd & 'iend=',iend(i,iint)
2464 c do j=istart(i,iint),iend(i,iint)
2465 itypj=iabs(itype(j))
2466 if (itypj.eq.ntyp1) cycle
2467 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2468 yj=boxshift(c(2,nres+j)-yi,boxysize)
2469 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2470 rij=xj*xj+yj*yj+zj*zj
2471 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2472 r0ij=r0(itypi,itypj)
2474 c print *,i,j,r0ij,dsqrt(rij)
2475 if (rij.lt.r0ijsq) then
2476 evdwij=0.25d0*(rij-r0ijsq)**2
2484 C Calculate the components of the gradient in DC and X
2490 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2491 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2492 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2493 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2497 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2505 C--------------------------------------------------------------------------
2506 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2509 C Soft-sphere potential of p-p interaction
2511 implicit real*8 (a-h,o-z)
2512 include 'DIMENSIONS'
2513 include 'COMMON.CONTROL'
2514 include 'COMMON.IOUNITS'
2515 include 'COMMON.GEO'
2516 include 'COMMON.VAR'
2517 include 'COMMON.LOCAL'
2518 include 'COMMON.CHAIN'
2519 include 'COMMON.DERIV'
2520 include 'COMMON.INTERACT'
2521 c include 'COMMON.CONTACTS'
2522 include 'COMMON.TORSION'
2523 include 'COMMON.VECTORS'
2524 include 'COMMON.FFIELD'
2526 double precision boxshift
2527 C write(iout,*) 'In EELEC_soft_sphere'
2534 do i=iatel_s,iatel_e
2535 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2539 xmedi=c(1,i)+0.5d0*dxi
2540 ymedi=c(2,i)+0.5d0*dyi
2541 zmedi=c(3,i)+0.5d0*dzi
2542 call to_box(xmedi,ymedi,zmedi)
2544 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2545 do j=ielstart(i),ielend(i)
2546 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2550 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2551 r0ij=rpp(iteli,itelj)
2559 call to_box(xj,yj,zj)
2560 xj=boxshift(xj-xmedi,boxxsize)
2561 yj=boxshift(yj-ymedi,boxysize)
2562 zj=boxshift(zj-zmedi,boxzsize)
2563 rij=xj*xj+yj*yj+zj*zj
2564 sss=sscale(sqrt(rij),r_cut_int)
2565 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2566 if (rij.lt.r0ijsq) then
2567 evdw1ij=0.25d0*(rij-r0ijsq)**2
2573 evdw1=evdw1+evdw1ij*sss
2575 C Calculate contributions to the Cartesian gradient.
2577 ggg(1)=fac*xj*sssgrad
2578 ggg(2)=fac*yj*sssgrad
2579 ggg(3)=fac*zj*sssgrad
2581 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2582 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2585 * Loop over residues i+1 thru j-1.
2589 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2594 cgrad do i=nnt,nct-1
2596 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2598 cgrad do j=i+1,nct-1
2600 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2606 c------------------------------------------------------------------------------
2607 subroutine vec_and_deriv
2608 implicit real*8 (a-h,o-z)
2609 include 'DIMENSIONS'
2613 include 'COMMON.IOUNITS'
2614 include 'COMMON.GEO'
2615 include 'COMMON.VAR'
2616 include 'COMMON.LOCAL'
2617 include 'COMMON.CHAIN'
2618 include 'COMMON.VECTORS'
2619 include 'COMMON.SETUP'
2620 include 'COMMON.TIME1'
2621 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2622 C Compute the local reference systems. For reference system (i), the
2623 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2624 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2626 do i=ivec_start,ivec_end
2630 if (i.eq.nres-1) then
2631 C Case of the last full residue
2632 C Compute the Z-axis
2633 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2634 costh=dcos(pi-theta(nres))
2635 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2639 C Compute the derivatives of uz
2641 uzder(2,1,1)=-dc_norm(3,i-1)
2642 uzder(3,1,1)= dc_norm(2,i-1)
2643 uzder(1,2,1)= dc_norm(3,i-1)
2645 uzder(3,2,1)=-dc_norm(1,i-1)
2646 uzder(1,3,1)=-dc_norm(2,i-1)
2647 uzder(2,3,1)= dc_norm(1,i-1)
2650 uzder(2,1,2)= dc_norm(3,i)
2651 uzder(3,1,2)=-dc_norm(2,i)
2652 uzder(1,2,2)=-dc_norm(3,i)
2654 uzder(3,2,2)= dc_norm(1,i)
2655 uzder(1,3,2)= dc_norm(2,i)
2656 uzder(2,3,2)=-dc_norm(1,i)
2658 C Compute the Y-axis
2661 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2663 C Compute the derivatives of uy
2666 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2667 & -dc_norm(k,i)*dc_norm(j,i-1)
2668 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2670 uyder(j,j,1)=uyder(j,j,1)-costh
2671 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2676 uygrad(l,k,j,i)=uyder(l,k,j)
2677 uzgrad(l,k,j,i)=uzder(l,k,j)
2681 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2682 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2683 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2684 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2687 C Compute the Z-axis
2688 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2689 costh=dcos(pi-theta(i+2))
2690 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2694 C Compute the derivatives of uz
2696 uzder(2,1,1)=-dc_norm(3,i+1)
2697 uzder(3,1,1)= dc_norm(2,i+1)
2698 uzder(1,2,1)= dc_norm(3,i+1)
2700 uzder(3,2,1)=-dc_norm(1,i+1)
2701 uzder(1,3,1)=-dc_norm(2,i+1)
2702 uzder(2,3,1)= dc_norm(1,i+1)
2705 uzder(2,1,2)= dc_norm(3,i)
2706 uzder(3,1,2)=-dc_norm(2,i)
2707 uzder(1,2,2)=-dc_norm(3,i)
2709 uzder(3,2,2)= dc_norm(1,i)
2710 uzder(1,3,2)= dc_norm(2,i)
2711 uzder(2,3,2)=-dc_norm(1,i)
2713 C Compute the Y-axis
2716 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2718 C Compute the derivatives of uy
2721 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2722 & -dc_norm(k,i)*dc_norm(j,i+1)
2723 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2725 uyder(j,j,1)=uyder(j,j,1)-costh
2726 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2731 uygrad(l,k,j,i)=uyder(l,k,j)
2732 uzgrad(l,k,j,i)=uzder(l,k,j)
2736 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2737 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2738 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2739 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2743 vbld_inv_temp(1)=vbld_inv(i+1)
2744 if (i.lt.nres-1) then
2745 vbld_inv_temp(2)=vbld_inv(i+2)
2747 vbld_inv_temp(2)=vbld_inv(i)
2752 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2753 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2758 #if defined(PARVEC) && defined(MPI)
2759 if (nfgtasks1.gt.1) then
2761 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2762 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2763 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2764 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2765 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2767 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2768 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2770 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2771 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2772 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2773 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2774 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2775 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2776 time_gather=time_gather+MPI_Wtime()-time00
2780 if (fg_rank.eq.0) then
2781 write (iout,*) "Arrays UY and UZ"
2783 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2790 C--------------------------------------------------------------------------
2791 subroutine set_matrices
2792 implicit real*8 (a-h,o-z)
2793 include 'DIMENSIONS'
2796 include "COMMON.SETUP"
2798 integer status(MPI_STATUS_SIZE)
2800 include 'COMMON.IOUNITS'
2801 include 'COMMON.GEO'
2802 include 'COMMON.VAR'
2803 include 'COMMON.LOCAL'
2804 include 'COMMON.CHAIN'
2805 include 'COMMON.DERIV'
2806 include 'COMMON.INTERACT'
2807 include 'COMMON.CORRMAT'
2808 include 'COMMON.TORSION'
2809 include 'COMMON.VECTORS'
2810 include 'COMMON.FFIELD'
2811 double precision auxvec(2),auxmat(2,2)
2813 C Compute the virtual-bond-torsional-angle dependent quantities needed
2814 C to calculate the el-loc multibody terms of various order.
2816 c write(iout,*) 'nphi=',nphi,nres
2817 c write(iout,*) "itype2loc",itype2loc
2819 do i=ivec_start+2,ivec_end+2
2824 c write (iout,*) "i",i,i-2," ii",ii
2826 innt=chain_border(1,ii)
2827 inct=chain_border(2,ii)
2828 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2829 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2830 if (i.gt. innt+2 .and. i.lt.inct+2) then
2831 iti = itype2loc(itype(i-2))
2835 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2836 if (i.gt. innt+1 .and. i.lt.inct+1) then
2837 iti1 = itype2loc(itype(i-1))
2841 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2842 c & " iti1",itype(i-1),iti1
2844 cost1=dcos(theta(i-1))
2845 sint1=dsin(theta(i-1))
2847 sint1cub=sint1sq*sint1
2848 sint1cost1=2*sint1*cost1
2849 c write (iout,*) "bnew1",i,iti
2850 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2851 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2852 c write (iout,*) "bnew2",i,iti
2853 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2854 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2856 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2858 gtb1(k,i-2)=cost1*b1k-sint1sq*
2859 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2860 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2862 gtb2(k,i-2)=cost1*b2k-sint1sq*
2863 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2866 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2867 cc(1,k,i-2)=sint1sq*aux
2868 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2869 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2870 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2871 dd(1,k,i-2)=sint1sq*aux
2872 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2873 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2875 cc(2,1,i-2)=cc(1,2,i-2)
2876 cc(2,2,i-2)=-cc(1,1,i-2)
2877 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2878 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2879 dd(2,1,i-2)=dd(1,2,i-2)
2880 dd(2,2,i-2)=-dd(1,1,i-2)
2881 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2882 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2885 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2886 EE(l,k,i-2)=sint1sq*aux
2887 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2890 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2891 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2892 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2893 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2894 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2895 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2896 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2897 c b1tilde(1,i-2)=b1(1,i-2)
2898 c b1tilde(2,i-2)=-b1(2,i-2)
2899 c b2tilde(1,i-2)=b2(1,i-2)
2900 c b2tilde(2,i-2)=-b2(2,i-2)
2902 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2903 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2904 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2905 write (iout,*) 'theta=', theta(i-1)
2908 if (i.gt. innt+2 .and. i.lt.inct+2) then
2909 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2910 iti = itype2loc(itype(i-2))
2914 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2915 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2916 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2917 iti1 = itype2loc(itype(i-1))
2927 CC(k,l,i-2)=ccold(k,l,iti)
2928 DD(k,l,i-2)=ddold(k,l,iti)
2929 EE(k,l,i-2)=eeold(k,l,iti)
2934 b1tilde(1,i-2)= b1(1,i-2)
2935 b1tilde(2,i-2)=-b1(2,i-2)
2936 b2tilde(1,i-2)= b2(1,i-2)
2937 b2tilde(2,i-2)=-b2(2,i-2)
2939 Ctilde(1,1,i-2)= CC(1,1,i-2)
2940 Ctilde(1,2,i-2)= CC(1,2,i-2)
2941 Ctilde(2,1,i-2)=-CC(2,1,i-2)
2942 Ctilde(2,2,i-2)=-CC(2,2,i-2)
2944 Dtilde(1,1,i-2)= DD(1,1,i-2)
2945 Dtilde(1,2,i-2)= DD(1,2,i-2)
2946 Dtilde(2,1,i-2)=-DD(2,1,i-2)
2947 Dtilde(2,2,i-2)=-DD(2,2,i-2)
2949 write(iout,*) "i",i," iti",iti
2950 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2951 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2956 do i=ivec_start+2,ivec_end+2
2960 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2961 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
2999 obrot_der(1,i-2)=-sin1
3000 obrot_der(2,i-2)= cos1
3001 Ugder(1,1,i-2)= sin1
3002 Ugder(1,2,i-2)=-cos1
3003 Ugder(2,1,i-2)=-cos1
3004 Ugder(2,2,i-2)=-sin1
3007 obrot2_der(1,i-2)=-dwasin2
3008 obrot2_der(2,i-2)= dwacos2
3009 Ug2der(1,1,i-2)= dwasin2
3010 Ug2der(1,2,i-2)=-dwacos2
3011 Ug2der(2,1,i-2)=-dwacos2
3012 Ug2der(2,2,i-2)=-dwasin2
3014 obrot_der(1,i-2)=0.0d0
3015 obrot_der(2,i-2)=0.0d0
3016 Ugder(1,1,i-2)=0.0d0
3017 Ugder(1,2,i-2)=0.0d0
3018 Ugder(2,1,i-2)=0.0d0
3019 Ugder(2,2,i-2)=0.0d0
3020 obrot2_der(1,i-2)=0.0d0
3021 obrot2_der(2,i-2)=0.0d0
3022 Ug2der(1,1,i-2)=0.0d0
3023 Ug2der(1,2,i-2)=0.0d0
3024 Ug2der(2,1,i-2)=0.0d0
3025 Ug2der(2,2,i-2)=0.0d0
3027 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3028 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3029 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3030 iti = itype2loc(itype(i-2))
3034 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3035 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3036 iti1 = itype2loc(itype(i-1))
3040 cd write (iout,*) '*******i',i,' iti1',iti
3041 cd write (iout,*) 'b1',b1(:,iti)
3042 cd write (iout,*) 'b2',b2(:,iti)
3043 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3044 c if (i .gt. iatel_s+2) then
3045 if (i .gt. nnt+2) then
3046 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3048 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3049 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3051 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3052 c & EE(1,2,iti),EE(2,2,i)
3053 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3054 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3055 c write(iout,*) "Macierz EUG",
3056 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3059 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3061 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3062 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3063 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3064 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3065 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3077 DtUg2(l,k,i-2)=0.0d0
3081 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3082 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3084 muder(k,i-2)=Ub2der(k,i-2)
3086 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3087 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3088 if (itype(i-1).le.ntyp) then
3089 iti1 = itype2loc(itype(i-1))
3097 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3098 c mu(k,i-2)=b1(k,i-1)
3099 c mu(k,i-2)=Ub2(k,i-2)
3102 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3103 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3104 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3105 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3106 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3107 & ((ee(l,k,i-2),l=1,2),k=1,2)
3109 cd write (iout,*) 'mu1',mu1(:,i-2)
3110 cd write (iout,*) 'mu2',mu2(:,i-2)
3111 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3113 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3115 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3116 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3117 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3118 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3119 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3120 C Vectors and matrices dependent on a single virtual-bond dihedral.
3121 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3122 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3123 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3124 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3125 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3126 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3127 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3128 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3129 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3134 C Matrices dependent on two consecutive virtual-bond dihedrals.
3135 C The order of matrices is from left to right.
3136 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3138 c do i=max0(ivec_start,2),ivec_end
3140 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3141 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3142 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3143 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3144 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3145 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3146 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3147 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3151 #if defined(MPI) && defined(PARMAT)
3153 c if (fg_rank.eq.0) then
3154 write (iout,*) "Arrays UG and UGDER before GATHER"
3156 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3157 & ((ug(l,k,i),l=1,2),k=1,2),
3158 & ((ugder(l,k,i),l=1,2),k=1,2)
3160 write (iout,*) "Arrays UG2 and UG2DER"
3162 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3163 & ((ug2(l,k,i),l=1,2),k=1,2),
3164 & ((ug2der(l,k,i),l=1,2),k=1,2)
3166 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3168 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3169 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3170 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3172 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3174 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3175 & costab(i),sintab(i),costab2(i),sintab2(i)
3177 write (iout,*) "Array MUDER"
3179 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3183 if (nfgtasks.gt.1) then
3185 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3186 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3187 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3189 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3190 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3192 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3193 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3195 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3196 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3198 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3199 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3201 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3202 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3204 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3205 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3207 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3208 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3209 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3210 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3211 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3212 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3213 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3214 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3215 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3216 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3217 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3218 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3220 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3222 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3223 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3225 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3226 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3228 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3229 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3231 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3232 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3234 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3235 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3237 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3238 & ivec_count(fg_rank1),
3239 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3241 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3242 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3244 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3245 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3247 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3248 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3250 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3251 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3253 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3254 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3256 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3257 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3259 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3260 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3262 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3263 & ivec_count(fg_rank1),
3264 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3266 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3267 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3269 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3270 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3272 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3273 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3275 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3276 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3279 & ivec_count(fg_rank1),
3280 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3282 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3283 & ivec_count(fg_rank1),
3284 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3286 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3287 & ivec_count(fg_rank1),
3288 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3289 & MPI_MAT2,FG_COMM1,IERR)
3290 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3291 & ivec_count(fg_rank1),
3292 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3293 & MPI_MAT2,FG_COMM1,IERR)
3297 c Passes matrix info through the ring
3300 if (irecv.lt.0) irecv=nfgtasks1-1
3303 if (inext.ge.nfgtasks1) inext=0
3305 c write (iout,*) "isend",isend," irecv",irecv
3307 lensend=lentyp(isend)
3308 lenrecv=lentyp(irecv)
3309 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3310 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3311 c & MPI_ROTAT1(lensend),inext,2200+isend,
3312 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3313 c & iprev,2200+irecv,FG_COMM,status,IERR)
3314 c write (iout,*) "Gather ROTAT1"
3316 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3317 c & MPI_ROTAT2(lensend),inext,3300+isend,
3318 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3319 c & iprev,3300+irecv,FG_COMM,status,IERR)
3320 c write (iout,*) "Gather ROTAT2"
3322 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3323 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3324 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3325 & iprev,4400+irecv,FG_COMM,status,IERR)
3326 c write (iout,*) "Gather ROTAT_OLD"
3328 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3329 & MPI_PRECOMP11(lensend),inext,5500+isend,
3330 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3331 & iprev,5500+irecv,FG_COMM,status,IERR)
3332 c write (iout,*) "Gather PRECOMP11"
3334 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3335 & MPI_PRECOMP12(lensend),inext,6600+isend,
3336 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3337 & iprev,6600+irecv,FG_COMM,status,IERR)
3338 c write (iout,*) "Gather PRECOMP12"
3341 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3343 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3344 & MPI_ROTAT2(lensend),inext,7700+isend,
3345 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3346 & iprev,7700+irecv,FG_COMM,status,IERR)
3347 c write (iout,*) "Gather PRECOMP21"
3349 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3350 & MPI_PRECOMP22(lensend),inext,8800+isend,
3351 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3352 & iprev,8800+irecv,FG_COMM,status,IERR)
3353 c write (iout,*) "Gather PRECOMP22"
3355 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3356 & MPI_PRECOMP23(lensend),inext,9900+isend,
3357 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3358 & MPI_PRECOMP23(lenrecv),
3359 & iprev,9900+irecv,FG_COMM,status,IERR)
3361 c write (iout,*) "Gather PRECOMP23"
3366 if (irecv.lt.0) irecv=nfgtasks1-1
3369 time_gather=time_gather+MPI_Wtime()-time00
3372 c if (fg_rank.eq.0) then
3373 write (iout,*) "Arrays UG and UGDER"
3375 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376 & ((ug(l,k,i),l=1,2),k=1,2),
3377 & ((ugder(l,k,i),l=1,2),k=1,2)
3379 write (iout,*) "Arrays UG2 and UG2DER"
3381 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3382 & ((ug2(l,k,i),l=1,2),k=1,2),
3383 & ((ug2der(l,k,i),l=1,2),k=1,2)
3385 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3387 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3388 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3389 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3391 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3393 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3394 & costab(i),sintab(i),costab2(i),sintab2(i)
3396 write (iout,*) "Array MUDER"
3398 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3404 cd iti = itype2loc(itype(i))
3407 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3408 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3413 C-----------------------------------------------------------------------------
3414 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3416 C This subroutine calculates the average interaction energy and its gradient
3417 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3418 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3419 C The potential depends both on the distance of peptide-group centers and on
3420 C the orientation of the CA-CA virtual bonds.
3422 implicit real*8 (a-h,o-z)
3426 include 'DIMENSIONS'
3427 include 'COMMON.CONTROL'
3428 include 'COMMON.SETUP'
3429 include 'COMMON.IOUNITS'
3430 include 'COMMON.GEO'
3431 include 'COMMON.VAR'
3432 include 'COMMON.LOCAL'
3433 include 'COMMON.CHAIN'
3434 include 'COMMON.DERIV'
3435 include 'COMMON.INTERACT'
3437 include 'COMMON.CONTACTS'
3438 include 'COMMON.CONTMAT'
3440 include 'COMMON.CORRMAT'
3441 include 'COMMON.TORSION'
3442 include 'COMMON.VECTORS'
3443 include 'COMMON.FFIELD'
3444 include 'COMMON.TIME1'
3445 include 'COMMON.SPLITELE'
3446 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3447 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3448 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3449 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3450 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3451 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3453 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3455 double precision scal_el /1.0d0/
3457 double precision scal_el /0.5d0/
3460 C 13-go grudnia roku pamietnego...
3461 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3462 & 0.0d0,1.0d0,0.0d0,
3463 & 0.0d0,0.0d0,1.0d0/
3464 cd write(iout,*) 'In EELEC'
3466 cd write(iout,*) 'Type',i
3467 cd write(iout,*) 'B1',B1(:,i)
3468 cd write(iout,*) 'B2',B2(:,i)
3469 cd write(iout,*) 'CC',CC(:,:,i)
3470 cd write(iout,*) 'DD',DD(:,:,i)
3471 cd write(iout,*) 'EE',EE(:,:,i)
3473 cd call check_vecgrad
3475 if (icheckgrad.eq.1) then
3477 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3479 dc_norm(k,i)=dc(k,i)*fac
3481 c write (iout,*) 'i',i,' fac',fac
3484 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3485 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3486 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3487 c call vec_and_deriv
3493 time_mat=time_mat+MPI_Wtime()-time01
3497 cd write (iout,*) 'i=',i
3499 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3502 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3503 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3518 cd print '(a)','Enter EELEC'
3519 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3521 gel_loc_loc(i)=0.0d0
3526 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3528 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3530 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3531 do i=iturn3_start,iturn3_end
3533 C write(iout,*) "tu jest i",i
3534 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3535 C changes suggested by Ana to avoid out of bounds
3536 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3537 c & .or.((i+4).gt.nres)
3538 c & .or.((i-1).le.0)
3539 C end of changes by Ana
3540 & .or. itype(i+2).eq.ntyp1
3541 & .or. itype(i+3).eq.ntyp1) cycle
3542 C Adam: Instructions below will switch off existing interactions
3544 c if(itype(i-1).eq.ntyp1)cycle
3546 c if(i.LT.nres-3)then
3547 c if (itype(i+4).eq.ntyp1) cycle
3552 dx_normi=dc_norm(1,i)
3553 dy_normi=dc_norm(2,i)
3554 dz_normi=dc_norm(3,i)
3555 xmedi=c(1,i)+0.5d0*dxi
3556 ymedi=c(2,i)+0.5d0*dyi
3557 zmedi=c(3,i)+0.5d0*dzi
3558 call to_box(xmedi,ymedi,zmedi)
3560 call eelecij(i,i+2,ees,evdw1,eel_loc)
3561 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3563 num_cont_hb(i)=num_conti
3566 do i=iturn4_start,iturn4_end
3568 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3569 C changes suggested by Ana to avoid out of bounds
3570 c & .or.((i+5).gt.nres)
3571 c & .or.((i-1).le.0)
3572 C end of changes suggested by Ana
3573 & .or. itype(i+3).eq.ntyp1
3574 & .or. itype(i+4).eq.ntyp1
3575 c & .or. itype(i+5).eq.ntyp1
3576 c & .or. itype(i).eq.ntyp1
3577 c & .or. itype(i-1).eq.ntyp1
3582 dx_normi=dc_norm(1,i)
3583 dy_normi=dc_norm(2,i)
3584 dz_normi=dc_norm(3,i)
3585 xmedi=c(1,i)+0.5d0*dxi
3586 ymedi=c(2,i)+0.5d0*dyi
3587 zmedi=c(3,i)+0.5d0*dzi
3588 C Return atom into box, boxxsize is size of box in x dimension
3590 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3591 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3592 C Condition for being inside the proper box
3593 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3594 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3598 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3599 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3600 C Condition for being inside the proper box
3601 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3602 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3606 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3607 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3608 C Condition for being inside the proper box
3609 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3610 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3613 call to_box(xmedi,ymedi,zmedi)
3615 num_conti=num_cont_hb(i)
3617 c write(iout,*) "JESTEM W PETLI"
3618 call eelecij(i,i+3,ees,evdw1,eel_loc)
3619 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3620 & call eturn4(i,eello_turn4)
3622 num_cont_hb(i)=num_conti
3625 C Loop over all neighbouring boxes
3630 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3633 c do i=iatel_s,iatel_e
3634 do ikont=g_listpp_start,g_listpp_end
3635 i=newcontlistppi(ikont)
3636 j=newcontlistppj(ikont)
3639 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3640 C changes suggested by Ana to avoid out of bounds
3641 c & .or.((i+2).gt.nres)
3642 c & .or.((i-1).le.0)
3643 C end of changes by Ana
3644 c & .or. itype(i+2).eq.ntyp1
3645 c & .or. itype(i-1).eq.ntyp1
3650 dx_normi=dc_norm(1,i)
3651 dy_normi=dc_norm(2,i)
3652 dz_normi=dc_norm(3,i)
3653 xmedi=c(1,i)+0.5d0*dxi
3654 ymedi=c(2,i)+0.5d0*dyi
3655 zmedi=c(3,i)+0.5d0*dzi
3656 call to_box(xmedi,ymedi,zmedi)
3657 C xmedi=xmedi+xshift*boxxsize
3658 C ymedi=ymedi+yshift*boxysize
3659 C zmedi=zmedi+zshift*boxzsize
3661 C Return tom into box, boxxsize is size of box in x dimension
3663 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3664 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3665 C Condition for being inside the proper box
3666 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3667 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3671 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3672 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3673 C Condition for being inside the proper box
3674 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3675 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3679 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3680 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3681 cC Condition for being inside the proper box
3682 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3683 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3687 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3689 num_conti=num_cont_hb(i)
3692 c do j=ielstart(i),ielend(i)
3694 C write (iout,*) i,j
3696 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3697 C changes suggested by Ana to avoid out of bounds
3698 c & .or.((j+2).gt.nres)
3699 c & .or.((j-1).le.0)
3700 C end of changes by Ana
3701 c & .or.itype(j+2).eq.ntyp1
3702 c & .or.itype(j-1).eq.ntyp1
3704 call eelecij(i,j,ees,evdw1,eel_loc)
3707 num_cont_hb(i)=num_conti
3714 c write (iout,*) "Number of loop steps in EELEC:",ind
3716 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3717 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3719 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3720 ccc eel_loc=eel_loc+eello_turn3
3721 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3724 C-------------------------------------------------------------------------------
3725 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3727 include 'DIMENSIONS'
3731 include 'COMMON.CONTROL'
3732 include 'COMMON.IOUNITS'
3733 include 'COMMON.GEO'
3734 include 'COMMON.VAR'
3735 include 'COMMON.LOCAL'
3736 include 'COMMON.CHAIN'
3737 include 'COMMON.DERIV'
3738 include 'COMMON.INTERACT'
3740 include 'COMMON.CONTACTS'
3741 include 'COMMON.CONTMAT'
3743 include 'COMMON.CORRMAT'
3744 include 'COMMON.TORSION'
3745 include 'COMMON.VECTORS'
3746 include 'COMMON.FFIELD'
3747 include 'COMMON.TIME1'
3748 include 'COMMON.SPLITELE'
3749 include 'COMMON.SHIELD'
3750 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3751 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3752 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3753 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3754 & gmuij2(4),gmuji2(4)
3755 double precision dxi,dyi,dzi
3756 double precision dx_normi,dy_normi,dz_normi,aux
3757 integer j1,j2,lll,num_conti
3758 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3759 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3761 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3762 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3763 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3764 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3765 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3766 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3767 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3768 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3769 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3770 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3771 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3772 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3773 double precision xmedi,ymedi,zmedi
3774 double precision sscale,sscagrad,scalar
3775 double precision boxshift
3776 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3778 double precision scal_el /1.0d0/
3780 double precision scal_el /0.5d0/
3783 C 13-go grudnia roku pamietnego...
3784 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3785 & 0.0d0,1.0d0,0.0d0,
3786 & 0.0d0,0.0d0,1.0d0/
3787 c time00=MPI_Wtime()
3788 cd write (iout,*) "eelecij",i,j
3792 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3793 aaa=app(iteli,itelj)
3794 bbb=bpp(iteli,itelj)
3795 ael6i=ael6(iteli,itelj)
3796 ael3i=ael3(iteli,itelj)
3800 dx_normj=dc_norm(1,j)
3801 dy_normj=dc_norm(2,j)
3802 dz_normj=dc_norm(3,j)
3803 C xj=c(1,j)+0.5D0*dxj-xmedi
3804 C yj=c(2,j)+0.5D0*dyj-ymedi
3805 C zj=c(3,j)+0.5D0*dzj-zmedi
3809 call to_box(xj,yj,zj)
3810 xj=boxshift(xj-xmedi,boxxsize)
3811 yj=boxshift(yj-ymedi,boxysize)
3812 zj=boxshift(zj-zmedi,boxzsize)
3813 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3815 rij=xj*xj+yj*yj+zj*zj
3817 sss=sscale(dsqrt(rij),r_cut_int)
3818 if (sss.eq.0.0d0) return
3819 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3820 c if (sss.gt.0.0d0) then
3826 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3827 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3828 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3829 fac=cosa-3.0D0*cosb*cosg
3831 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3832 if (j.eq.i+2) ev1=scal_el*ev1
3837 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3841 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3842 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3843 if (shield_mode.gt.0) then
3846 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3847 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3856 evdw1=evdw1+evdwij*sss
3857 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3858 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3859 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3860 cd & xmedi,ymedi,zmedi,xj,yj,zj
3862 if (energy_dec) then
3863 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3864 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3865 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3866 & fac_shield(i),fac_shield(j)
3870 C Calculate contributions to the Cartesian gradient.
3873 facvdw=-6*rrmij*(ev1+evdwij)*sss
3874 facel=-3*rrmij*(el1+eesij)
3881 * Radial derivatives. First process both termini of the fragment (i,j)
3883 aux=facel*sss+rmij*sssgrad*eesij
3887 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3888 & (shield_mode.gt.0)) then
3890 do ilist=1,ishield_list(i)
3891 iresshield=shield_list(ilist,i)
3893 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3895 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3897 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3898 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3899 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3900 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3901 C if (iresshield.gt.i) then
3902 C do ishi=i+1,iresshield-1
3903 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3904 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3908 C do ishi=iresshield,i
3909 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3910 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3916 do ilist=1,ishield_list(j)
3917 iresshield=shield_list(ilist,j)
3919 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3921 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3923 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3924 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3926 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3927 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3928 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3929 C if (iresshield.gt.j) then
3930 C do ishi=j+1,iresshield-1
3931 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3932 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3936 C do ishi=iresshield,j
3937 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3938 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3945 gshieldc(k,i)=gshieldc(k,i)+
3946 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3947 gshieldc(k,j)=gshieldc(k,j)+
3948 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3949 gshieldc(k,i-1)=gshieldc(k,i-1)+
3950 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3951 gshieldc(k,j-1)=gshieldc(k,j-1)+
3952 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3957 c ghalf=0.5D0*ggg(k)
3958 c gelc(k,i)=gelc(k,i)+ghalf
3959 c gelc(k,j)=gelc(k,j)+ghalf
3961 c 9/28/08 AL Gradient compotents will be summed only at the end
3962 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3964 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3965 C & +grad_shield(k,j)*eesij/fac_shield(j)
3966 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3967 C & +grad_shield(k,i)*eesij/fac_shield(i)
3968 C gelc_long(k,i-1)=gelc_long(k,i-1)
3969 C & +grad_shield(k,i)*eesij/fac_shield(i)
3970 C gelc_long(k,j-1)=gelc_long(k,j-1)
3971 C & +grad_shield(k,j)*eesij/fac_shield(j)
3973 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3976 * Loop over residues i+1 thru j-1.
3980 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3983 facvdw=facvdw+sssgrad*rmij*evdwij
3988 c ghalf=0.5D0*ggg(k)
3989 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3990 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3992 c 9/28/08 AL Gradient compotents will be summed only at the end
3994 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3995 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3998 * Loop over residues i+1 thru j-1.
4002 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4010 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4011 & +(evdwij+eesij)*sssgrad*rrmij
4016 * Radial derivatives. First process both termini of the fragment (i,j)
4019 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4021 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4023 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4025 c ghalf=0.5D0*ggg(k)
4026 c gelc(k,i)=gelc(k,i)+ghalf
4027 c gelc(k,j)=gelc(k,j)+ghalf
4029 c 9/28/08 AL Gradient compotents will be summed only at the end
4031 gelc_long(k,j)=gelc(k,j)+ggg(k)
4032 gelc_long(k,i)=gelc(k,i)-ggg(k)
4035 * Loop over residues i+1 thru j-1.
4039 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4042 c 9/28/08 AL Gradient compotents will be summed only at the end
4043 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4044 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4045 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4047 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4048 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4054 ecosa=2.0D0*fac3*fac1+fac4
4057 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4058 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4060 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4061 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4063 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4064 cd & (dcosg(k),k=1,3)
4066 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4067 & fac_shield(i)**2*fac_shield(j)**2*sss
4070 c ghalf=0.5D0*ggg(k)
4071 c gelc(k,i)=gelc(k,i)+ghalf
4072 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4073 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4074 c gelc(k,j)=gelc(k,j)+ghalf
4075 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4076 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4080 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4083 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4086 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4087 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4088 & *fac_shield(i)**2*fac_shield(j)**2
4090 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4091 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4092 & *fac_shield(i)**2*fac_shield(j)**2
4093 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4094 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4096 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4100 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4101 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4102 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4104 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4105 C energy of a peptide unit is assumed in the form of a second-order
4106 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4107 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4108 C are computed for EVERY pair of non-contiguous peptide groups.
4111 if (j.lt.nres-1) then
4123 muij(kkk)=mu(k,i)*mu(l,j)
4124 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4126 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4127 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4128 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4129 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4130 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4131 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4136 write (iout,*) 'EELEC: i',i,' j',j
4137 write (iout,*) 'j',j,' j1',j1,' j2',j2
4138 write(iout,*) 'muij',muij
4140 ury=scalar(uy(1,i),erij)
4141 urz=scalar(uz(1,i),erij)
4142 vry=scalar(uy(1,j),erij)
4143 vrz=scalar(uz(1,j),erij)
4144 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4145 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4146 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4147 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4148 fac=dsqrt(-ael6i)*r3ij
4150 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4151 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4152 & "uyvz",scalar(uy(1,i),uz(1,j)),
4153 & "uzvy",scalar(uz(1,i),uy(1,j)),
4154 & "uzvz",scalar(uz(1,i),uz(1,j))
4155 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4156 write (iout,*) "fac",fac
4163 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4166 cd write (iout,'(4i5,4f10.5)')
4167 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4168 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4169 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4170 cd & uy(:,j),uz(:,j)
4171 cd write (iout,'(4f10.5)')
4172 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4173 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4174 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4175 cd write (iout,'(9f10.5/)')
4176 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4177 C Derivatives of the elements of A in virtual-bond vectors
4178 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4180 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4181 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4182 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4183 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4184 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4185 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4186 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4187 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4188 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4189 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4190 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4191 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4193 C Compute radial contributions to the gradient
4211 C Add the contributions coming from er
4214 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4215 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4216 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4217 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4220 C Derivatives in DC(i)
4221 cgrad ghalf1=0.5d0*agg(k,1)
4222 cgrad ghalf2=0.5d0*agg(k,2)
4223 cgrad ghalf3=0.5d0*agg(k,3)
4224 cgrad ghalf4=0.5d0*agg(k,4)
4225 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4226 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4227 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4228 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4229 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4230 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4231 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4232 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4233 C Derivatives in DC(i+1)
4234 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4235 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4236 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4237 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4238 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4239 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4240 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4241 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4242 C Derivatives in DC(j)
4243 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4244 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4245 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4246 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4247 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4248 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4249 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4250 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4251 C Derivatives in DC(j+1) or DC(nres-1)
4252 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4253 & -3.0d0*vryg(k,3)*ury)
4254 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4255 & -3.0d0*vrzg(k,3)*ury)
4256 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4257 & -3.0d0*vryg(k,3)*urz)
4258 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4259 & -3.0d0*vrzg(k,3)*urz)
4260 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4262 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4275 aggi(k,l)=-aggi(k,l)
4276 aggi1(k,l)=-aggi1(k,l)
4277 aggj(k,l)=-aggj(k,l)
4278 aggj1(k,l)=-aggj1(k,l)
4281 if (j.lt.nres-1) then
4287 aggi(k,l)=-aggi(k,l)
4288 aggi1(k,l)=-aggi1(k,l)
4289 aggj(k,l)=-aggj(k,l)
4290 aggj1(k,l)=-aggj1(k,l)
4301 aggi(k,l)=-aggi(k,l)
4302 aggi1(k,l)=-aggi1(k,l)
4303 aggj(k,l)=-aggj(k,l)
4304 aggj1(k,l)=-aggj1(k,l)
4309 IF (wel_loc.gt.0.0d0) THEN
4310 C Contribution to the local-electrostatic energy coming from the i-j pair
4311 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4314 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4316 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4317 & " wel_loc",wel_loc
4319 if (shield_mode.eq.0) then
4326 eel_loc_ij=eel_loc_ij
4327 & *fac_shield(i)*fac_shield(j)*sss
4328 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4329 c & 'eelloc',i,j,eel_loc_ij
4330 C Now derivative over eel_loc
4331 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4332 & (shield_mode.gt.0)) then
4335 do ilist=1,ishield_list(i)
4336 iresshield=shield_list(ilist,i)
4338 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4341 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4343 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4344 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4348 do ilist=1,ishield_list(j)
4349 iresshield=shield_list(ilist,j)
4351 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4354 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4356 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4357 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4364 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4365 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4366 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4367 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4368 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4369 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4370 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4371 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4376 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4377 c & ' eel_loc_ij',eel_loc_ij
4378 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4379 C Calculate patrial derivative for theta angle
4381 geel_loc_ij=(a22*gmuij1(1)
4385 & *fac_shield(i)*fac_shield(j)*sss
4386 c write(iout,*) "derivative over thatai"
4387 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4389 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4390 & geel_loc_ij*wel_loc
4391 c write(iout,*) "derivative over thatai-1"
4392 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4399 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4400 & geel_loc_ij*wel_loc
4401 & *fac_shield(i)*fac_shield(j)*sss
4403 c Derivative over j residue
4404 geel_loc_ji=a22*gmuji1(1)
4408 c write(iout,*) "derivative over thataj"
4409 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4412 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4413 & geel_loc_ji*wel_loc
4414 & *fac_shield(i)*fac_shield(j)*sss
4421 c write(iout,*) "derivative over thataj-1"
4422 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4424 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4425 & geel_loc_ji*wel_loc
4426 & *fac_shield(i)*fac_shield(j)*sss
4428 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4430 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4431 & 'eelloc',i,j,eel_loc_ij
4432 c if (eel_loc_ij.ne.0)
4433 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4434 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4436 eel_loc=eel_loc+eel_loc_ij
4437 C Partial derivatives in virtual-bond dihedral angles gamma
4439 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4440 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4441 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4442 & *fac_shield(i)*fac_shield(j)*sss
4444 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4445 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4446 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4447 & *fac_shield(i)*fac_shield(j)*sss
4448 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4449 aux=eel_loc_ij/sss*sssgrad*rmij
4454 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4455 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4456 & *fac_shield(i)*fac_shield(j)*sss
4457 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4458 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4459 cgrad ghalf=0.5d0*ggg(l)
4460 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4461 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4465 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4468 C Remaining derivatives of eello
4470 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4471 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4472 & *fac_shield(i)*fac_shield(j)*sss
4474 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4475 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4476 & *fac_shield(i)*fac_shield(j)*sss
4478 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4479 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4480 & *fac_shield(i)*fac_shield(j)*sss
4482 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4483 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4484 & *fac_shield(i)*fac_shield(j)*sss
4488 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4489 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4491 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4492 & .and. num_conti.le.maxconts) then
4493 c write (iout,*) i,j," entered corr"
4495 C Calculate the contact function. The ith column of the array JCONT will
4496 C contain the numbers of atoms that make contacts with the atom I (of numbers
4497 C greater than I). The arrays FACONT and GACONT will contain the values of
4498 C the contact function and its derivative.
4499 c r0ij=1.02D0*rpp(iteli,itelj)
4500 c r0ij=1.11D0*rpp(iteli,itelj)
4501 r0ij=2.20D0*rpp(iteli,itelj)
4502 c r0ij=1.55D0*rpp(iteli,itelj)
4503 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4504 if (fcont.gt.0.0D0) then
4505 num_conti=num_conti+1
4506 if (num_conti.gt.maxconts) then
4507 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4508 & ' will skip next contacts for this conf.'
4510 jcont_hb(num_conti,i)=j
4511 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4512 cd & " jcont_hb",jcont_hb(num_conti,i)
4513 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4514 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4515 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4517 d_cont(num_conti,i)=rij
4518 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4519 C --- Electrostatic-interaction matrix ---
4520 a_chuj(1,1,num_conti,i)=a22
4521 a_chuj(1,2,num_conti,i)=a23
4522 a_chuj(2,1,num_conti,i)=a32
4523 a_chuj(2,2,num_conti,i)=a33
4524 C --- Gradient of rij
4526 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4533 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4534 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4535 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4536 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4537 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4542 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4543 C Calculate contact energies
4545 wij=cosa-3.0D0*cosb*cosg
4548 c fac3=dsqrt(-ael6i)/r0ij**3
4549 fac3=dsqrt(-ael6i)*r3ij
4550 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4551 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4552 if (ees0tmp.gt.0) then
4553 ees0pij=dsqrt(ees0tmp)
4557 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4558 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4559 if (ees0tmp.gt.0) then
4560 ees0mij=dsqrt(ees0tmp)
4565 if (shield_mode.eq.0) then
4569 ees0plist(num_conti,i)=j
4570 C fac_shield(i)=0.4d0
4571 C fac_shield(j)=0.6d0
4573 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4574 & *fac_shield(i)*fac_shield(j)*sss
4575 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4576 & *fac_shield(i)*fac_shield(j)*sss
4577 C Diagnostics. Comment out or remove after debugging!
4578 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4579 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4580 c ees0m(num_conti,i)=0.0D0
4582 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4583 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4584 C Angular derivatives of the contact function
4585 ees0pij1=fac3/ees0pij
4586 ees0mij1=fac3/ees0mij
4587 fac3p=-3.0D0*fac3*rrmij
4588 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4589 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4591 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4592 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4593 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4594 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4595 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4596 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4597 ecosap=ecosa1+ecosa2
4598 ecosbp=ecosb1+ecosb2
4599 ecosgp=ecosg1+ecosg2
4600 ecosam=ecosa1-ecosa2
4601 ecosbm=ecosb1-ecosb2
4602 ecosgm=ecosg1-ecosg2
4611 facont_hb(num_conti,i)=fcont
4612 fprimcont=fprimcont/rij
4613 cd facont_hb(num_conti,i)=1.0D0
4614 C Following line is for diagnostics.
4617 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4618 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4621 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4622 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4624 gggp(1)=gggp(1)+ees0pijp*xj
4625 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4626 gggp(2)=gggp(2)+ees0pijp*yj
4627 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4628 gggp(3)=gggp(3)+ees0pijp*zj
4629 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4630 gggm(1)=gggm(1)+ees0mijp*xj
4631 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4632 gggm(2)=gggm(2)+ees0mijp*yj
4633 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4634 gggm(3)=gggm(3)+ees0mijp*zj
4635 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4636 C Derivatives due to the contact function
4637 gacont_hbr(1,num_conti,i)=fprimcont*xj
4638 gacont_hbr(2,num_conti,i)=fprimcont*yj
4639 gacont_hbr(3,num_conti,i)=fprimcont*zj
4642 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4643 c following the change of gradient-summation algorithm.
4645 cgrad ghalfp=0.5D0*gggp(k)
4646 cgrad ghalfm=0.5D0*gggm(k)
4647 gacontp_hb1(k,num_conti,i)=!ghalfp
4648 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4649 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4650 & *fac_shield(i)*fac_shield(j)*sss
4652 gacontp_hb2(k,num_conti,i)=!ghalfp
4653 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4654 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4655 & *fac_shield(i)*fac_shield(j)*sss
4657 gacontp_hb3(k,num_conti,i)=gggp(k)
4658 & *fac_shield(i)*fac_shield(j)*sss
4660 gacontm_hb1(k,num_conti,i)=!ghalfm
4661 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4662 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4663 & *fac_shield(i)*fac_shield(j)*sss
4665 gacontm_hb2(k,num_conti,i)=!ghalfm
4666 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4667 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4668 & *fac_shield(i)*fac_shield(j)*sss
4670 gacontm_hb3(k,num_conti,i)=gggm(k)
4671 & *fac_shield(i)*fac_shield(j)*sss
4674 C Diagnostics. Comment out or remove after debugging!
4676 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4677 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4678 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4679 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4680 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4681 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4684 endif ! num_conti.le.maxconts
4688 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4691 ghalf=0.5d0*agg(l,k)
4692 aggi(l,k)=aggi(l,k)+ghalf
4693 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4694 aggj(l,k)=aggj(l,k)+ghalf
4697 if (j.eq.nres-1 .and. i.lt.j-2) then
4700 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4705 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4708 C-----------------------------------------------------------------------------
4709 subroutine eturn3(i,eello_turn3)
4710 C Third- and fourth-order contributions from turns
4711 implicit real*8 (a-h,o-z)
4712 include 'DIMENSIONS'
4713 include 'COMMON.IOUNITS'
4714 include 'COMMON.GEO'
4715 include 'COMMON.VAR'
4716 include 'COMMON.LOCAL'
4717 include 'COMMON.CHAIN'
4718 include 'COMMON.DERIV'
4719 include 'COMMON.INTERACT'
4720 include 'COMMON.CORRMAT'
4721 include 'COMMON.TORSION'
4722 include 'COMMON.VECTORS'
4723 include 'COMMON.FFIELD'
4724 include 'COMMON.CONTROL'
4725 include 'COMMON.SHIELD'
4727 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4728 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4729 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4730 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4731 & auxgmat2(2,2),auxgmatt2(2,2)
4732 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4733 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4734 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4735 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4738 c write (iout,*) "eturn3",i,j,j1,j2
4743 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4745 C Third-order contributions
4752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4753 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4754 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4755 c auxalary matices for theta gradient
4756 c auxalary matrix for i+1 and constant i+2
4757 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4758 c auxalary matrix for i+2 and constant i+1
4759 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4760 call transpose2(auxmat(1,1),auxmat1(1,1))
4761 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4762 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4763 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4764 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4765 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4766 if (shield_mode.eq.0) then
4773 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4774 & *fac_shield(i)*fac_shield(j)
4775 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4776 & *fac_shield(i)*fac_shield(j)
4777 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4780 C Derivatives in theta
4781 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4782 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4783 & *fac_shield(i)*fac_shield(j)
4784 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4785 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4786 & *fac_shield(i)*fac_shield(j)
4789 C Derivatives in shield mode
4790 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4791 & (shield_mode.gt.0)) then
4794 do ilist=1,ishield_list(i)
4795 iresshield=shield_list(ilist,i)
4797 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4799 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4801 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4802 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4806 do ilist=1,ishield_list(j)
4807 iresshield=shield_list(ilist,j)
4809 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4811 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4813 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4814 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4821 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4822 & grad_shield(k,i)*eello_t3/fac_shield(i)
4823 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4824 & grad_shield(k,j)*eello_t3/fac_shield(j)
4825 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4826 & grad_shield(k,i)*eello_t3/fac_shield(i)
4827 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4828 & grad_shield(k,j)*eello_t3/fac_shield(j)
4832 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4833 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4834 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4835 cd & ' eello_turn3_num',4*eello_turn3_num
4836 C Derivatives in gamma(i)
4837 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4838 call transpose2(auxmat2(1,1),auxmat3(1,1))
4839 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4840 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4841 & *fac_shield(i)*fac_shield(j)
4842 C Derivatives in gamma(i+1)
4843 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4844 call transpose2(auxmat2(1,1),auxmat3(1,1))
4845 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4846 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4847 & +0.5d0*(pizda(1,1)+pizda(2,2))
4848 & *fac_shield(i)*fac_shield(j)
4849 C Cartesian derivatives
4851 c ghalf1=0.5d0*agg(l,1)
4852 c ghalf2=0.5d0*agg(l,2)
4853 c ghalf3=0.5d0*agg(l,3)
4854 c ghalf4=0.5d0*agg(l,4)
4855 a_temp(1,1)=aggi(l,1)!+ghalf1
4856 a_temp(1,2)=aggi(l,2)!+ghalf2
4857 a_temp(2,1)=aggi(l,3)!+ghalf3
4858 a_temp(2,2)=aggi(l,4)!+ghalf4
4859 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4860 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4861 & +0.5d0*(pizda(1,1)+pizda(2,2))
4862 & *fac_shield(i)*fac_shield(j)
4864 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4865 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4866 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4867 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4868 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4869 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4870 & +0.5d0*(pizda(1,1)+pizda(2,2))
4871 & *fac_shield(i)*fac_shield(j)
4872 a_temp(1,1)=aggj(l,1)!+ghalf1
4873 a_temp(1,2)=aggj(l,2)!+ghalf2
4874 a_temp(2,1)=aggj(l,3)!+ghalf3
4875 a_temp(2,2)=aggj(l,4)!+ghalf4
4876 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4877 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4878 & +0.5d0*(pizda(1,1)+pizda(2,2))
4879 & *fac_shield(i)*fac_shield(j)
4880 a_temp(1,1)=aggj1(l,1)
4881 a_temp(1,2)=aggj1(l,2)
4882 a_temp(2,1)=aggj1(l,3)
4883 a_temp(2,2)=aggj1(l,4)
4884 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4885 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4886 & +0.5d0*(pizda(1,1)+pizda(2,2))
4887 & *fac_shield(i)*fac_shield(j)
4891 C-------------------------------------------------------------------------------
4892 subroutine eturn4(i,eello_turn4)
4893 C Third- and fourth-order contributions from turns
4894 implicit real*8 (a-h,o-z)
4895 include 'DIMENSIONS'
4896 include 'COMMON.IOUNITS'
4897 include 'COMMON.GEO'
4898 include 'COMMON.VAR'
4899 include 'COMMON.LOCAL'
4900 include 'COMMON.CHAIN'
4901 include 'COMMON.DERIV'
4902 include 'COMMON.INTERACT'
4903 include 'COMMON.CORRMAT'
4904 include 'COMMON.TORSION'
4905 include 'COMMON.VECTORS'
4906 include 'COMMON.FFIELD'
4907 include 'COMMON.CONTROL'
4908 include 'COMMON.SHIELD'
4910 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4911 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4912 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4913 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4914 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4915 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4916 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4917 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4918 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4919 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4920 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4923 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4925 C Fourth-order contributions
4933 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4934 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4935 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4936 c write(iout,*)"WCHODZE W PROGRAM"
4941 iti1=itype2loc(itype(i+1))
4942 iti2=itype2loc(itype(i+2))
4943 iti3=itype2loc(itype(i+3))
4944 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4945 call transpose2(EUg(1,1,i+1),e1t(1,1))
4946 call transpose2(Eug(1,1,i+2),e2t(1,1))
4947 call transpose2(Eug(1,1,i+3),e3t(1,1))
4948 C Ematrix derivative in theta
4949 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4950 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4951 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4952 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4953 c eta1 in derivative theta
4954 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4955 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4956 c auxgvec is derivative of Ub2 so i+3 theta
4957 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4958 c auxalary matrix of E i+1
4959 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4962 s1=scalar2(b1(1,i+2),auxvec(1))
4963 c derivative of theta i+2 with constant i+3
4964 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4965 c derivative of theta i+2 with constant i+2
4966 gs32=scalar2(b1(1,i+2),auxgvec(1))
4967 c derivative of E matix in theta of i+1
4968 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4970 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4971 c ea31 in derivative theta
4972 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4973 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4974 c auxilary matrix auxgvec of Ub2 with constant E matirx
4975 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4976 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4977 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4981 s2=scalar2(b1(1,i+1),auxvec(1))
4982 c derivative of theta i+1 with constant i+3
4983 gs13=scalar2(gtb1(1,i+1),auxvec(1))
4984 c derivative of theta i+2 with constant i+1
4985 gs21=scalar2(b1(1,i+1),auxgvec(1))
4986 c derivative of theta i+3 with constant i+1
4987 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4988 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4990 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4991 c two derivatives over diffetent matrices
4992 c gtae3e2 is derivative over i+3
4993 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4994 c ae3gte2 is derivative over i+2
4995 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4996 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4997 c three possible derivative over theta E matices
4999 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5001 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5003 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5004 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5006 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5007 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5008 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5009 if (shield_mode.eq.0) then
5016 eello_turn4=eello_turn4-(s1+s2+s3)
5017 & *fac_shield(i)*fac_shield(j)
5018 eello_t4=-(s1+s2+s3)
5019 & *fac_shield(i)*fac_shield(j)
5020 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5021 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5022 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5023 C Now derivative over shield:
5024 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5025 & (shield_mode.gt.0)) then
5028 do ilist=1,ishield_list(i)
5029 iresshield=shield_list(ilist,i)
5031 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5033 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5035 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5036 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5040 do ilist=1,ishield_list(j)
5041 iresshield=shield_list(ilist,j)
5043 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5045 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5047 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5048 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5055 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5056 & grad_shield(k,i)*eello_t4/fac_shield(i)
5057 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5058 & grad_shield(k,j)*eello_t4/fac_shield(j)
5059 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5060 & grad_shield(k,i)*eello_t4/fac_shield(i)
5061 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5062 & grad_shield(k,j)*eello_t4/fac_shield(j)
5071 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5072 cd & ' eello_turn4_num',8*eello_turn4_num
5074 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5075 & -(gs13+gsE13+gsEE1)*wturn4
5076 & *fac_shield(i)*fac_shield(j)
5077 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5078 & -(gs23+gs21+gsEE2)*wturn4
5079 & *fac_shield(i)*fac_shield(j)
5081 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5082 & -(gs32+gsE31+gsEE3)*wturn4
5083 & *fac_shield(i)*fac_shield(j)
5085 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5088 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5089 & 'eturn4',i,j,-(s1+s2+s3)
5090 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5091 c & ' eello_turn4_num',8*eello_turn4_num
5092 C Derivatives in gamma(i)
5093 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5094 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5095 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5096 s1=scalar2(b1(1,i+2),auxvec(1))
5097 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5098 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5099 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5100 & *fac_shield(i)*fac_shield(j)
5101 C Derivatives in gamma(i+1)
5102 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5103 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5104 s2=scalar2(b1(1,i+1),auxvec(1))
5105 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5106 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5107 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5108 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5109 & *fac_shield(i)*fac_shield(j)
5110 C Derivatives in gamma(i+2)
5111 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5112 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5113 s1=scalar2(b1(1,i+2),auxvec(1))
5114 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5115 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5116 s2=scalar2(b1(1,i+1),auxvec(1))
5117 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5118 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5119 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5120 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5121 & *fac_shield(i)*fac_shield(j)
5122 C Cartesian derivatives
5123 C Derivatives of this turn contributions in DC(i+2)
5124 if (j.lt.nres-1) then
5126 a_temp(1,1)=agg(l,1)
5127 a_temp(1,2)=agg(l,2)
5128 a_temp(2,1)=agg(l,3)
5129 a_temp(2,2)=agg(l,4)
5130 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5131 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5132 s1=scalar2(b1(1,i+2),auxvec(1))
5133 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5134 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5135 s2=scalar2(b1(1,i+1),auxvec(1))
5136 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5137 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5138 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5140 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5141 & *fac_shield(i)*fac_shield(j)
5144 C Remaining derivatives of this turn contribution
5146 a_temp(1,1)=aggi(l,1)
5147 a_temp(1,2)=aggi(l,2)
5148 a_temp(2,1)=aggi(l,3)
5149 a_temp(2,2)=aggi(l,4)
5150 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5151 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5152 s1=scalar2(b1(1,i+2),auxvec(1))
5153 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5154 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5155 s2=scalar2(b1(1,i+1),auxvec(1))
5156 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5157 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5158 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5159 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5160 & *fac_shield(i)*fac_shield(j)
5161 a_temp(1,1)=aggi1(l,1)
5162 a_temp(1,2)=aggi1(l,2)
5163 a_temp(2,1)=aggi1(l,3)
5164 a_temp(2,2)=aggi1(l,4)
5165 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5166 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5167 s1=scalar2(b1(1,i+2),auxvec(1))
5168 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5169 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5170 s2=scalar2(b1(1,i+1),auxvec(1))
5171 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5172 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5173 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5174 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5175 & *fac_shield(i)*fac_shield(j)
5176 a_temp(1,1)=aggj(l,1)
5177 a_temp(1,2)=aggj(l,2)
5178 a_temp(2,1)=aggj(l,3)
5179 a_temp(2,2)=aggj(l,4)
5180 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5181 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5182 s1=scalar2(b1(1,i+2),auxvec(1))
5183 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5184 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5185 s2=scalar2(b1(1,i+1),auxvec(1))
5186 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5187 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5188 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5189 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5190 & *fac_shield(i)*fac_shield(j)
5191 a_temp(1,1)=aggj1(l,1)
5192 a_temp(1,2)=aggj1(l,2)
5193 a_temp(2,1)=aggj1(l,3)
5194 a_temp(2,2)=aggj1(l,4)
5195 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5196 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5197 s1=scalar2(b1(1,i+2),auxvec(1))
5198 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5199 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5200 s2=scalar2(b1(1,i+1),auxvec(1))
5201 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5202 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5203 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5204 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5205 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5206 & *fac_shield(i)*fac_shield(j)
5210 C-----------------------------------------------------------------------------
5211 subroutine vecpr(u,v,w)
5212 implicit real*8(a-h,o-z)
5213 dimension u(3),v(3),w(3)
5214 w(1)=u(2)*v(3)-u(3)*v(2)
5215 w(2)=-u(1)*v(3)+u(3)*v(1)
5216 w(3)=u(1)*v(2)-u(2)*v(1)
5219 C-----------------------------------------------------------------------------
5220 subroutine unormderiv(u,ugrad,unorm,ungrad)
5221 C This subroutine computes the derivatives of a normalized vector u, given
5222 C the derivatives computed without normalization conditions, ugrad. Returns
5225 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5226 double precision vec(3)
5227 double precision scalar
5229 c write (2,*) 'ugrad',ugrad
5232 vec(i)=scalar(ugrad(1,i),u(1))
5234 c write (2,*) 'vec',vec
5237 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5240 c write (2,*) 'ungrad',ungrad
5243 C-----------------------------------------------------------------------------
5244 subroutine escp_soft_sphere(evdw2,evdw2_14)
5246 C This subroutine calculates the excluded-volume interaction energy between
5247 C peptide-group centers and side chains and its gradient in virtual-bond and
5248 C side-chain vectors.
5250 implicit real*8 (a-h,o-z)
5251 include 'DIMENSIONS'
5252 include 'COMMON.GEO'
5253 include 'COMMON.VAR'
5254 include 'COMMON.LOCAL'
5255 include 'COMMON.CHAIN'
5256 include 'COMMON.DERIV'
5257 include 'COMMON.INTERACT'
5258 include 'COMMON.FFIELD'
5259 include 'COMMON.IOUNITS'
5260 include 'COMMON.CONTROL'
5262 double precision boxshift
5266 cd print '(a)','Enter ESCP'
5267 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5271 c do i=iatscp_s,iatscp_e
5272 do ikont=g_listscp_start,g_listscp_end
5273 i=newcontlistscpi(ikont)
5274 j=newcontlistscpj(ikont)
5275 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5277 xi=0.5D0*(c(1,i)+c(1,i+1))
5278 yi=0.5D0*(c(2,i)+c(2,i+1))
5279 zi=0.5D0*(c(3,i)+c(3,i+1))
5280 C Return atom into box, boxxsize is size of box in x dimension
5282 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5283 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5284 C Condition for being inside the proper box
5285 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5286 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5290 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5291 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5292 C Condition for being inside the proper box
5293 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5294 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5298 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5299 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5300 cC Condition for being inside the proper box
5301 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5302 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5305 call to_box(xi,yi,zi)
5306 C xi=xi+xshift*boxxsize
5307 C yi=yi+yshift*boxysize
5308 C zi=zi+zshift*boxzsize
5309 c do iint=1,nscp_gr(i)
5311 c do j=iscpstart(i,iint),iscpend(i,iint)
5312 if (itype(j).eq.ntyp1) cycle
5313 itypj=iabs(itype(j))
5314 C Uncomment following three lines for SC-p interactions
5318 C Uncomment following three lines for Ca-p interactions
5322 call to_box(xj,yj,zj)
5323 xj=boxshift(xj-xi,boxxsize)
5324 yj=boxshift(yj-yi,boxysize)
5325 zj=boxshift(zj-zi,boxzsize)
5329 rij=xj*xj+yj*yj+zj*zj
5333 if (rij.lt.r0ijsq) then
5334 evdwij=0.25d0*(rij-r0ijsq)**2
5342 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5348 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5349 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5360 C-----------------------------------------------------------------------------
5361 subroutine escp(evdw2,evdw2_14)
5363 C This subroutine calculates the excluded-volume interaction energy between
5364 C peptide-group centers and side chains and its gradient in virtual-bond and
5365 C side-chain vectors.
5368 include 'DIMENSIONS'
5369 include 'COMMON.GEO'
5370 include 'COMMON.VAR'
5371 include 'COMMON.LOCAL'
5372 include 'COMMON.CHAIN'
5373 include 'COMMON.DERIV'
5374 include 'COMMON.INTERACT'
5375 include 'COMMON.FFIELD'
5376 include 'COMMON.IOUNITS'
5377 include 'COMMON.CONTROL'
5378 include 'COMMON.SPLITELE'
5379 double precision ggg(3)
5380 integer i,iint,j,k,iteli,itypj,subchap,ikont
5381 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5383 double precision evdw2,evdw2_14,evdwij
5384 double precision sscale,sscagrad
5385 double precision boxshift
5388 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5389 cd print '(a)','Enter ESCP'
5390 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5394 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5395 c do i=iatscp_s,iatscp_e
5396 do ikont=g_listscp_start,g_listscp_end
5397 i=newcontlistscpi(ikont)
5398 j=newcontlistscpj(ikont)
5399 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5401 xi=0.5D0*(c(1,i)+c(1,i+1))
5402 yi=0.5D0*(c(2,i)+c(2,i+1))
5403 zi=0.5D0*(c(3,i)+c(3,i+1))
5404 call to_box(xi,yi,zi)
5405 c do iint=1,nscp_gr(i)
5407 c do j=iscpstart(i,iint),iscpend(i,iint)
5408 itypj=iabs(itype(j))
5409 if (itypj.eq.ntyp1) cycle
5410 C Uncomment following three lines for SC-p interactions
5414 C Uncomment following three lines for Ca-p interactions
5418 call to_box(xj,yj,zj)
5419 xj=boxshift(xj-xi,boxxsize)
5420 yj=boxshift(yj-yi,boxysize)
5421 zj=boxshift(zj-zi,boxzsize)
5422 c print *,xj,yj,zj,'polozenie j'
5423 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5425 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5426 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5427 c if (sss.eq.0) print *,'czasem jest OK'
5428 if (sss.le.0.0d0) cycle
5429 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5431 e1=fac*fac*aad(itypj,iteli)
5432 e2=fac*bad(itypj,iteli)
5433 if (iabs(j-i) .le. 2) then
5436 evdw2_14=evdw2_14+(e1+e2)*sss
5439 evdw2=evdw2+evdwij*sss
5440 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5441 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5442 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5445 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5447 fac=-(evdwij+e1)*rrij*sss
5448 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5452 cgrad if (j.lt.i) then
5453 cd write (iout,*) 'j<i'
5454 C Uncomment following three lines for SC-p interactions
5456 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5459 cd write (iout,*) 'j>i'
5461 cgrad ggg(k)=-ggg(k)
5462 C Uncomment following line for SC-p interactions
5463 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5464 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5468 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5470 cgrad kstart=min0(i+1,j)
5471 cgrad kend=max0(i-1,j-1)
5472 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5473 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5474 cgrad do k=kstart,kend
5476 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5480 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5481 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5483 c endif !endif for sscale cutoff
5493 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5494 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5495 gradx_scp(j,i)=expon*gradx_scp(j,i)
5498 C******************************************************************************
5502 C To save time the factor EXPON has been extracted from ALL components
5503 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5506 C******************************************************************************
5509 C--------------------------------------------------------------------------
5510 subroutine edis(ehpb)
5512 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5514 implicit real*8 (a-h,o-z)
5515 include 'DIMENSIONS'
5516 include 'COMMON.SBRIDGE'
5517 include 'COMMON.CHAIN'
5518 include 'COMMON.DERIV'
5519 include 'COMMON.VAR'
5520 include 'COMMON.INTERACT'
5521 include 'COMMON.IOUNITS'
5522 include 'COMMON.CONTROL'
5523 dimension ggg(3),ggg_peak(3,1000)
5528 c 8/21/18 AL: added explicit restraints on reference coords
5529 c write (iout,*) "restr_on_coord",restr_on_coord
5530 if (restr_on_coord) then
5534 if (itype(i).eq.ntyp1) cycle
5536 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5537 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5539 if (itype(i).ne.10) then
5541 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5542 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5545 if (energy_dec) write (iout,*)
5546 & "i",i," bfac",bfac(i)," ecoor",ecoor
5547 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5551 C write (iout,*) ,"link_end",link_end,constr_dist
5552 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5553 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5554 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5555 c & " link_end_peak",link_end_peak
5556 if (link_end.eq.0.and.link_end_peak.eq.0) return
5557 do i=link_start_peak,link_end_peak
5559 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5560 c & ipeak(1,i),ipeak(2,i)
5561 do ip=ipeak(1,i),ipeak(2,i)
5566 C iii and jjj point to the residues for which the distance is assigned.
5567 c if (ii.gt.nres) then
5574 if (ii.gt.nres) then
5579 if (jj.gt.nres) then
5584 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5585 aux=dexp(-scal_peak*aux)
5586 ehpb_peak=ehpb_peak+aux
5587 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5588 & forcon_peak(ip))*aux/dd
5590 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5592 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5593 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5594 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5596 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5597 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5598 do ip=ipeak(1,i),ipeak(2,i)
5601 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5605 C iii and jjj point to the residues for which the distance is assigned.
5606 c if (ii.gt.nres) then
5613 if (ii.gt.nres) then
5618 if (jj.gt.nres) then
5625 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5630 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5634 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5635 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5639 do i=link_start,link_end
5640 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5641 C CA-CA distance used in regularization of structure.
5644 C iii and jjj point to the residues for which the distance is assigned.
5645 if (ii.gt.nres) then
5650 if (jj.gt.nres) then
5655 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5656 c & dhpb(i),dhpb1(i),forcon(i)
5657 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5658 C distance and angle dependent SS bond potential.
5659 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5660 C & iabs(itype(jjj)).eq.1) then
5661 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5662 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5663 if (.not.dyn_ss .and. i.le.nss) then
5664 C 15/02/13 CC dynamic SSbond - additional check
5665 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5666 & iabs(itype(jjj)).eq.1) then
5667 call ssbond_ene(iii,jjj,eij)
5670 cd write (iout,*) "eij",eij
5671 cd & ' waga=',waga,' fac=',fac
5672 ! else if (ii.gt.nres .and. jj.gt.nres) then
5674 C Calculate the distance between the two points and its difference from the
5677 if (irestr_type(i).eq.11) then
5678 ehpb=ehpb+fordepth(i)!**4.0d0
5679 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5680 fac=fordepth(i)!**4.0d0
5681 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5682 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5683 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5684 & ehpb,irestr_type(i)
5685 else if (irestr_type(i).eq.10) then
5686 c AL 6//19/2018 cross-link restraints
5687 xdis = 0.5d0*(dd/forcon(i))**2
5688 expdis = dexp(-xdis)
5689 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5690 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5691 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5692 c & " wboltzd",wboltzd
5693 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5694 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5695 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5696 & *expdis/(aux*forcon(i)**2)
5697 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5698 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5699 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5700 else if (irestr_type(i).eq.2) then
5701 c Quartic restraints
5702 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5703 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5704 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5705 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5706 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5708 c Quadratic restraints
5710 C Get the force constant corresponding to this distance.
5712 C Calculate the contribution to energy.
5713 ehpb=ehpb+0.5d0*waga*rdis*rdis
5714 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5715 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5716 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5718 C Evaluate gradient.
5722 c Calculate Cartesian gradient
5724 ggg(j)=fac*(c(j,jj)-c(j,ii))
5726 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5727 C If this is a SC-SC distance, we need to calculate the contributions to the
5728 C Cartesian gradient in the SC vectors (ghpbx).
5731 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5736 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5740 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5741 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5747 C--------------------------------------------------------------------------
5748 subroutine ssbond_ene(i,j,eij)
5750 C Calculate the distance and angle dependent SS-bond potential energy
5751 C using a free-energy function derived based on RHF/6-31G** ab initio
5752 C calculations of diethyl disulfide.
5754 C A. Liwo and U. Kozlowska, 11/24/03
5756 implicit real*8 (a-h,o-z)
5757 include 'DIMENSIONS'
5758 include 'COMMON.SBRIDGE'
5759 include 'COMMON.CHAIN'
5760 include 'COMMON.DERIV'
5761 include 'COMMON.LOCAL'
5762 include 'COMMON.INTERACT'
5763 include 'COMMON.VAR'
5764 include 'COMMON.IOUNITS'
5765 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5766 itypi=iabs(itype(i))
5770 dxi=dc_norm(1,nres+i)
5771 dyi=dc_norm(2,nres+i)
5772 dzi=dc_norm(3,nres+i)
5773 c dsci_inv=dsc_inv(itypi)
5774 dsci_inv=vbld_inv(nres+i)
5775 itypj=iabs(itype(j))
5776 c dscj_inv=dsc_inv(itypj)
5777 dscj_inv=vbld_inv(nres+j)
5781 dxj=dc_norm(1,nres+j)
5782 dyj=dc_norm(2,nres+j)
5783 dzj=dc_norm(3,nres+j)
5784 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5789 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5790 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5791 om12=dxi*dxj+dyi*dyj+dzi*dzj
5793 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5794 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5800 deltat12=om2-om1+2.0d0
5802 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5803 & +akct*deltad*deltat12
5804 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5805 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5806 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5807 c & " deltat12",deltat12," eij",eij
5808 ed=2*akcm*deltad+akct*deltat12
5810 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5811 eom1=-2*akth*deltat1-pom1-om2*pom2
5812 eom2= 2*akth*deltat2+pom1-om1*pom2
5815 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5816 ghpbx(k,i)=ghpbx(k,i)-ggk
5817 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5818 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5819 ghpbx(k,j)=ghpbx(k,j)+ggk
5820 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5821 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5822 ghpbc(k,i)=ghpbc(k,i)-ggk
5823 ghpbc(k,j)=ghpbc(k,j)+ggk
5826 C Calculate the components of the gradient in DC and X
5830 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5835 C--------------------------------------------------------------------------
5836 subroutine ebond(estr)
5838 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5840 implicit real*8 (a-h,o-z)
5841 include 'DIMENSIONS'
5842 include 'COMMON.LOCAL'
5843 include 'COMMON.GEO'
5844 include 'COMMON.INTERACT'
5845 include 'COMMON.DERIV'
5846 include 'COMMON.VAR'
5847 include 'COMMON.CHAIN'
5848 include 'COMMON.IOUNITS'
5849 include 'COMMON.NAMES'
5850 include 'COMMON.FFIELD'
5851 include 'COMMON.CONTROL'
5852 include 'COMMON.SETUP'
5853 double precision u(3),ud(3)
5856 do i=ibondp_start,ibondp_end
5857 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5860 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5861 diff = vbld(i)-vbldp0
5863 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5864 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5866 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5867 c & *dc(j,i-1)/vbld(i)
5869 c if (energy_dec) write(iout,*)
5870 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5872 C Checking if it involves dummy (NH3+ or COO-) group
5873 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5874 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5875 diff = vbld(i)-vbldpDUM
5876 if (energy_dec) write(iout,*) "dum_bond",i,diff
5878 C NO vbldp0 is the equlibrium length of spring for peptide group
5879 diff = vbld(i)-vbldp0
5882 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5883 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5886 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5888 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5892 estr=0.5d0*AKP*estr+estr1
5894 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5896 do i=ibond_start,ibond_end
5898 if (iti.ne.10 .and. iti.ne.ntyp1) then
5901 diff=vbld(i+nres)-vbldsc0(1,iti)
5902 if (energy_dec) write (iout,*)
5903 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5904 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5905 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5907 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5911 diff=vbld(i+nres)-vbldsc0(j,iti)
5912 ud(j)=aksc(j,iti)*diff
5913 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5927 uprod2=uprod2*u(k)*u(k)
5931 usumsqder=usumsqder+ud(j)*uprod2
5933 estr=estr+uprod/usum
5935 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5943 C--------------------------------------------------------------------------
5944 subroutine ebend(etheta)
5946 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5947 C angles gamma and its derivatives in consecutive thetas and gammas.
5949 implicit real*8 (a-h,o-z)
5950 include 'DIMENSIONS'
5951 include 'COMMON.LOCAL'
5952 include 'COMMON.GEO'
5953 include 'COMMON.INTERACT'
5954 include 'COMMON.DERIV'
5955 include 'COMMON.VAR'
5956 include 'COMMON.CHAIN'
5957 include 'COMMON.IOUNITS'
5958 include 'COMMON.NAMES'
5959 include 'COMMON.FFIELD'
5960 include 'COMMON.CONTROL'
5961 include 'COMMON.TORCNSTR'
5962 common /calcthet/ term1,term2,termm,diffak,ratak,
5963 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5964 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5965 double precision y(2),z(2)
5967 c time11=dexp(-2*time)
5970 c write (*,'(a,i2)') 'EBEND ICG=',icg
5971 do i=ithet_start,ithet_end
5972 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5973 & .or.itype(i).eq.ntyp1) cycle
5974 C Zero the energy function and its derivative at 0 or pi.
5975 call splinthet(theta(i),0.5d0*delta,ss,ssd)
5977 ichir1=isign(1,itype(i-2))
5978 ichir2=isign(1,itype(i))
5979 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5980 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5981 if (itype(i-1).eq.10) then
5982 itype1=isign(10,itype(i-2))
5983 ichir11=isign(1,itype(i-2))
5984 ichir12=isign(1,itype(i-2))
5985 itype2=isign(10,itype(i))
5986 ichir21=isign(1,itype(i))
5987 ichir22=isign(1,itype(i))
5990 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5993 if (phii.ne.phii) phii=150.0
6003 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6006 if (phii1.ne.phii1) phii1=150.0
6018 C Calculate the "mean" value of theta from the part of the distribution
6019 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6020 C In following comments this theta will be referred to as t_c.
6021 thet_pred_mean=0.0d0
6023 athetk=athet(k,it,ichir1,ichir2)
6024 bthetk=bthet(k,it,ichir1,ichir2)
6026 athetk=athet(k,itype1,ichir11,ichir12)
6027 bthetk=bthet(k,itype2,ichir21,ichir22)
6029 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6030 c write(iout,*) 'chuj tu', y(k),z(k)
6032 dthett=thet_pred_mean*ssd
6033 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6034 C Derivatives of the "mean" values in gamma1 and gamma2.
6035 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6036 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6037 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6038 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6040 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6041 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6042 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6043 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6045 if (theta(i).gt.pi-delta) then
6046 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6048 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6049 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6050 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6052 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6054 else if (theta(i).lt.delta) then
6055 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6056 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6057 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6059 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6060 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6063 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6066 etheta=etheta+ethetai
6067 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6068 & 'ebend',i,ethetai,theta(i),itype(i)
6069 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6070 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6071 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6074 C Ufff.... We've done all this!!!
6077 C---------------------------------------------------------------------------
6078 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6080 implicit real*8 (a-h,o-z)
6081 include 'DIMENSIONS'
6082 include 'COMMON.LOCAL'
6083 include 'COMMON.IOUNITS'
6084 common /calcthet/ term1,term2,termm,diffak,ratak,
6085 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6086 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6087 C Calculate the contributions to both Gaussian lobes.
6088 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6089 C The "polynomial part" of the "standard deviation" of this part of
6090 C the distributioni.
6091 ccc write (iout,*) thetai,thet_pred_mean
6094 sig=sig*thet_pred_mean+polthet(j,it)
6096 C Derivative of the "interior part" of the "standard deviation of the"
6097 C gamma-dependent Gaussian lobe in t_c.
6098 sigtc=3*polthet(3,it)
6100 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6103 C Set the parameters of both Gaussian lobes of the distribution.
6104 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6105 fac=sig*sig+sigc0(it)
6108 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6109 sigsqtc=-4.0D0*sigcsq*sigtc
6110 c print *,i,sig,sigtc,sigsqtc
6111 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6112 sigtc=-sigtc/(fac*fac)
6113 C Following variable is sigma(t_c)**(-2)
6114 sigcsq=sigcsq*sigcsq
6116 sig0inv=1.0D0/sig0i**2
6117 delthec=thetai-thet_pred_mean
6118 delthe0=thetai-theta0i
6119 term1=-0.5D0*sigcsq*delthec*delthec
6120 term2=-0.5D0*sig0inv*delthe0*delthe0
6121 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6122 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6123 C NaNs in taking the logarithm. We extract the largest exponent which is added
6124 C to the energy (this being the log of the distribution) at the end of energy
6125 C term evaluation for this virtual-bond angle.
6126 if (term1.gt.term2) then
6128 term2=dexp(term2-termm)
6132 term1=dexp(term1-termm)
6135 C The ratio between the gamma-independent and gamma-dependent lobes of
6136 C the distribution is a Gaussian function of thet_pred_mean too.
6137 diffak=gthet(2,it)-thet_pred_mean
6138 ratak=diffak/gthet(3,it)**2
6139 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6140 C Let's differentiate it in thet_pred_mean NOW.
6142 C Now put together the distribution terms to make complete distribution.
6143 termexp=term1+ak*term2
6144 termpre=sigc+ak*sig0i
6145 C Contribution of the bending energy from this theta is just the -log of
6146 C the sum of the contributions from the two lobes and the pre-exponential
6147 C factor. Simple enough, isn't it?
6148 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6149 C write (iout,*) 'termexp',termexp,termm,termpre,i
6150 C NOW the derivatives!!!
6151 C 6/6/97 Take into account the deformation.
6152 E_theta=(delthec*sigcsq*term1
6153 & +ak*delthe0*sig0inv*term2)/termexp
6154 E_tc=((sigtc+aktc*sig0i)/termpre
6155 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6156 & aktc*term2)/termexp)
6159 c-----------------------------------------------------------------------------
6160 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6161 implicit real*8 (a-h,o-z)
6162 include 'DIMENSIONS'
6163 include 'COMMON.LOCAL'
6164 include 'COMMON.IOUNITS'
6165 common /calcthet/ term1,term2,termm,diffak,ratak,
6166 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6167 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6168 delthec=thetai-thet_pred_mean
6169 delthe0=thetai-theta0i
6170 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6171 t3 = thetai-thet_pred_mean
6175 t14 = t12+t6*sigsqtc
6177 t21 = thetai-theta0i
6183 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6184 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6185 & *(-t12*t9-ak*sig0inv*t27)
6189 C--------------------------------------------------------------------------
6190 subroutine ebend(etheta)
6192 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6193 C angles gamma and its derivatives in consecutive thetas and gammas.
6194 C ab initio-derived potentials from
6195 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6197 implicit real*8 (a-h,o-z)
6198 include 'DIMENSIONS'
6199 include 'COMMON.LOCAL'
6200 include 'COMMON.GEO'
6201 include 'COMMON.INTERACT'
6202 include 'COMMON.DERIV'
6203 include 'COMMON.VAR'
6204 include 'COMMON.CHAIN'
6205 include 'COMMON.IOUNITS'
6206 include 'COMMON.NAMES'
6207 include 'COMMON.FFIELD'
6208 include 'COMMON.CONTROL'
6209 include 'COMMON.TORCNSTR'
6210 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6211 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6212 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6213 & sinph1ph2(maxdouble,maxdouble)
6214 logical lprn /.false./, lprn1 /.false./
6216 do i=ithet_start,ithet_end
6217 c print *,i,itype(i-1),itype(i),itype(i-2)
6218 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6219 & .or.itype(i).eq.ntyp1) cycle
6220 C print *,i,theta(i)
6221 if (iabs(itype(i+1)).eq.20) iblock=2
6222 if (iabs(itype(i+1)).ne.20) iblock=1
6226 theti2=0.5d0*theta(i)
6227 ityp2=ithetyp((itype(i-1)))
6229 coskt(k)=dcos(k*theti2)
6230 sinkt(k)=dsin(k*theti2)
6233 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6236 if (phii.ne.phii) phii=150.0
6240 ityp1=ithetyp((itype(i-2)))
6241 C propagation of chirality for glycine type
6243 cosph1(k)=dcos(k*phii)
6244 sinph1(k)=dsin(k*phii)
6249 ityp1=ithetyp((itype(i-2)))
6254 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6257 if (phii1.ne.phii1) phii1=150.0
6262 ityp3=ithetyp((itype(i)))
6264 cosph2(k)=dcos(k*phii1)
6265 sinph2(k)=dsin(k*phii1)
6269 ityp3=ithetyp((itype(i)))
6275 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6278 ccl=cosph1(l)*cosph2(k-l)
6279 ssl=sinph1(l)*sinph2(k-l)
6280 scl=sinph1(l)*cosph2(k-l)
6281 csl=cosph1(l)*sinph2(k-l)
6282 cosph1ph2(l,k)=ccl-ssl
6283 cosph1ph2(k,l)=ccl+ssl
6284 sinph1ph2(l,k)=scl+csl
6285 sinph1ph2(k,l)=scl-csl
6289 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6290 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6291 write (iout,*) "coskt and sinkt"
6293 write (iout,*) k,coskt(k),sinkt(k)
6297 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6298 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6301 & write (iout,*) "k",k,"
6302 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6303 & " ethetai",ethetai
6306 write (iout,*) "cosph and sinph"
6308 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6310 write (iout,*) "cosph1ph2 and sinph2ph2"
6313 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6314 & sinph1ph2(l,k),sinph1ph2(k,l)
6317 write(iout,*) "ethetai",ethetai
6322 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6323 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6324 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6325 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6326 ethetai=ethetai+sinkt(m)*aux
6327 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6328 dephii=dephii+k*sinkt(m)*(
6329 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6330 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6331 dephii1=dephii1+k*sinkt(m)*(
6332 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6333 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6335 & write (iout,*) "m",m," k",k," bbthet",
6336 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6337 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6338 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6339 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6340 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6343 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6344 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6345 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6346 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6348 & write(iout,*) "ethetai",ethetai
6349 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6353 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6354 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6355 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6356 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6357 ethetai=ethetai+sinkt(m)*aux
6358 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6359 dephii=dephii+l*sinkt(m)*(
6360 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6361 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6362 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6363 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6364 dephii1=dephii1+(k-l)*sinkt(m)*(
6365 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6366 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6367 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6368 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6370 write (iout,*) "m",m," k",k," l",l," ffthet",
6371 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6372 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6373 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6374 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6375 & " ethetai",ethetai
6376 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6377 & cosph1ph2(k,l)*sinkt(m),
6378 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6387 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6388 & i,theta(i)*rad2deg,phii*rad2deg,
6389 & phii1*rad2deg,ethetai
6391 etheta=etheta+ethetai
6392 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6393 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6394 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6401 c-----------------------------------------------------------------------------
6402 subroutine esc(escloc)
6403 C Calculate the local energy of a side chain and its derivatives in the
6404 C corresponding virtual-bond valence angles THETA and the spherical angles
6406 implicit real*8 (a-h,o-z)
6407 include 'DIMENSIONS'
6408 include 'COMMON.GEO'
6409 include 'COMMON.LOCAL'
6410 include 'COMMON.VAR'
6411 include 'COMMON.INTERACT'
6412 include 'COMMON.DERIV'
6413 include 'COMMON.CHAIN'
6414 include 'COMMON.IOUNITS'
6415 include 'COMMON.NAMES'
6416 include 'COMMON.FFIELD'
6417 include 'COMMON.CONTROL'
6418 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6419 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6420 common /sccalc/ time11,time12,time112,theti,it,nlobit
6423 c write (iout,'(a)') 'ESC'
6424 do i=loc_start,loc_end
6426 if (it.eq.ntyp1) cycle
6427 if (it.eq.10) goto 1
6428 nlobit=nlob(iabs(it))
6429 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6430 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6431 theti=theta(i+1)-pipol
6436 if (x(2).gt.pi-delta) then
6440 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6442 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6443 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6445 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6446 & ddersc0(1),dersc(1))
6447 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6448 & ddersc0(3),dersc(3))
6450 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6452 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6453 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6454 & dersc0(2),esclocbi,dersc02)
6455 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6457 call splinthet(x(2),0.5d0*delta,ss,ssd)
6462 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6464 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6465 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6467 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6469 c write (iout,*) escloci
6470 else if (x(2).lt.delta) then
6474 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6476 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6477 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6479 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6480 & ddersc0(1),dersc(1))
6481 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6482 & ddersc0(3),dersc(3))
6484 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6486 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6487 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6488 & dersc0(2),esclocbi,dersc02)
6489 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6494 call splinthet(x(2),0.5d0*delta,ss,ssd)
6496 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6498 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6499 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6501 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6502 c write (iout,*) escloci
6504 call enesc(x,escloci,dersc,ddummy,.false.)
6507 escloc=escloc+escloci
6508 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6509 & 'escloc',i,escloci
6510 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6512 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6514 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6515 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6520 C---------------------------------------------------------------------------
6521 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6522 implicit real*8 (a-h,o-z)
6523 include 'DIMENSIONS'
6524 include 'COMMON.GEO'
6525 include 'COMMON.LOCAL'
6526 include 'COMMON.IOUNITS'
6527 common /sccalc/ time11,time12,time112,theti,it,nlobit
6528 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6529 double precision contr(maxlob,-1:1)
6531 c write (iout,*) 'it=',it,' nlobit=',nlobit
6535 if (mixed) ddersc(j)=0.0d0
6539 C Because of periodicity of the dependence of the SC energy in omega we have
6540 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6541 C To avoid underflows, first compute & store the exponents.
6549 z(k)=x(k)-censc(k,j,it)
6554 Axk=Axk+gaussc(l,k,j,it)*z(l)
6560 expfac=expfac+Ax(k,j,iii)*z(k)
6568 C As in the case of ebend, we want to avoid underflows in exponentiation and
6569 C subsequent NaNs and INFs in energy calculation.
6570 C Find the largest exponent
6574 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6578 cd print *,'it=',it,' emin=',emin
6580 C Compute the contribution to SC energy and derivatives
6585 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6586 if(adexp.ne.adexp) adexp=1.0
6589 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6591 cd print *,'j=',j,' expfac=',expfac
6592 escloc_i=escloc_i+expfac
6594 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6598 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6599 & +gaussc(k,2,j,it))*expfac
6606 dersc(1)=dersc(1)/cos(theti)**2
6607 ddersc(1)=ddersc(1)/cos(theti)**2
6610 escloci=-(dlog(escloc_i)-emin)
6612 dersc(j)=dersc(j)/escloc_i
6616 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6621 C------------------------------------------------------------------------------
6622 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6623 implicit real*8 (a-h,o-z)
6624 include 'DIMENSIONS'
6625 include 'COMMON.GEO'
6626 include 'COMMON.LOCAL'
6627 include 'COMMON.IOUNITS'
6628 common /sccalc/ time11,time12,time112,theti,it,nlobit
6629 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6630 double precision contr(maxlob)
6641 z(k)=x(k)-censc(k,j,it)
6647 Axk=Axk+gaussc(l,k,j,it)*z(l)
6653 expfac=expfac+Ax(k,j)*z(k)
6658 C As in the case of ebend, we want to avoid underflows in exponentiation and
6659 C subsequent NaNs and INFs in energy calculation.
6660 C Find the largest exponent
6663 if (emin.gt.contr(j)) emin=contr(j)
6667 C Compute the contribution to SC energy and derivatives
6671 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6672 escloc_i=escloc_i+expfac
6674 dersc(k)=dersc(k)+Ax(k,j)*expfac
6676 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6677 & +gaussc(1,2,j,it))*expfac
6681 dersc(1)=dersc(1)/cos(theti)**2
6682 dersc12=dersc12/cos(theti)**2
6683 escloci=-(dlog(escloc_i)-emin)
6685 dersc(j)=dersc(j)/escloc_i
6687 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6691 c----------------------------------------------------------------------------------
6692 subroutine esc(escloc)
6693 C Calculate the local energy of a side chain and its derivatives in the
6694 C corresponding virtual-bond valence angles THETA and the spherical angles
6695 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6696 C added by Urszula Kozlowska. 07/11/2007
6698 implicit real*8 (a-h,o-z)
6699 include 'DIMENSIONS'
6700 include 'COMMON.GEO'
6701 include 'COMMON.LOCAL'
6702 include 'COMMON.VAR'
6703 include 'COMMON.SCROT'
6704 include 'COMMON.INTERACT'
6705 include 'COMMON.DERIV'
6706 include 'COMMON.CHAIN'
6707 include 'COMMON.IOUNITS'
6708 include 'COMMON.NAMES'
6709 include 'COMMON.FFIELD'
6710 include 'COMMON.CONTROL'
6711 include 'COMMON.VECTORS'
6712 double precision x_prime(3),y_prime(3),z_prime(3)
6713 & , sumene,dsc_i,dp2_i,x(65),
6714 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6715 & de_dxx,de_dyy,de_dzz,de_dt
6716 double precision s1_t,s1_6_t,s2_t,s2_6_t
6718 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6719 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6720 & dt_dCi(3),dt_dCi1(3)
6721 common /sccalc/ time11,time12,time112,theti,it,nlobit
6724 do i=loc_start,loc_end
6725 if (itype(i).eq.ntyp1) cycle
6726 costtab(i+1) =dcos(theta(i+1))
6727 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6728 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6729 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6730 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6731 cosfac=dsqrt(cosfac2)
6732 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6733 sinfac=dsqrt(sinfac2)
6735 if (it.eq.10) goto 1
6737 C Compute the axes of tghe local cartesian coordinates system; store in
6738 c x_prime, y_prime and z_prime
6745 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6746 C & dc_norm(3,i+nres)
6748 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6749 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6752 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6755 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6756 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6757 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6758 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6759 c & " xy",scalar(x_prime(1),y_prime(1)),
6760 c & " xz",scalar(x_prime(1),z_prime(1)),
6761 c & " yy",scalar(y_prime(1),y_prime(1)),
6762 c & " yz",scalar(y_prime(1),z_prime(1)),
6763 c & " zz",scalar(z_prime(1),z_prime(1))
6765 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6766 C to local coordinate system. Store in xx, yy, zz.
6772 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6773 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6774 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6781 C Compute the energy of the ith side cbain
6783 c write (2,*) "xx",xx," yy",yy," zz",zz
6786 x(j) = sc_parmin(j,it)
6789 Cc diagnostics - remove later
6791 yy1 = dsin(alph(2))*dcos(omeg(2))
6792 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6793 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6794 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6796 C," --- ", xx_w,yy_w,zz_w
6799 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6800 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6802 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6803 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6805 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6806 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6807 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6808 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6809 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6811 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6812 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6813 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6814 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6815 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6817 dsc_i = 0.743d0+x(61)
6819 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6820 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6821 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6822 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6823 s1=(1+x(63))/(0.1d0 + dscp1)
6824 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6825 s2=(1+x(65))/(0.1d0 + dscp2)
6826 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6827 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6828 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6829 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6831 c & dscp1,dscp2,sumene
6832 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6833 escloc = escloc + sumene
6834 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6835 & " escloc",sumene,escloc,it,itype(i)
6840 C This section to check the numerical derivatives of the energy of ith side
6841 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6842 C #define DEBUG in the code to turn it on.
6844 write (2,*) "sumene =",sumene
6848 write (2,*) xx,yy,zz
6849 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6850 de_dxx_num=(sumenep-sumene)/aincr
6852 write (2,*) "xx+ sumene from enesc=",sumenep
6855 write (2,*) xx,yy,zz
6856 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6857 de_dyy_num=(sumenep-sumene)/aincr
6859 write (2,*) "yy+ sumene from enesc=",sumenep
6862 write (2,*) xx,yy,zz
6863 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6864 de_dzz_num=(sumenep-sumene)/aincr
6866 write (2,*) "zz+ sumene from enesc=",sumenep
6867 costsave=cost2tab(i+1)
6868 sintsave=sint2tab(i+1)
6869 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6870 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6871 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6872 de_dt_num=(sumenep-sumene)/aincr
6873 write (2,*) " t+ sumene from enesc=",sumenep
6874 cost2tab(i+1)=costsave
6875 sint2tab(i+1)=sintsave
6876 C End of diagnostics section.
6879 C Compute the gradient of esc
6881 c zz=zz*dsign(1.0,dfloat(itype(i)))
6882 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6883 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6884 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6885 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6886 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6887 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6888 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6889 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6890 pom1=(sumene3*sint2tab(i+1)+sumene1)
6891 & *(pom_s1/dscp1+pom_s16*dscp1**4)
6892 pom2=(sumene4*cost2tab(i+1)+sumene2)
6893 & *(pom_s2/dscp2+pom_s26*dscp2**4)
6894 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6895 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6896 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6898 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6899 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6900 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6902 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6903 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6904 & +(pom1+pom2)*pom_dx
6906 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6909 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6910 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6911 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6913 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6914 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6915 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6916 & +x(59)*zz**2 +x(60)*xx*zz
6917 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6918 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6919 & +(pom1-pom2)*pom_dy
6921 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6924 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6925 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6926 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6927 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
6928 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
6929 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6930 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6931 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
6933 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6936 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6937 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6938 & +pom1*pom_dt1+pom2*pom_dt2
6940 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6945 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6946 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6947 cosfac2xx=cosfac2*xx
6948 sinfac2yy=sinfac2*yy
6950 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6952 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6954 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6955 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6956 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6957 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6958 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6959 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6960 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6961 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6962 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6963 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6967 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6968 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6969 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6970 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6973 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6974 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6975 dZZ_XYZ(k)=vbld_inv(i+nres)*
6976 & (z_prime(k)-zz*dC_norm(k,i+nres))
6978 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6979 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6983 dXX_Ctab(k,i)=dXX_Ci(k)
6984 dXX_C1tab(k,i)=dXX_Ci1(k)
6985 dYY_Ctab(k,i)=dYY_Ci(k)
6986 dYY_C1tab(k,i)=dYY_Ci1(k)
6987 dZZ_Ctab(k,i)=dZZ_Ci(k)
6988 dZZ_C1tab(k,i)=dZZ_Ci1(k)
6989 dXX_XYZtab(k,i)=dXX_XYZ(k)
6990 dYY_XYZtab(k,i)=dYY_XYZ(k)
6991 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6995 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6996 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6997 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6998 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
6999 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7001 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7002 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7003 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7004 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7005 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7006 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7007 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7008 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7010 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7011 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7013 C to check gradient call subroutine check_grad
7019 c------------------------------------------------------------------------------
7020 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7022 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7023 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7024 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7025 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7027 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7028 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7030 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7031 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7032 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7033 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7034 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7036 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7037 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7038 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7039 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7040 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7042 dsc_i = 0.743d0+x(61)
7044 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7045 & *(xx*cost2+yy*sint2))
7046 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7047 & *(xx*cost2-yy*sint2))
7048 s1=(1+x(63))/(0.1d0 + dscp1)
7049 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7050 s2=(1+x(65))/(0.1d0 + dscp2)
7051 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7052 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7053 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7058 c------------------------------------------------------------------------------
7059 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7061 C This procedure calculates two-body contact function g(rij) and its derivative:
7064 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7067 C where x=(rij-r0ij)/delta
7069 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7072 double precision rij,r0ij,eps0ij,fcont,fprimcont
7073 double precision x,x2,x4,delta
7077 if (x.lt.-1.0D0) then
7080 else if (x.le.1.0D0) then
7083 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7084 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7091 c------------------------------------------------------------------------------
7092 subroutine splinthet(theti,delta,ss,ssder)
7093 implicit real*8 (a-h,o-z)
7094 include 'DIMENSIONS'
7095 include 'COMMON.VAR'
7096 include 'COMMON.GEO'
7099 if (theti.gt.pipol) then
7100 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7102 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7107 c------------------------------------------------------------------------------
7108 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7110 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7111 double precision ksi,ksi2,ksi3,a1,a2,a3
7112 a1=fprim0*delta/(f1-f0)
7118 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7119 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7122 c------------------------------------------------------------------------------
7123 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7125 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7126 double precision ksi,ksi2,ksi3,a1,a2,a3
7131 a2=3*(f1x-f0x)-2*fprim0x*delta
7132 a3=fprim0x*delta-2*(f1x-f0x)
7133 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7136 C-----------------------------------------------------------------------------
7138 C-----------------------------------------------------------------------------
7139 subroutine etor(etors)
7140 implicit real*8 (a-h,o-z)
7141 include 'DIMENSIONS'
7142 include 'COMMON.VAR'
7143 include 'COMMON.GEO'
7144 include 'COMMON.LOCAL'
7145 include 'COMMON.TORSION'
7146 include 'COMMON.INTERACT'
7147 include 'COMMON.DERIV'
7148 include 'COMMON.CHAIN'
7149 include 'COMMON.NAMES'
7150 include 'COMMON.IOUNITS'
7151 include 'COMMON.FFIELD'
7152 include 'COMMON.TORCNSTR'
7153 include 'COMMON.CONTROL'
7155 C Set lprn=.true. for debugging
7159 do i=iphi_start,iphi_end
7161 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7162 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7163 itori=itortyp(itype(i-2))
7164 itori1=itortyp(itype(i-1))
7167 C Proline-Proline pair is a special case...
7168 if (itori.eq.3 .and. itori1.eq.3) then
7169 if (phii.gt.-dwapi3) then
7171 fac=1.0D0/(1.0D0-cosphi)
7172 etorsi=v1(1,3,3)*fac
7173 etorsi=etorsi+etorsi
7174 etors=etors+etorsi-v1(1,3,3)
7175 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7176 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7179 v1ij=v1(j+1,itori,itori1)
7180 v2ij=v2(j+1,itori,itori1)
7183 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7184 if (energy_dec) etors_ii=etors_ii+
7185 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7186 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7190 v1ij=v1(j,itori,itori1)
7191 v2ij=v2(j,itori,itori1)
7194 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7195 if (energy_dec) etors_ii=etors_ii+
7196 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7197 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7200 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7203 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7204 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7205 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7206 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7207 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7211 c------------------------------------------------------------------------------
7212 subroutine etor_d(etors_d)
7216 c----------------------------------------------------------------------------
7217 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7218 subroutine e_modeller(ehomology_constr)
7219 ehomology_constr=0.0d0
7220 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7223 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7225 c------------------------------------------------------------------------------
7226 subroutine etor_d(etors_d)
7230 c----------------------------------------------------------------------------
7232 subroutine etor(etors)
7233 implicit real*8 (a-h,o-z)
7234 include 'DIMENSIONS'
7235 include 'COMMON.VAR'
7236 include 'COMMON.GEO'
7237 include 'COMMON.LOCAL'
7238 include 'COMMON.TORSION'
7239 include 'COMMON.INTERACT'
7240 include 'COMMON.DERIV'
7241 include 'COMMON.CHAIN'
7242 include 'COMMON.NAMES'
7243 include 'COMMON.IOUNITS'
7244 include 'COMMON.FFIELD'
7245 include 'COMMON.TORCNSTR'
7246 include 'COMMON.CONTROL'
7248 C Set lprn=.true. for debugging
7252 do i=iphi_start,iphi_end
7253 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7254 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7255 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7256 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7257 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7258 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7259 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7260 C For introducing the NH3+ and COO- group please check the etor_d for reference
7263 if (iabs(itype(i)).eq.20) then
7268 itori=itortyp(itype(i-2))
7269 itori1=itortyp(itype(i-1))
7272 C Regular cosine and sine terms
7273 do j=1,nterm(itori,itori1,iblock)
7274 v1ij=v1(j,itori,itori1,iblock)
7275 v2ij=v2(j,itori,itori1,iblock)
7278 etors=etors+v1ij*cosphi+v2ij*sinphi
7279 if (energy_dec) etors_ii=etors_ii+
7280 & v1ij*cosphi+v2ij*sinphi
7281 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7285 C E = SUM ----------------------------------- - v1
7286 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7288 cosphi=dcos(0.5d0*phii)
7289 sinphi=dsin(0.5d0*phii)
7290 do j=1,nlor(itori,itori1,iblock)
7291 vl1ij=vlor1(j,itori,itori1)
7292 vl2ij=vlor2(j,itori,itori1)
7293 vl3ij=vlor3(j,itori,itori1)
7294 pom=vl2ij*cosphi+vl3ij*sinphi
7295 pom1=1.0d0/(pom*pom+1.0d0)
7296 etors=etors+vl1ij*pom1
7297 if (energy_dec) etors_ii=etors_ii+
7300 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7302 C Subtract the constant term
7303 etors=etors-v0(itori,itori1,iblock)
7304 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7305 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7307 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7308 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7309 & (v1(j,itori,itori1,iblock),j=1,6),
7310 & (v2(j,itori,itori1,iblock),j=1,6)
7311 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7312 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7316 c----------------------------------------------------------------------------
7317 subroutine etor_d(etors_d)
7318 C 6/23/01 Compute double torsional energy
7319 implicit real*8 (a-h,o-z)
7320 include 'DIMENSIONS'
7321 include 'COMMON.VAR'
7322 include 'COMMON.GEO'
7323 include 'COMMON.LOCAL'
7324 include 'COMMON.TORSION'
7325 include 'COMMON.INTERACT'
7326 include 'COMMON.DERIV'
7327 include 'COMMON.CHAIN'
7328 include 'COMMON.NAMES'
7329 include 'COMMON.IOUNITS'
7330 include 'COMMON.FFIELD'
7331 include 'COMMON.TORCNSTR'
7333 C Set lprn=.true. for debugging
7337 c write(iout,*) "a tu??"
7338 do i=iphid_start,iphid_end
7339 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7340 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7341 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7342 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7343 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7344 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7345 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7346 & (itype(i+1).eq.ntyp1)) cycle
7347 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7348 itori=itortyp(itype(i-2))
7349 itori1=itortyp(itype(i-1))
7350 itori2=itortyp(itype(i))
7356 if (iabs(itype(i+1)).eq.20) iblock=2
7357 C Iblock=2 Proline type
7358 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7359 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7360 C if (itype(i+1).eq.ntyp1) iblock=3
7361 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7362 C IS or IS NOT need for this
7363 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7364 C is (itype(i-3).eq.ntyp1) ntblock=2
7365 C ntblock is N-terminal blocking group
7367 C Regular cosine and sine terms
7368 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7369 C Example of changes for NH3+ blocking group
7370 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7371 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7372 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7373 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7374 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7375 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7376 cosphi1=dcos(j*phii)
7377 sinphi1=dsin(j*phii)
7378 cosphi2=dcos(j*phii1)
7379 sinphi2=dsin(j*phii1)
7380 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7381 & v2cij*cosphi2+v2sij*sinphi2
7382 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7383 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7385 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7387 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7388 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7389 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7390 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7391 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7392 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7393 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7394 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7395 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7396 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7397 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7398 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7399 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7400 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7403 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7404 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7409 C----------------------------------------------------------------------------------
7410 C The rigorous attempt to derive energy function
7411 subroutine etor_kcc(etors)
7412 implicit real*8 (a-h,o-z)
7413 include 'DIMENSIONS'
7414 include 'COMMON.VAR'
7415 include 'COMMON.GEO'
7416 include 'COMMON.LOCAL'
7417 include 'COMMON.TORSION'
7418 include 'COMMON.INTERACT'
7419 include 'COMMON.DERIV'
7420 include 'COMMON.CHAIN'
7421 include 'COMMON.NAMES'
7422 include 'COMMON.IOUNITS'
7423 include 'COMMON.FFIELD'
7424 include 'COMMON.TORCNSTR'
7425 include 'COMMON.CONTROL'
7426 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7428 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7429 C Set lprn=.true. for debugging
7432 C print *,"wchodze kcc"
7433 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7435 do i=iphi_start,iphi_end
7436 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7437 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7438 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7439 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7440 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7441 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7442 itori=itortyp(itype(i-2))
7443 itori1=itortyp(itype(i-1))
7448 C to avoid multiple devision by 2
7449 c theti22=0.5d0*theta(i)
7450 C theta 12 is the theta_1 /2
7451 C theta 22 is theta_2 /2
7452 c theti12=0.5d0*theta(i-1)
7453 C and appropriate sinus function
7454 sinthet1=dsin(theta(i-1))
7455 sinthet2=dsin(theta(i))
7456 costhet1=dcos(theta(i-1))
7457 costhet2=dcos(theta(i))
7458 C to speed up lets store its mutliplication
7459 sint1t2=sinthet2*sinthet1
7461 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7462 C +d_n*sin(n*gamma)) *
7463 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7464 C we have two sum 1) Non-Chebyshev which is with n and gamma
7465 nval=nterm_kcc_Tb(itori,itori1)
7471 c1(j)=c1(j-1)*costhet1
7472 c2(j)=c2(j-1)*costhet2
7475 do j=1,nterm_kcc(itori,itori1)
7479 sint1t2n=sint1t2n*sint1t2
7485 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7486 gradvalct1=gradvalct1+
7487 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7488 gradvalct2=gradvalct2+
7489 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7492 gradvalct1=-gradvalct1*sinthet1
7493 gradvalct2=-gradvalct2*sinthet2
7499 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7500 gradvalst1=gradvalst1+
7501 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7502 gradvalst2=gradvalst2+
7503 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7506 gradvalst1=-gradvalst1*sinthet1
7507 gradvalst2=-gradvalst2*sinthet2
7508 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7509 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7510 C glocig is the gradient local i site in gamma
7511 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7512 C now gradient over theta_1
7513 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7514 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7515 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7516 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7519 C derivative over gamma
7520 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7521 C derivative over theta1
7522 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7523 C now derivative over theta2
7524 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7526 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7527 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7528 write (iout,*) "c1",(c1(k),k=0,nval),
7529 & " c2",(c2(k),k=0,nval)
7534 c---------------------------------------------------------------------------------------------
7535 subroutine etor_constr(edihcnstr)
7536 implicit real*8 (a-h,o-z)
7537 include 'DIMENSIONS'
7538 include 'COMMON.VAR'
7539 include 'COMMON.GEO'
7540 include 'COMMON.LOCAL'
7541 include 'COMMON.TORSION'
7542 include 'COMMON.INTERACT'
7543 include 'COMMON.DERIV'
7544 include 'COMMON.CHAIN'
7545 include 'COMMON.NAMES'
7546 include 'COMMON.IOUNITS'
7547 include 'COMMON.FFIELD'
7548 include 'COMMON.TORCNSTR'
7549 include 'COMMON.BOUNDS'
7550 include 'COMMON.CONTROL'
7551 ! 6/20/98 - dihedral angle constraints
7553 c do i=1,ndih_constr
7554 if (raw_psipred) then
7555 do i=idihconstr_start,idihconstr_end
7556 itori=idih_constr(i)
7558 gaudih_i=vpsipred(1,i)
7562 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7563 dexpcos_i=dexp(-cos_i*cos_i)
7564 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7565 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7566 & *cos_i*dexpcos_i/s**2
7568 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7569 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7571 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7572 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7573 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7574 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7575 & -wdihc*dlog(gaudih_i)
7579 do i=idihconstr_start,idihconstr_end
7580 itori=idih_constr(i)
7582 difi=pinorm(phii-phi0(i))
7583 if (difi.gt.drange(i)) then
7585 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7586 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7587 else if (difi.lt.-drange(i)) then
7589 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7590 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7600 c----------------------------------------------------------------------------
7601 c MODELLER restraint function
7602 subroutine e_modeller(ehomology_constr)
7604 include 'DIMENSIONS'
7606 double precision ehomology_constr
7607 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7608 integer katy, odleglosci, test7
7609 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7611 real*8 distance(max_template),distancek(max_template),
7612 & min_odl,godl(max_template),dih_diff(max_template)
7615 c FP - 30/10/2014 Temporary specifications for homology restraints
7617 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7619 double precision, dimension (maxres) :: guscdiff,usc_diff
7620 double precision, dimension (max_template) ::
7621 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7623 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7624 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7625 & betai,sum_sgodl,dij
7626 double precision dist,pinorm
7628 include 'COMMON.SBRIDGE'
7629 include 'COMMON.CHAIN'
7630 include 'COMMON.GEO'
7631 include 'COMMON.DERIV'
7632 include 'COMMON.LOCAL'
7633 include 'COMMON.INTERACT'
7634 include 'COMMON.VAR'
7635 include 'COMMON.IOUNITS'
7636 c include 'COMMON.MD'
7637 include 'COMMON.CONTROL'
7638 include 'COMMON.HOMOLOGY'
7639 include 'COMMON.QRESTR'
7641 c From subroutine Econstr_back
7643 include 'COMMON.NAMES'
7644 include 'COMMON.TIME1'
7649 distancek(i)=9999999.9
7655 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7657 C AL 5/2/14 - Introduce list of restraints
7658 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7660 write(iout,*) "------- dist restrs start -------"
7662 do ii = link_start_homo,link_end_homo
7666 c write (iout,*) "dij(",i,j,") =",dij
7668 do k=1,constr_homology
7669 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7670 if(.not.l_homo(k,ii)) then
7674 distance(k)=odl(k,ii)-dij
7675 c write (iout,*) "distance(",k,") =",distance(k)
7677 c For Gaussian-type Urestr
7679 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7680 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7681 c write (iout,*) "distancek(",k,") =",distancek(k)
7682 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7684 c For Lorentzian-type Urestr
7686 if (waga_dist.lt.0.0d0) then
7687 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7688 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7689 & (distance(k)**2+sigma_odlir(k,ii)**2))
7693 c min_odl=minval(distancek)
7694 do kk=1,constr_homology
7695 if(l_homo(kk,ii)) then
7696 min_odl=distancek(kk)
7700 do kk=1,constr_homology
7701 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7702 & min_odl=distancek(kk)
7705 c write (iout,* )"min_odl",min_odl
7707 write (iout,*) "ij dij",i,j,dij
7708 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7709 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7710 write (iout,* )"min_odl",min_odl
7715 if (waga_dist.ge.0.0d0) then
7721 do k=1,constr_homology
7722 c Nie wiem po co to liczycie jeszcze raz!
7723 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7724 c & (2*(sigma_odl(i,j,k))**2))
7725 if(.not.l_homo(k,ii)) cycle
7726 if (waga_dist.ge.0.0d0) then
7728 c For Gaussian-type Urestr
7730 godl(k)=dexp(-distancek(k)+min_odl)
7731 odleg2=odleg2+godl(k)
7733 c For Lorentzian-type Urestr
7736 odleg2=odleg2+distancek(k)
7739 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7740 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7741 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7742 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7745 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7746 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7748 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7749 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7751 if (waga_dist.ge.0.0d0) then
7753 c For Gaussian-type Urestr
7755 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7757 c For Lorentzian-type Urestr
7760 odleg=odleg+odleg2/constr_homology
7763 c write (iout,*) "odleg",odleg ! sum of -ln-s
7766 c For Gaussian-type Urestr
7768 if (waga_dist.ge.0.0d0) sum_godl=odleg2
7770 do k=1,constr_homology
7771 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7772 c & *waga_dist)+min_odl
7773 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7775 if(.not.l_homo(k,ii)) cycle
7776 if (waga_dist.ge.0.0d0) then
7777 c For Gaussian-type Urestr
7779 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7781 c For Lorentzian-type Urestr
7784 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7785 & sigma_odlir(k,ii)**2)**2)
7787 sum_sgodl=sum_sgodl+sgodl
7789 c sgodl2=sgodl2+sgodl
7790 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7791 c write(iout,*) "constr_homology=",constr_homology
7792 c write(iout,*) i, j, k, "TEST K"
7794 if (waga_dist.ge.0.0d0) then
7796 c For Gaussian-type Urestr
7798 grad_odl3=waga_homology(iset)*waga_dist
7799 & *sum_sgodl/(sum_godl*dij)
7801 c For Lorentzian-type Urestr
7804 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7805 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7806 grad_odl3=-waga_homology(iset)*waga_dist*
7807 & sum_sgodl/(constr_homology*dij)
7810 c grad_odl3=sum_sgodl/(sum_godl*dij)
7813 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7814 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7815 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7817 ccc write(iout,*) godl, sgodl, grad_odl3
7819 c grad_odl=grad_odl+grad_odl3
7822 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7823 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7824 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7825 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7826 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7827 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7828 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7829 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7830 c if (i.eq.25.and.j.eq.27) then
7831 c write(iout,*) "jik",jik,"i",i,"j",j
7832 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7833 c write(iout,*) "grad_odl3",grad_odl3
7834 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7835 c write(iout,*) "ggodl",ggodl
7836 c write(iout,*) "ghpbc(",jik,i,")",
7837 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
7841 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7842 ccc & dLOG(odleg2),"-odleg=", -odleg
7844 enddo ! ii-loop for dist
7846 write(iout,*) "------- dist restrs end -------"
7847 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7848 c & waga_d.eq.1.0d0) call sum_gradient
7850 c Pseudo-energy and gradient from dihedral-angle restraints from
7851 c homology templates
7852 c write (iout,*) "End of distance loop"
7855 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7857 write(iout,*) "------- dih restrs start -------"
7858 do i=idihconstr_start_homo,idihconstr_end_homo
7859 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7862 do i=idihconstr_start_homo,idihconstr_end_homo
7864 c betai=beta(i,i+1,i+2,i+3)
7866 c write (iout,*) "betai =",betai
7867 do k=1,constr_homology
7868 dih_diff(k)=pinorm(dih(k,i)-betai)
7869 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7870 cd & ,sigma_dih(k,i)
7871 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7872 c & -(6.28318-dih_diff(i,k))
7873 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7874 c & 6.28318+dih_diff(i,k)
7876 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7878 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7880 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7883 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7886 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7887 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7889 write (iout,*) "i",i," betai",betai," kat2",kat2
7890 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7892 if (kat2.le.1.0d-14) cycle
7893 kat=kat-dLOG(kat2/constr_homology)
7894 c write (iout,*) "kat",kat ! sum of -ln-s
7896 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7897 ccc & dLOG(kat2), "-kat=", -kat
7899 c ----------------------------------------------------------------------
7901 c ----------------------------------------------------------------------
7905 do k=1,constr_homology
7907 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
7909 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
7911 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7912 sum_sgdih=sum_sgdih+sgdih
7914 c grad_dih3=sum_sgdih/sum_gdih
7915 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7917 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7918 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7919 ccc & gloc(nphi+i-3,icg)
7920 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7922 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7924 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7925 ccc & gloc(nphi+i-3,icg)
7927 enddo ! i-loop for dih
7929 write(iout,*) "------- dih restrs end -------"
7932 c Pseudo-energy and gradient for theta angle restraints from
7933 c homology templates
7934 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7938 c For constr_homology reference structures (FP)
7940 c Uconst_back_tot=0.0d0
7943 c Econstr_back legacy
7945 c do i=ithet_start,ithet_end
7948 c do i=loc_start,loc_end
7951 duscdiffx(j,i)=0.0d0
7956 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7957 c write (iout,*) "waga_theta",waga_theta
7958 if (waga_theta.gt.0.0d0) then
7960 write (iout,*) "usampl",usampl
7961 write(iout,*) "------- theta restrs start -------"
7962 c do i=ithet_start,ithet_end
7963 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7966 c write (iout,*) "maxres",maxres,"nres",nres
7968 do i=ithet_start,ithet_end
7971 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7973 c Deviation of theta angles wrt constr_homology ref structures
7975 utheta_i=0.0d0 ! argument of Gaussian for single k
7976 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7977 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7978 c over residues in a fragment
7979 c write (iout,*) "theta(",i,")=",theta(i)
7980 do k=1,constr_homology
7982 c dtheta_i=theta(j)-thetaref(j,iref)
7983 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7984 theta_diff(k)=thetatpl(k,i)-theta(i)
7985 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7986 cd & ,sigma_theta(k,i)
7989 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7990 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7991 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7992 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
7993 c Gradient for single Gaussian restraint in subr Econstr_back
7994 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7997 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7998 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8001 c Gradient for multiple Gaussian restraint
8002 sum_gtheta=gutheta_i
8004 do k=1,constr_homology
8005 c New generalized expr for multiple Gaussian from Econstr_back
8006 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8008 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8009 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8011 c Final value of gradient using same var as in Econstr_back
8012 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8013 & +sum_sgtheta/sum_gtheta*waga_theta
8014 & *waga_homology(iset)
8015 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8016 c & *waga_homology(iset)
8017 c dutheta(i)=sum_sgtheta/sum_gtheta
8019 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8020 Eval=Eval-dLOG(gutheta_i/constr_homology)
8021 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8022 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8023 c Uconst_back=Uconst_back+utheta(i)
8024 enddo ! (i-loop for theta)
8026 write(iout,*) "------- theta restrs end -------"
8030 c Deviation of local SC geometry
8032 c Separation of two i-loops (instructed by AL - 11/3/2014)
8034 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8035 c write (iout,*) "waga_d",waga_d
8038 write(iout,*) "------- SC restrs start -------"
8039 write (iout,*) "Initial duscdiff,duscdiffx"
8040 do i=loc_start,loc_end
8041 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8042 & (duscdiffx(jik,i),jik=1,3)
8045 do i=loc_start,loc_end
8046 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8047 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8048 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8049 c write(iout,*) "xxtab, yytab, zztab"
8050 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8051 do k=1,constr_homology
8053 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8054 c Original sign inverted for calc of gradients (s. Econstr_back)
8055 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8056 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8057 c write(iout,*) "dxx, dyy, dzz"
8058 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8060 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8061 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8062 c uscdiffk(k)=usc_diff(i)
8063 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8064 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8065 c & " guscdiff2",guscdiff2(k)
8066 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8067 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8068 c & xxref(j),yyref(j),zzref(j)
8073 c Generalized expression for multiple Gaussian acc to that for a single
8074 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8076 c Original implementation
8077 c sum_guscdiff=guscdiff(i)
8079 c sum_sguscdiff=0.0d0
8080 c do k=1,constr_homology
8081 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8082 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8083 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8086 c Implementation of new expressions for gradient (Jan. 2015)
8088 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8089 do k=1,constr_homology
8091 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8092 c before. Now the drivatives should be correct
8094 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8095 c Original sign inverted for calc of gradients (s. Econstr_back)
8096 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8097 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8099 c New implementation
8101 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8102 & sigma_d(k,i) ! for the grad wrt r'
8103 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8106 c New implementation
8107 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8109 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8110 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8111 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8112 duscdiff(jik,i)=duscdiff(jik,i)+
8113 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8114 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8115 duscdiffx(jik,i)=duscdiffx(jik,i)+
8116 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8117 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8120 write(iout,*) "jik",jik,"i",i
8121 write(iout,*) "dxx, dyy, dzz"
8122 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8123 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8124 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8125 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8126 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8127 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8128 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8129 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8130 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8131 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8132 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8133 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8134 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8135 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8136 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8142 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8143 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8145 c write (iout,*) i," uscdiff",uscdiff(i)
8147 c Put together deviations from local geometry
8149 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8150 c & wfrag_back(3,i,iset)*uscdiff(i)
8151 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8152 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8153 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8154 c Uconst_back=Uconst_back+usc_diff(i)
8156 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8158 c New implment: multiplied by sum_sguscdiff
8161 enddo ! (i-loop for dscdiff)
8166 write(iout,*) "------- SC restrs end -------"
8167 write (iout,*) "------ After SC loop in e_modeller ------"
8168 do i=loc_start,loc_end
8169 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8170 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8172 if (waga_theta.eq.1.0d0) then
8173 write (iout,*) "in e_modeller after SC restr end: dutheta"
8174 do i=ithet_start,ithet_end
8175 write (iout,*) i,dutheta(i)
8178 if (waga_d.eq.1.0d0) then
8179 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8181 write (iout,*) i,(duscdiff(j,i),j=1,3)
8182 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8187 c Total energy from homology restraints
8189 write (iout,*) "odleg",odleg," kat",kat
8192 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8194 c ehomology_constr=odleg+kat
8196 c For Lorentzian-type Urestr
8199 if (waga_dist.ge.0.0d0) then
8201 c For Gaussian-type Urestr
8203 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8204 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8205 c write (iout,*) "ehomology_constr=",ehomology_constr
8208 c For Lorentzian-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 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8216 & "Eval",waga_theta,eval,
8217 & "Erot",waga_d,Erot
8218 write (iout,*) "ehomology_constr",ehomology_constr
8224 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8225 747 format(a12,i4,i4,i4,f8.3,f8.3)
8226 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8227 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8228 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8229 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8231 c----------------------------------------------------------------------------
8232 C The rigorous attempt to derive energy function
8233 subroutine ebend_kcc(etheta)
8235 implicit real*8 (a-h,o-z)
8236 include 'DIMENSIONS'
8237 include 'COMMON.VAR'
8238 include 'COMMON.GEO'
8239 include 'COMMON.LOCAL'
8240 include 'COMMON.TORSION'
8241 include 'COMMON.INTERACT'
8242 include 'COMMON.DERIV'
8243 include 'COMMON.CHAIN'
8244 include 'COMMON.NAMES'
8245 include 'COMMON.IOUNITS'
8246 include 'COMMON.FFIELD'
8247 include 'COMMON.TORCNSTR'
8248 include 'COMMON.CONTROL'
8250 double precision thybt1(maxang_kcc)
8251 C Set lprn=.true. for debugging
8254 C print *,"wchodze kcc"
8255 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8257 do i=ithet_start,ithet_end
8258 c print *,i,itype(i-1),itype(i),itype(i-2)
8259 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8260 & .or.itype(i).eq.ntyp1) cycle
8261 iti=iabs(itortyp(itype(i-1)))
8262 sinthet=dsin(theta(i))
8263 costhet=dcos(theta(i))
8264 do j=1,nbend_kcc_Tb(iti)
8265 thybt1(j)=v1bend_chyb(j,iti)
8267 sumth1thyb=v1bend_chyb(0,iti)+
8268 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8269 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8271 ihelp=nbend_kcc_Tb(iti)-1
8272 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8273 etheta=etheta+sumth1thyb
8274 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8275 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8279 c-------------------------------------------------------------------------------------
8280 subroutine etheta_constr(ethetacnstr)
8282 implicit real*8 (a-h,o-z)
8283 include 'DIMENSIONS'
8284 include 'COMMON.VAR'
8285 include 'COMMON.GEO'
8286 include 'COMMON.LOCAL'
8287 include 'COMMON.TORSION'
8288 include 'COMMON.INTERACT'
8289 include 'COMMON.DERIV'
8290 include 'COMMON.CHAIN'
8291 include 'COMMON.NAMES'
8292 include 'COMMON.IOUNITS'
8293 include 'COMMON.FFIELD'
8294 include 'COMMON.TORCNSTR'
8295 include 'COMMON.CONTROL'
8297 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8298 do i=ithetaconstr_start,ithetaconstr_end
8299 itheta=itheta_constr(i)
8300 thetiii=theta(itheta)
8301 difi=pinorm(thetiii-theta_constr0(i))
8302 if (difi.gt.theta_drange(i)) then
8303 difi=difi-theta_drange(i)
8304 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8305 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8306 & +for_thet_constr(i)*difi**3
8307 else if (difi.lt.-drange(i)) then
8309 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8310 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8311 & +for_thet_constr(i)*difi**3
8315 if (energy_dec) then
8316 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8317 & i,itheta,rad2deg*thetiii,
8318 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8319 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8320 & gloc(itheta+nphi-2,icg)
8325 c------------------------------------------------------------------------------
8326 subroutine eback_sc_corr(esccor)
8327 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8328 c conformational states; temporarily implemented as differences
8329 c between UNRES torsional potentials (dependent on three types of
8330 c residues) and the torsional potentials dependent on all 20 types
8331 c of residues computed from AM1 energy surfaces of terminally-blocked
8332 c amino-acid residues.
8333 implicit real*8 (a-h,o-z)
8334 include 'DIMENSIONS'
8335 include 'COMMON.VAR'
8336 include 'COMMON.GEO'
8337 include 'COMMON.LOCAL'
8338 include 'COMMON.TORSION'
8339 include 'COMMON.SCCOR'
8340 include 'COMMON.INTERACT'
8341 include 'COMMON.DERIV'
8342 include 'COMMON.CHAIN'
8343 include 'COMMON.NAMES'
8344 include 'COMMON.IOUNITS'
8345 include 'COMMON.FFIELD'
8346 include 'COMMON.CONTROL'
8348 C Set lprn=.true. for debugging
8351 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8353 do i=itau_start,itau_end
8354 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8356 isccori=isccortyp(itype(i-2))
8357 isccori1=isccortyp(itype(i-1))
8358 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8360 do intertyp=1,3 !intertyp
8361 cc Added 09 May 2012 (Adasko)
8362 cc Intertyp means interaction type of backbone mainchain correlation:
8363 c 1 = SC...Ca...Ca...Ca
8364 c 2 = Ca...Ca...Ca...SC
8365 c 3 = SC...Ca...Ca...SCi
8367 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8368 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8369 & (itype(i-1).eq.ntyp1)))
8370 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8371 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8372 & .or.(itype(i).eq.ntyp1)))
8373 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8374 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8375 & (itype(i-3).eq.ntyp1)))) cycle
8376 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8377 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8379 do j=1,nterm_sccor(isccori,isccori1)
8380 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8381 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8382 cosphi=dcos(j*tauangle(intertyp,i))
8383 sinphi=dsin(j*tauangle(intertyp,i))
8384 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8385 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8387 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8388 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8390 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8391 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8392 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8393 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8394 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8401 c----------------------------------------------------------------------------
8402 subroutine multibody(ecorr)
8403 C This subroutine calculates multi-body contributions to energy following
8404 C the idea of Skolnick et al. If side chains I and J make a contact and
8405 C at the same time side chains I+1 and J+1 make a contact, an extra
8406 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8407 implicit real*8 (a-h,o-z)
8408 include 'DIMENSIONS'
8409 include 'COMMON.IOUNITS'
8410 include 'COMMON.DERIV'
8411 include 'COMMON.INTERACT'
8412 include 'COMMON.CONTACTS'
8413 include 'COMMON.CONTMAT'
8414 include 'COMMON.CORRMAT'
8415 double precision gx(3),gx1(3)
8418 C Set lprn=.true. for debugging
8422 write (iout,'(a)') 'Contact function values:'
8424 write (iout,'(i2,20(1x,i2,f10.5))')
8425 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8440 num_conti=num_cont(i)
8441 num_conti1=num_cont(i1)
8446 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8447 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8448 cd & ' ishift=',ishift
8449 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8450 C The system gains extra energy.
8451 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8452 endif ! j1==j+-ishift
8461 c------------------------------------------------------------------------------
8462 double precision function esccorr(i,j,k,l,jj,kk)
8463 implicit real*8 (a-h,o-z)
8464 include 'DIMENSIONS'
8465 include 'COMMON.IOUNITS'
8466 include 'COMMON.DERIV'
8467 include 'COMMON.INTERACT'
8468 include 'COMMON.CONTACTS'
8469 include 'COMMON.CONTMAT'
8470 include 'COMMON.CORRMAT'
8471 include 'COMMON.SHIELD'
8472 double precision gx(3),gx1(3)
8477 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8478 C Calculate the multi-body contribution to energy.
8479 C Calculate multi-body contributions to the gradient.
8480 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8481 cd & k,l,(gacont(m,kk,k),m=1,3)
8483 gx(m) =ekl*gacont(m,jj,i)
8484 gx1(m)=eij*gacont(m,kk,k)
8485 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8486 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8487 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8488 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8492 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8497 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8503 c------------------------------------------------------------------------------
8504 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8505 C This subroutine calculates multi-body contributions to hydrogen-bonding
8506 implicit real*8 (a-h,o-z)
8507 include 'DIMENSIONS'
8508 include 'COMMON.IOUNITS'
8511 parameter (max_cont=maxconts)
8512 parameter (max_dim=26)
8513 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8514 double precision zapas(max_dim,maxconts,max_fg_procs),
8515 & zapas_recv(max_dim,maxconts,max_fg_procs)
8516 common /przechowalnia/ zapas
8517 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8518 & status_array(MPI_STATUS_SIZE,maxconts*2)
8520 include 'COMMON.SETUP'
8521 include 'COMMON.FFIELD'
8522 include 'COMMON.DERIV'
8523 include 'COMMON.INTERACT'
8524 include 'COMMON.CONTACTS'
8525 include 'COMMON.CONTMAT'
8526 include 'COMMON.CORRMAT'
8527 include 'COMMON.CONTROL'
8528 include 'COMMON.LOCAL'
8529 double precision gx(3),gx1(3),time00
8532 C Set lprn=.true. for debugging
8537 if (nfgtasks.le.1) goto 30
8539 write (iout,'(a)') 'Contact function values before RECEIVE:'
8541 write (iout,'(2i3,50(1x,i2,f5.2))')
8542 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8543 & j=1,num_cont_hb(i))
8547 do i=1,ntask_cont_from
8550 do i=1,ntask_cont_to
8553 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8555 C Make the list of contacts to send to send to other procesors
8556 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8558 do i=iturn3_start,iturn3_end
8559 c write (iout,*) "make contact list turn3",i," num_cont",
8561 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8563 do i=iturn4_start,iturn4_end
8564 c write (iout,*) "make contact list turn4",i," num_cont",
8566 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8570 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8572 do j=1,num_cont_hb(i)
8575 iproc=iint_sent_local(k,jjc,ii)
8576 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8577 if (iproc.gt.0) then
8578 ncont_sent(iproc)=ncont_sent(iproc)+1
8579 nn=ncont_sent(iproc)
8581 zapas(2,nn,iproc)=jjc
8582 zapas(3,nn,iproc)=facont_hb(j,i)
8583 zapas(4,nn,iproc)=ees0p(j,i)
8584 zapas(5,nn,iproc)=ees0m(j,i)
8585 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8586 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8587 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8588 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8589 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8590 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8591 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8592 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8593 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8594 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8595 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8596 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8597 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8598 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8599 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8600 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8601 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8602 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8603 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8604 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8605 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8612 & "Numbers of contacts to be sent to other processors",
8613 & (ncont_sent(i),i=1,ntask_cont_to)
8614 write (iout,*) "Contacts sent"
8615 do ii=1,ntask_cont_to
8617 iproc=itask_cont_to(ii)
8618 write (iout,*) nn," contacts to processor",iproc,
8619 & " of CONT_TO_COMM group"
8621 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8629 CorrelID1=nfgtasks+fg_rank+1
8631 C Receive the numbers of needed contacts from other processors
8632 do ii=1,ntask_cont_from
8633 iproc=itask_cont_from(ii)
8635 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8636 & FG_COMM,req(ireq),IERR)
8638 c write (iout,*) "IRECV ended"
8640 C Send the number of contacts needed by other processors
8641 do ii=1,ntask_cont_to
8642 iproc=itask_cont_to(ii)
8644 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8645 & FG_COMM,req(ireq),IERR)
8647 c write (iout,*) "ISEND ended"
8648 c write (iout,*) "number of requests (nn)",ireq
8651 & call MPI_Waitall(ireq,req,status_array,ierr)
8653 c & "Numbers of contacts to be received from other processors",
8654 c & (ncont_recv(i),i=1,ntask_cont_from)
8658 do ii=1,ntask_cont_from
8659 iproc=itask_cont_from(ii)
8661 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8662 c & " of CONT_TO_COMM group"
8666 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8667 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8668 c write (iout,*) "ireq,req",ireq,req(ireq)
8671 C Send the contacts to processors that need them
8672 do ii=1,ntask_cont_to
8673 iproc=itask_cont_to(ii)
8675 c write (iout,*) nn," contacts to processor",iproc,
8676 c & " of CONT_TO_COMM group"
8679 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8680 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8681 c write (iout,*) "ireq,req",ireq,req(ireq)
8683 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8687 c write (iout,*) "number of requests (contacts)",ireq
8688 c write (iout,*) "req",(req(i),i=1,4)
8691 & call MPI_Waitall(ireq,req,status_array,ierr)
8692 do iii=1,ntask_cont_from
8693 iproc=itask_cont_from(iii)
8696 write (iout,*) "Received",nn," contacts from processor",iproc,
8697 & " of CONT_FROM_COMM group"
8700 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8705 ii=zapas_recv(1,i,iii)
8706 c Flag the received contacts to prevent double-counting
8707 jj=-zapas_recv(2,i,iii)
8708 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8710 nnn=num_cont_hb(ii)+1
8713 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8714 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8715 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8716 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8717 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8718 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8719 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8720 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8721 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8722 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8723 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8724 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8725 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8726 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8727 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8728 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8729 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8730 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8731 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8732 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8733 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8734 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8735 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8736 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8740 write (iout,'(a)') 'Contact function values after receive:'
8742 write (iout,'(2i3,50(1x,i3,f5.2))')
8743 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8744 & j=1,num_cont_hb(i))
8751 write (iout,'(a)') 'Contact function values:'
8753 write (iout,'(2i3,50(1x,i3,f5.2))')
8754 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8755 & j=1,num_cont_hb(i))
8760 C Remove the loop below after debugging !!!
8767 C Calculate the local-electrostatic correlation terms
8768 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8770 num_conti=num_cont_hb(i)
8771 num_conti1=num_cont_hb(i+1)
8778 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8779 c & ' jj=',jj,' kk=',kk
8781 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8782 & .or. j.lt.0 .and. j1.gt.0) .and.
8783 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8784 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8785 C The system gains extra energy.
8786 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8787 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8788 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8790 else if (j1.eq.j) then
8791 C Contacts I-J and I-(J+1) occur simultaneously.
8792 C The system loses extra energy.
8793 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8798 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8799 c & ' jj=',jj,' kk=',kk
8801 C Contacts I-J and (I+1)-J occur simultaneously.
8802 C The system loses extra energy.
8803 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8810 c------------------------------------------------------------------------------
8811 subroutine add_hb_contact(ii,jj,itask)
8812 implicit real*8 (a-h,o-z)
8813 include "DIMENSIONS"
8814 include "COMMON.IOUNITS"
8817 parameter (max_cont=maxconts)
8818 parameter (max_dim=26)
8819 include "COMMON.CONTACTS"
8820 include 'COMMON.CONTMAT'
8821 include 'COMMON.CORRMAT'
8822 double precision zapas(max_dim,maxconts,max_fg_procs),
8823 & zapas_recv(max_dim,maxconts,max_fg_procs)
8824 common /przechowalnia/ zapas
8825 integer i,j,ii,jj,iproc,itask(4),nn
8826 c write (iout,*) "itask",itask
8829 if (iproc.gt.0) then
8830 do j=1,num_cont_hb(ii)
8832 c write (iout,*) "i",ii," j",jj," jjc",jjc
8834 ncont_sent(iproc)=ncont_sent(iproc)+1
8835 nn=ncont_sent(iproc)
8836 zapas(1,nn,iproc)=ii
8837 zapas(2,nn,iproc)=jjc
8838 zapas(3,nn,iproc)=facont_hb(j,ii)
8839 zapas(4,nn,iproc)=ees0p(j,ii)
8840 zapas(5,nn,iproc)=ees0m(j,ii)
8841 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8842 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8843 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8844 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8845 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8846 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8847 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8848 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8849 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8850 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8851 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8852 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8853 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8854 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8855 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8856 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8857 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8858 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8859 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8860 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8861 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8869 c------------------------------------------------------------------------------
8870 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8872 C This subroutine calculates multi-body contributions to hydrogen-bonding
8873 implicit real*8 (a-h,o-z)
8874 include 'DIMENSIONS'
8875 include 'COMMON.IOUNITS'
8878 parameter (max_cont=maxconts)
8879 parameter (max_dim=70)
8880 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8881 double precision zapas(max_dim,maxconts,max_fg_procs),
8882 & zapas_recv(max_dim,maxconts,max_fg_procs)
8883 common /przechowalnia/ zapas
8884 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8885 & status_array(MPI_STATUS_SIZE,maxconts*2)
8887 include 'COMMON.SETUP'
8888 include 'COMMON.FFIELD'
8889 include 'COMMON.DERIV'
8890 include 'COMMON.LOCAL'
8891 include 'COMMON.INTERACT'
8892 include 'COMMON.CONTACTS'
8893 include 'COMMON.CONTMAT'
8894 include 'COMMON.CORRMAT'
8895 include 'COMMON.CHAIN'
8896 include 'COMMON.CONTROL'
8897 include 'COMMON.SHIELD'
8898 double precision gx(3),gx1(3)
8899 integer num_cont_hb_old(maxres)
8901 double precision eello4,eello5,eelo6,eello_turn6
8902 external eello4,eello5,eello6,eello_turn6
8903 C Set lprn=.true. for debugging
8908 num_cont_hb_old(i)=num_cont_hb(i)
8912 if (nfgtasks.le.1) goto 30
8914 write (iout,'(a)') 'Contact function values before RECEIVE:'
8916 write (iout,'(2i3,50(1x,i2,f5.2))')
8917 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8918 & j=1,num_cont_hb(i))
8921 do i=1,ntask_cont_from
8924 do i=1,ntask_cont_to
8927 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8929 C Make the list of contacts to send to send to other procesors
8930 do i=iturn3_start,iturn3_end
8931 c write (iout,*) "make contact list turn3",i," num_cont",
8933 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8935 do i=iturn4_start,iturn4_end
8936 c write (iout,*) "make contact list turn4",i," num_cont",
8938 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8942 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8944 do j=1,num_cont_hb(i)
8947 iproc=iint_sent_local(k,jjc,ii)
8948 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8949 if (iproc.ne.0) then
8950 ncont_sent(iproc)=ncont_sent(iproc)+1
8951 nn=ncont_sent(iproc)
8953 zapas(2,nn,iproc)=jjc
8954 zapas(3,nn,iproc)=d_cont(j,i)
8958 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8963 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8971 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8982 & "Numbers of contacts to be sent to other processors",
8983 & (ncont_sent(i),i=1,ntask_cont_to)
8984 write (iout,*) "Contacts sent"
8985 do ii=1,ntask_cont_to
8987 iproc=itask_cont_to(ii)
8988 write (iout,*) nn," contacts to processor",iproc,
8989 & " of CONT_TO_COMM group"
8991 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8999 CorrelID1=nfgtasks+fg_rank+1
9001 C Receive the numbers of needed contacts from other processors
9002 do ii=1,ntask_cont_from
9003 iproc=itask_cont_from(ii)
9005 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9006 & FG_COMM,req(ireq),IERR)
9008 c write (iout,*) "IRECV ended"
9010 C Send the number of contacts needed by other processors
9011 do ii=1,ntask_cont_to
9012 iproc=itask_cont_to(ii)
9014 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9015 & FG_COMM,req(ireq),IERR)
9017 c write (iout,*) "ISEND ended"
9018 c write (iout,*) "number of requests (nn)",ireq
9021 & call MPI_Waitall(ireq,req,status_array,ierr)
9023 c & "Numbers of contacts to be received from other processors",
9024 c & (ncont_recv(i),i=1,ntask_cont_from)
9028 do ii=1,ntask_cont_from
9029 iproc=itask_cont_from(ii)
9031 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9032 c & " of CONT_TO_COMM group"
9036 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9037 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9038 c write (iout,*) "ireq,req",ireq,req(ireq)
9041 C Send the contacts to processors that need them
9042 do ii=1,ntask_cont_to
9043 iproc=itask_cont_to(ii)
9045 c write (iout,*) nn," contacts to processor",iproc,
9046 c & " of CONT_TO_COMM group"
9049 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9050 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9051 c write (iout,*) "ireq,req",ireq,req(ireq)
9053 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9057 c write (iout,*) "number of requests (contacts)",ireq
9058 c write (iout,*) "req",(req(i),i=1,4)
9061 & call MPI_Waitall(ireq,req,status_array,ierr)
9062 do iii=1,ntask_cont_from
9063 iproc=itask_cont_from(iii)
9066 write (iout,*) "Received",nn," contacts from processor",iproc,
9067 & " of CONT_FROM_COMM group"
9070 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9075 ii=zapas_recv(1,i,iii)
9076 c Flag the received contacts to prevent double-counting
9077 jj=-zapas_recv(2,i,iii)
9078 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9080 nnn=num_cont_hb(ii)+1
9083 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9087 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9092 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9100 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9108 write (iout,'(a)') 'Contact function values after receive:'
9110 write (iout,'(2i3,50(1x,i3,5f6.3))')
9111 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9112 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9119 write (iout,'(a)') 'Contact function values:'
9121 write (iout,'(2i3,50(1x,i2,5f6.3))')
9122 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9123 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9129 C Remove the loop below after debugging !!!
9136 C Calculate the dipole-dipole interaction energies
9137 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9138 do i=iatel_s,iatel_e+1
9139 num_conti=num_cont_hb(i)
9148 C Calculate the local-electrostatic correlation terms
9149 c write (iout,*) "gradcorr5 in eello5 before loop"
9151 c write (iout,'(i5,3f10.5)')
9152 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9154 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9155 c write (iout,*) "corr loop i",i
9157 num_conti=num_cont_hb(i)
9158 num_conti1=num_cont_hb(i+1)
9165 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9166 c & ' jj=',jj,' kk=',kk
9167 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9168 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9169 & .or. j.lt.0 .and. j1.gt.0) .and.
9170 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9171 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9172 C The system gains extra energy.
9174 sqd1=dsqrt(d_cont(jj,i))
9175 sqd2=dsqrt(d_cont(kk,i1))
9176 sred_geom = sqd1*sqd2
9177 IF (sred_geom.lt.cutoff_corr) THEN
9178 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9180 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9181 cd & ' jj=',jj,' kk=',kk
9182 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9183 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9185 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9186 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9189 cd write (iout,*) 'sred_geom=',sred_geom,
9190 cd & ' ekont=',ekont,' fprim=',fprimcont,
9191 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9192 cd write (iout,*) "g_contij",g_contij
9193 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9194 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9195 call calc_eello(i,jp,i+1,jp1,jj,kk)
9196 if (wcorr4.gt.0.0d0)
9197 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9198 CC & *fac_shield(i)**2*fac_shield(j)**2
9199 if (energy_dec.and.wcorr4.gt.0.0d0)
9200 1 write (iout,'(a6,4i5,0pf7.3)')
9201 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9202 c write (iout,*) "gradcorr5 before eello5"
9204 c write (iout,'(i5,3f10.5)')
9205 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9207 if (wcorr5.gt.0.0d0)
9208 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9209 c write (iout,*) "gradcorr5 after eello5"
9211 c write (iout,'(i5,3f10.5)')
9212 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9214 if (energy_dec.and.wcorr5.gt.0.0d0)
9215 1 write (iout,'(a6,4i5,0pf7.3)')
9216 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9217 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9218 cd write(2,*)'ijkl',i,jp,i+1,jp1
9219 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9220 & .or. wturn6.eq.0.0d0))then
9221 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9222 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9223 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9224 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9225 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9226 cd & 'ecorr6=',ecorr6
9227 cd write (iout,'(4e15.5)') sred_geom,
9228 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9229 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9230 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9231 else if (wturn6.gt.0.0d0
9232 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9233 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9234 eturn6=eturn6+eello_turn6(i,jj,kk)
9235 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9236 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9237 cd write (2,*) 'multibody_eello:eturn6',eturn6
9246 num_cont_hb(i)=num_cont_hb_old(i)
9248 c write (iout,*) "gradcorr5 in eello5"
9250 c write (iout,'(i5,3f10.5)')
9251 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9255 c------------------------------------------------------------------------------
9256 subroutine add_hb_contact_eello(ii,jj,itask)
9257 implicit real*8 (a-h,o-z)
9258 include "DIMENSIONS"
9259 include "COMMON.IOUNITS"
9262 parameter (max_cont=maxconts)
9263 parameter (max_dim=70)
9264 include "COMMON.CONTACTS"
9265 include 'COMMON.CONTMAT'
9266 include 'COMMON.CORRMAT'
9267 double precision zapas(max_dim,maxconts,max_fg_procs),
9268 & zapas_recv(max_dim,maxconts,max_fg_procs)
9269 common /przechowalnia/ zapas
9270 integer i,j,ii,jj,iproc,itask(4),nn
9271 c write (iout,*) "itask",itask
9274 if (iproc.gt.0) then
9275 do j=1,num_cont_hb(ii)
9277 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9279 ncont_sent(iproc)=ncont_sent(iproc)+1
9280 nn=ncont_sent(iproc)
9281 zapas(1,nn,iproc)=ii
9282 zapas(2,nn,iproc)=jjc
9283 zapas(3,nn,iproc)=d_cont(j,ii)
9287 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9292 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9300 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9312 c------------------------------------------------------------------------------
9313 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9314 implicit real*8 (a-h,o-z)
9315 include 'DIMENSIONS'
9316 include 'COMMON.IOUNITS'
9317 include 'COMMON.DERIV'
9318 include 'COMMON.INTERACT'
9319 include 'COMMON.CONTACTS'
9320 include 'COMMON.CONTMAT'
9321 include 'COMMON.CORRMAT'
9322 include 'COMMON.SHIELD'
9323 include 'COMMON.CONTROL'
9324 double precision gx(3),gx1(3)
9327 C print *,"wchodze",fac_shield(i),shield_mode
9335 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9337 C & fac_shield(i)**2*fac_shield(j)**2
9338 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9339 C Following 4 lines for diagnostics.
9344 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9345 c & 'Contacts ',i,j,
9346 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9347 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9349 C Calculate the multi-body contribution to energy.
9350 C ecorr=ecorr+ekont*ees
9351 C Calculate multi-body contributions to the gradient.
9352 coeffpees0pij=coeffp*ees0pij
9353 coeffmees0mij=coeffm*ees0mij
9354 coeffpees0pkl=coeffp*ees0pkl
9355 coeffmees0mkl=coeffm*ees0mkl
9357 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9358 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9359 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9360 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9361 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9362 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9363 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9364 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9365 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9366 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9367 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9368 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9369 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9370 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9371 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9372 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9373 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9374 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9375 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9376 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9377 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9378 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9379 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9380 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9381 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9386 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9387 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9388 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9389 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9394 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9395 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9396 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9397 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9400 c write (iout,*) "ehbcorr",ekont*ees
9401 C print *,ekont,ees,i,k
9403 C now gradient over shielding
9405 if (shield_mode.gt.0) then
9408 C print *,i,j,fac_shield(i),fac_shield(j),
9409 C &fac_shield(k),fac_shield(l)
9410 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9411 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9412 do ilist=1,ishield_list(i)
9413 iresshield=shield_list(ilist,i)
9415 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9417 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9419 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9420 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9424 do ilist=1,ishield_list(j)
9425 iresshield=shield_list(ilist,j)
9427 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9429 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9431 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9432 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9437 do ilist=1,ishield_list(k)
9438 iresshield=shield_list(ilist,k)
9440 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9442 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9444 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9445 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9449 do ilist=1,ishield_list(l)
9450 iresshield=shield_list(ilist,l)
9452 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9454 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9456 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9457 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9461 C print *,gshieldx(m,iresshield)
9463 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9464 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9465 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9466 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9467 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9468 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9469 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9470 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9472 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9473 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9474 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9475 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9476 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9477 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9478 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9479 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9487 C---------------------------------------------------------------------------
9488 subroutine dipole(i,j,jj)
9489 implicit real*8 (a-h,o-z)
9490 include 'DIMENSIONS'
9491 include 'COMMON.IOUNITS'
9492 include 'COMMON.CHAIN'
9493 include 'COMMON.FFIELD'
9494 include 'COMMON.DERIV'
9495 include 'COMMON.INTERACT'
9496 include 'COMMON.CONTACTS'
9497 include 'COMMON.CONTMAT'
9498 include 'COMMON.CORRMAT'
9499 include 'COMMON.TORSION'
9500 include 'COMMON.VAR'
9501 include 'COMMON.GEO'
9502 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9504 iti1 = itortyp(itype(i+1))
9505 if (j.lt.nres-1) then
9506 itj1 = itype2loc(itype(j+1))
9511 dipi(iii,1)=Ub2(iii,i)
9512 dipderi(iii)=Ub2der(iii,i)
9513 dipi(iii,2)=b1(iii,i+1)
9514 dipj(iii,1)=Ub2(iii,j)
9515 dipderj(iii)=Ub2der(iii,j)
9516 dipj(iii,2)=b1(iii,j+1)
9520 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9523 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9530 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9534 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9539 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9540 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9542 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9544 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9546 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9551 C---------------------------------------------------------------------------
9552 subroutine calc_eello(i,j,k,l,jj,kk)
9554 C This subroutine computes matrices and vectors needed to calculate
9555 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9557 implicit real*8 (a-h,o-z)
9558 include 'DIMENSIONS'
9559 include 'COMMON.IOUNITS'
9560 include 'COMMON.CHAIN'
9561 include 'COMMON.DERIV'
9562 include 'COMMON.INTERACT'
9563 include 'COMMON.CONTACTS'
9564 include 'COMMON.CONTMAT'
9565 include 'COMMON.CORRMAT'
9566 include 'COMMON.TORSION'
9567 include 'COMMON.VAR'
9568 include 'COMMON.GEO'
9569 include 'COMMON.FFIELD'
9570 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9571 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9574 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9575 cd & ' jj=',jj,' kk=',kk
9576 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9577 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9578 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9581 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9582 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9585 call transpose2(aa1(1,1),aa1t(1,1))
9586 call transpose2(aa2(1,1),aa2t(1,1))
9589 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9590 & aa1tder(1,1,lll,kkk))
9591 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9592 & aa2tder(1,1,lll,kkk))
9596 C parallel orientation of the two CA-CA-CA frames.
9598 iti=itype2loc(itype(i))
9602 itk1=itype2loc(itype(k+1))
9603 itj=itype2loc(itype(j))
9604 if (l.lt.nres-1) then
9605 itl1=itype2loc(itype(l+1))
9609 C A1 kernel(j+1) A2T
9611 cd write (iout,'(3f10.5,5x,3f10.5)')
9612 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9614 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9615 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9616 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9617 C Following matrices are needed only for 6-th order cumulants
9618 IF (wcorr6.gt.0.0d0) THEN
9619 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9620 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9621 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9622 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9623 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9624 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9625 & ADtEAderx(1,1,1,1,1,1))
9627 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9628 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9629 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9630 & ADtEA1derx(1,1,1,1,1,1))
9632 C End 6-th order cumulants
9635 cd write (2,*) 'In calc_eello6'
9637 cd write (2,*) 'iii=',iii
9639 cd write (2,*) 'kkk=',kkk
9641 cd write (2,'(3(2f10.5),5x)')
9642 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9647 call transpose2(EUgder(1,1,k),auxmat(1,1))
9648 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9649 call transpose2(EUg(1,1,k),auxmat(1,1))
9650 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9651 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9652 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9653 c in theta; to be sriten later.
9655 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9656 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9657 c call transpose2(EUg(1,1,k),auxmat(1,1))
9658 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9663 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9664 & EAEAderx(1,1,lll,kkk,iii,1))
9668 C A1T kernel(i+1) A2
9669 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9670 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9671 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9672 C Following matrices are needed only for 6-th order cumulants
9673 IF (wcorr6.gt.0.0d0) THEN
9674 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9675 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9676 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9677 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9678 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9679 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9680 & ADtEAderx(1,1,1,1,1,2))
9681 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9682 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9683 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9684 & ADtEA1derx(1,1,1,1,1,2))
9686 C End 6-th order cumulants
9687 call transpose2(EUgder(1,1,l),auxmat(1,1))
9688 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9689 call transpose2(EUg(1,1,l),auxmat(1,1))
9690 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9691 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9695 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9696 & EAEAderx(1,1,lll,kkk,iii,2))
9701 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9702 C They are needed only when the fifth- or the sixth-order cumulants are
9704 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9705 call transpose2(AEA(1,1,1),auxmat(1,1))
9706 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9707 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9708 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9709 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9710 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9711 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9712 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9713 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9714 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9715 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9716 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9717 call transpose2(AEA(1,1,2),auxmat(1,1))
9718 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9719 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9720 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9721 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9722 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9723 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9724 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9725 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9726 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9727 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9728 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9729 C Calculate the Cartesian derivatives of the vectors.
9733 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9734 call matvec2(auxmat(1,1),b1(1,i),
9735 & AEAb1derx(1,lll,kkk,iii,1,1))
9736 call matvec2(auxmat(1,1),Ub2(1,i),
9737 & AEAb2derx(1,lll,kkk,iii,1,1))
9738 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9739 & AEAb1derx(1,lll,kkk,iii,2,1))
9740 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9741 & AEAb2derx(1,lll,kkk,iii,2,1))
9742 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9743 call matvec2(auxmat(1,1),b1(1,j),
9744 & AEAb1derx(1,lll,kkk,iii,1,2))
9745 call matvec2(auxmat(1,1),Ub2(1,j),
9746 & AEAb2derx(1,lll,kkk,iii,1,2))
9747 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9748 & AEAb1derx(1,lll,kkk,iii,2,2))
9749 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9750 & AEAb2derx(1,lll,kkk,iii,2,2))
9757 C Antiparallel orientation of the two CA-CA-CA frames.
9759 iti=itype2loc(itype(i))
9763 itk1=itype2loc(itype(k+1))
9764 itl=itype2loc(itype(l))
9765 itj=itype2loc(itype(j))
9766 if (j.lt.nres-1) then
9767 itj1=itype2loc(itype(j+1))
9771 C A2 kernel(j-1)T A1T
9772 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9773 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9774 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9775 C Following matrices are needed only for 6-th order cumulants
9776 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9777 & j.eq.i+4 .and. l.eq.i+3)) THEN
9778 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9779 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9780 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9781 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9782 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9783 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9784 & ADtEAderx(1,1,1,1,1,1))
9785 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9786 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9787 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9788 & ADtEA1derx(1,1,1,1,1,1))
9790 C End 6-th order cumulants
9791 call transpose2(EUgder(1,1,k),auxmat(1,1))
9792 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9793 call transpose2(EUg(1,1,k),auxmat(1,1))
9794 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9795 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9799 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9800 & EAEAderx(1,1,lll,kkk,iii,1))
9804 C A2T kernel(i+1)T A1
9805 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9806 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9807 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9808 C Following matrices are needed only for 6-th order cumulants
9809 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9810 & j.eq.i+4 .and. l.eq.i+3)) THEN
9811 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9812 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9813 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9814 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9815 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9816 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9817 & ADtEAderx(1,1,1,1,1,2))
9818 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9819 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9820 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9821 & ADtEA1derx(1,1,1,1,1,2))
9823 C End 6-th order cumulants
9824 call transpose2(EUgder(1,1,j),auxmat(1,1))
9825 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9826 call transpose2(EUg(1,1,j),auxmat(1,1))
9827 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9828 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9832 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9833 & EAEAderx(1,1,lll,kkk,iii,2))
9838 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9839 C They are needed only when the fifth- or the sixth-order cumulants are
9841 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9842 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9843 call transpose2(AEA(1,1,1),auxmat(1,1))
9844 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9845 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9846 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9847 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9848 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9849 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9850 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9851 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9852 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9853 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9854 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9855 call transpose2(AEA(1,1,2),auxmat(1,1))
9856 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9857 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9858 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9859 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9860 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9861 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9862 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9863 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9864 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9865 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9866 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9867 C Calculate the Cartesian derivatives of the vectors.
9871 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9872 call matvec2(auxmat(1,1),b1(1,i),
9873 & AEAb1derx(1,lll,kkk,iii,1,1))
9874 call matvec2(auxmat(1,1),Ub2(1,i),
9875 & AEAb2derx(1,lll,kkk,iii,1,1))
9876 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9877 & AEAb1derx(1,lll,kkk,iii,2,1))
9878 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9879 & AEAb2derx(1,lll,kkk,iii,2,1))
9880 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9881 call matvec2(auxmat(1,1),b1(1,l),
9882 & AEAb1derx(1,lll,kkk,iii,1,2))
9883 call matvec2(auxmat(1,1),Ub2(1,l),
9884 & AEAb2derx(1,lll,kkk,iii,1,2))
9885 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9886 & AEAb1derx(1,lll,kkk,iii,2,2))
9887 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9888 & AEAb2derx(1,lll,kkk,iii,2,2))
9897 C---------------------------------------------------------------------------
9898 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9899 & KK,KKderg,AKA,AKAderg,AKAderx)
9903 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9904 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9905 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9910 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9912 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9915 cd if (lprn) write (2,*) 'In kernel'
9917 cd if (lprn) write (2,*) 'kkk=',kkk
9919 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9920 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9922 cd write (2,*) 'lll=',lll
9923 cd write (2,*) 'iii=1'
9925 cd write (2,'(3(2f10.5),5x)')
9926 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9929 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9930 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9932 cd write (2,*) 'lll=',lll
9933 cd write (2,*) 'iii=2'
9935 cd write (2,'(3(2f10.5),5x)')
9936 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9943 C---------------------------------------------------------------------------
9944 double precision function eello4(i,j,k,l,jj,kk)
9945 implicit real*8 (a-h,o-z)
9946 include 'DIMENSIONS'
9947 include 'COMMON.IOUNITS'
9948 include 'COMMON.CHAIN'
9949 include 'COMMON.DERIV'
9950 include 'COMMON.INTERACT'
9951 include 'COMMON.CONTACTS'
9952 include 'COMMON.CONTMAT'
9953 include 'COMMON.CORRMAT'
9954 include 'COMMON.TORSION'
9955 include 'COMMON.VAR'
9956 include 'COMMON.GEO'
9957 double precision pizda(2,2),ggg1(3),ggg2(3)
9958 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9962 cd print *,'eello4:',i,j,k,l,jj,kk
9963 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9964 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9965 cold eij=facont_hb(jj,i)
9966 cold ekl=facont_hb(kk,k)
9968 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9969 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9970 gcorr_loc(k-1)=gcorr_loc(k-1)
9971 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9973 gcorr_loc(l-1)=gcorr_loc(l-1)
9974 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9975 C Al 4/16/16: Derivatives in theta, to be added later.
9977 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9978 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9981 gcorr_loc(j-1)=gcorr_loc(j-1)
9982 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9984 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9985 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9991 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9992 & -EAEAderx(2,2,lll,kkk,iii,1)
9993 cd derx(lll,kkk,iii)=0.0d0
9997 cd gcorr_loc(l-1)=0.0d0
9998 cd gcorr_loc(j-1)=0.0d0
9999 cd gcorr_loc(k-1)=0.0d0
10001 cd write (iout,*)'Contacts have occurred for peptide groups',
10002 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10003 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10004 if (j.lt.nres-1) then
10011 if (l.lt.nres-1) then
10019 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10020 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10021 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10022 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10023 cgrad ghalf=0.5d0*ggg1(ll)
10024 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10025 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10026 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10027 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10028 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10029 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10030 cgrad ghalf=0.5d0*ggg2(ll)
10031 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10032 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10033 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10034 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10035 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10036 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10040 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10045 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10050 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10055 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10059 cd write (2,*) iii,gcorr_loc(iii)
10062 cd write (2,*) 'ekont',ekont
10063 cd write (iout,*) 'eello4',ekont*eel4
10066 C---------------------------------------------------------------------------
10067 double precision function eello5(i,j,k,l,jj,kk)
10068 implicit real*8 (a-h,o-z)
10069 include 'DIMENSIONS'
10070 include 'COMMON.IOUNITS'
10071 include 'COMMON.CHAIN'
10072 include 'COMMON.DERIV'
10073 include 'COMMON.INTERACT'
10074 include 'COMMON.CONTACTS'
10075 include 'COMMON.CONTMAT'
10076 include 'COMMON.CORRMAT'
10077 include 'COMMON.TORSION'
10078 include 'COMMON.VAR'
10079 include 'COMMON.GEO'
10080 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10081 double precision ggg1(3),ggg2(3)
10082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10084 C Parallel chains C
10087 C /l\ / \ \ / \ / \ / C
10088 C / \ / \ \ / \ / \ / C
10089 C j| o |l1 | o | o| o | | o |o C
10090 C \ |/k\| |/ \| / |/ \| |/ \| C
10091 C \i/ \ / \ / / \ / \ C
10093 C (I) (II) (III) (IV) C
10095 C eello5_1 eello5_2 eello5_3 eello5_4 C
10097 C Antiparallel chains C
10100 C /j\ / \ \ / \ / \ / C
10101 C / \ / \ \ / \ / \ / C
10102 C j1| o |l | o | o| o | | o |o C
10103 C \ |/k\| |/ \| / |/ \| |/ \| C
10104 C \i/ \ / \ / / \ / \ C
10106 C (I) (II) (III) (IV) C
10108 C eello5_1 eello5_2 eello5_3 eello5_4 C
10110 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10113 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10118 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10120 itk=itype2loc(itype(k))
10121 itl=itype2loc(itype(l))
10122 itj=itype2loc(itype(j))
10127 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10128 cd & eel5_3_num,eel5_4_num)
10132 derx(lll,kkk,iii)=0.0d0
10136 cd eij=facont_hb(jj,i)
10137 cd ekl=facont_hb(kk,k)
10139 cd write (iout,*)'Contacts have occurred for peptide groups',
10140 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10142 C Contribution from the graph I.
10143 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10144 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10145 call transpose2(EUg(1,1,k),auxmat(1,1))
10146 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10147 vv(1)=pizda(1,1)-pizda(2,2)
10148 vv(2)=pizda(1,2)+pizda(2,1)
10149 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10150 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10151 C Explicit gradient in virtual-dihedral angles.
10152 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10153 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10154 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10155 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10156 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10157 vv(1)=pizda(1,1)-pizda(2,2)
10158 vv(2)=pizda(1,2)+pizda(2,1)
10159 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10160 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10161 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10162 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10163 vv(1)=pizda(1,1)-pizda(2,2)
10164 vv(2)=pizda(1,2)+pizda(2,1)
10166 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10167 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10168 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10170 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10171 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10172 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10174 C Cartesian gradient
10178 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10180 vv(1)=pizda(1,1)-pizda(2,2)
10181 vv(2)=pizda(1,2)+pizda(2,1)
10182 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10183 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10184 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10190 C Contribution from graph II
10191 call transpose2(EE(1,1,k),auxmat(1,1))
10192 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10193 vv(1)=pizda(1,1)+pizda(2,2)
10194 vv(2)=pizda(2,1)-pizda(1,2)
10195 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10196 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10197 C Explicit gradient in virtual-dihedral angles.
10198 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10199 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10200 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10201 vv(1)=pizda(1,1)+pizda(2,2)
10202 vv(2)=pizda(2,1)-pizda(1,2)
10204 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10205 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10206 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10208 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10209 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10210 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10212 C Cartesian gradient
10216 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10218 vv(1)=pizda(1,1)+pizda(2,2)
10219 vv(2)=pizda(2,1)-pizda(1,2)
10220 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10221 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10222 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10230 C Parallel orientation
10231 C Contribution from graph III
10232 call transpose2(EUg(1,1,l),auxmat(1,1))
10233 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10234 vv(1)=pizda(1,1)-pizda(2,2)
10235 vv(2)=pizda(1,2)+pizda(2,1)
10236 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10237 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10238 C Explicit gradient in virtual-dihedral angles.
10239 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10240 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10241 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10242 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10243 vv(1)=pizda(1,1)-pizda(2,2)
10244 vv(2)=pizda(1,2)+pizda(2,1)
10245 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10246 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10247 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10248 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10249 call matmat2(AEA(1,1,2),auxmat1(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(l-1)=g_corr5_loc(l-1)
10253 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10254 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10255 C Cartesian gradient
10259 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10261 vv(1)=pizda(1,1)-pizda(2,2)
10262 vv(2)=pizda(1,2)+pizda(2,1)
10263 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10264 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10265 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10270 C Contribution from graph IV
10272 call transpose2(EE(1,1,l),auxmat(1,1))
10273 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10274 vv(1)=pizda(1,1)+pizda(2,2)
10275 vv(2)=pizda(2,1)-pizda(1,2)
10276 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10277 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10278 C Explicit gradient in virtual-dihedral angles.
10279 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10280 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10281 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10282 vv(1)=pizda(1,1)+pizda(2,2)
10283 vv(2)=pizda(2,1)-pizda(1,2)
10284 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10285 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10286 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10287 C Cartesian gradient
10291 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10293 vv(1)=pizda(1,1)+pizda(2,2)
10294 vv(2)=pizda(2,1)-pizda(1,2)
10295 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10296 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10297 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10302 C Antiparallel orientation
10303 C Contribution from graph III
10305 call transpose2(EUg(1,1,j),auxmat(1,1))
10306 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10307 vv(1)=pizda(1,1)-pizda(2,2)
10308 vv(2)=pizda(1,2)+pizda(2,1)
10309 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10310 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10311 C Explicit gradient in virtual-dihedral angles.
10312 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10313 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10314 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10315 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10316 vv(1)=pizda(1,1)-pizda(2,2)
10317 vv(2)=pizda(1,2)+pizda(2,1)
10318 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10319 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10320 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10321 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10322 call matmat2(AEA(1,1,2),auxmat1(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(j-1)=g_corr5_loc(j-1)
10326 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10327 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10328 C Cartesian gradient
10332 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10334 vv(1)=pizda(1,1)-pizda(2,2)
10335 vv(2)=pizda(1,2)+pizda(2,1)
10336 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10337 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10338 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10343 C Contribution from graph IV
10345 call transpose2(EE(1,1,j),auxmat(1,1))
10346 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10347 vv(1)=pizda(1,1)+pizda(2,2)
10348 vv(2)=pizda(2,1)-pizda(1,2)
10349 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10350 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10351 C Explicit gradient in virtual-dihedral angles.
10352 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10353 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10354 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10355 vv(1)=pizda(1,1)+pizda(2,2)
10356 vv(2)=pizda(2,1)-pizda(1,2)
10357 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10358 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10359 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10360 C Cartesian gradient
10364 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10366 vv(1)=pizda(1,1)+pizda(2,2)
10367 vv(2)=pizda(2,1)-pizda(1,2)
10368 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10369 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10370 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10376 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10377 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10378 cd write (2,*) 'ijkl',i,j,k,l
10379 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10380 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10382 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10383 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10384 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10385 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10386 if (j.lt.nres-1) then
10393 if (l.lt.nres-1) then
10403 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10404 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10405 C summed up outside the subrouine as for the other subroutines
10406 C handling long-range interactions. The old code is commented out
10407 C with "cgrad" to keep track of changes.
10409 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10410 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10411 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10412 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10413 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10414 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10415 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10416 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10417 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10418 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10420 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10421 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10422 cgrad ghalf=0.5d0*ggg1(ll)
10424 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10425 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10426 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10427 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10428 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10429 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10430 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10431 cgrad ghalf=0.5d0*ggg2(ll)
10433 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10434 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10435 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10436 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10437 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10438 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10443 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10444 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10449 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10450 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10456 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10461 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10465 cd write (2,*) iii,g_corr5_loc(iii)
10468 cd write (2,*) 'ekont',ekont
10469 cd write (iout,*) 'eello5',ekont*eel5
10472 c--------------------------------------------------------------------------
10473 double precision function eello6(i,j,k,l,jj,kk)
10474 implicit real*8 (a-h,o-z)
10475 include 'DIMENSIONS'
10476 include 'COMMON.IOUNITS'
10477 include 'COMMON.CHAIN'
10478 include 'COMMON.DERIV'
10479 include 'COMMON.INTERACT'
10480 include 'COMMON.CONTACTS'
10481 include 'COMMON.CONTMAT'
10482 include 'COMMON.CORRMAT'
10483 include 'COMMON.TORSION'
10484 include 'COMMON.VAR'
10485 include 'COMMON.GEO'
10486 include 'COMMON.FFIELD'
10487 double precision ggg1(3),ggg2(3)
10488 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10493 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10501 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10502 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10506 derx(lll,kkk,iii)=0.0d0
10510 cd eij=facont_hb(jj,i)
10511 cd ekl=facont_hb(kk,k)
10517 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10518 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10519 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10520 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10521 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10522 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10524 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10525 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10526 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10527 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10528 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10529 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10533 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10535 C If turn contributions are considered, they will be handled separately.
10536 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10537 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10538 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10539 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10540 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10541 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10542 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10544 if (j.lt.nres-1) then
10551 if (l.lt.nres-1) then
10559 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10560 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10561 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10562 cgrad ghalf=0.5d0*ggg1(ll)
10564 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10565 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10566 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10567 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10568 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10569 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10570 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10571 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10572 cgrad ghalf=0.5d0*ggg2(ll)
10573 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10575 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10576 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10577 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10578 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10579 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10580 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10585 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10586 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10591 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10592 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10598 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10603 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10607 cd write (2,*) iii,g_corr6_loc(iii)
10610 cd write (2,*) 'ekont',ekont
10611 cd write (iout,*) 'eello6',ekont*eel6
10614 c--------------------------------------------------------------------------
10615 double precision function eello6_graph1(i,j,k,l,imat,swap)
10616 implicit real*8 (a-h,o-z)
10617 include 'DIMENSIONS'
10618 include 'COMMON.IOUNITS'
10619 include 'COMMON.CHAIN'
10620 include 'COMMON.DERIV'
10621 include 'COMMON.INTERACT'
10622 include 'COMMON.CONTACTS'
10623 include 'COMMON.CONTMAT'
10624 include 'COMMON.CORRMAT'
10625 include 'COMMON.TORSION'
10626 include 'COMMON.VAR'
10627 include 'COMMON.GEO'
10628 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10631 common /kutas/ lprn
10632 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10634 C Parallel Antiparallel C
10640 C \ j|/k\| / \ |/k\|l / C
10641 C \ / \ / \ / \ / C
10645 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10646 itk=itype2loc(itype(k))
10647 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10648 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10649 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10650 call transpose2(EUgC(1,1,k),auxmat(1,1))
10651 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10652 vv1(1)=pizda1(1,1)-pizda1(2,2)
10653 vv1(2)=pizda1(1,2)+pizda1(2,1)
10654 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10655 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10656 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10657 s5=scalar2(vv(1),Dtobr2(1,i))
10658 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10659 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10660 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10661 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10662 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10663 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10664 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10665 & +scalar2(vv(1),Dtobr2der(1,i)))
10666 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10667 vv1(1)=pizda1(1,1)-pizda1(2,2)
10668 vv1(2)=pizda1(1,2)+pizda1(2,1)
10669 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10670 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10672 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10673 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10674 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10675 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10676 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10678 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10679 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10680 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10681 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10682 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10684 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10685 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10686 vv1(1)=pizda1(1,1)-pizda1(2,2)
10687 vv1(2)=pizda1(1,2)+pizda1(2,1)
10688 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10689 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10690 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10691 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10700 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10701 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10702 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10703 call transpose2(EUgC(1,1,k),auxmat(1,1))
10704 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10706 vv1(1)=pizda1(1,1)-pizda1(2,2)
10707 vv1(2)=pizda1(1,2)+pizda1(2,1)
10708 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10709 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10710 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10711 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10712 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10713 s5=scalar2(vv(1),Dtobr2(1,i))
10714 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10720 c----------------------------------------------------------------------------
10721 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10722 implicit real*8 (a-h,o-z)
10723 include 'DIMENSIONS'
10724 include 'COMMON.IOUNITS'
10725 include 'COMMON.CHAIN'
10726 include 'COMMON.DERIV'
10727 include 'COMMON.INTERACT'
10728 include 'COMMON.CONTACTS'
10729 include 'COMMON.CONTMAT'
10730 include 'COMMON.CORRMAT'
10731 include 'COMMON.TORSION'
10732 include 'COMMON.VAR'
10733 include 'COMMON.GEO'
10735 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10736 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10738 common /kutas/ lprn
10739 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10741 C Parallel Antiparallel C
10747 C \ j|/k\| \ |/k\|l C
10752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10753 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10754 C AL 7/4/01 s1 would occur in the sixth-order moment,
10755 C but not in a cluster cumulant
10757 s1=dip(1,jj,i)*dip(1,kk,k)
10759 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10760 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10761 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10762 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10763 call transpose2(EUg(1,1,k),auxmat(1,1))
10764 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10765 vv(1)=pizda(1,1)-pizda(2,2)
10766 vv(2)=pizda(1,2)+pizda(2,1)
10767 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10768 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10770 eello6_graph2=-(s1+s2+s3+s4)
10772 eello6_graph2=-(s2+s3+s4)
10774 c eello6_graph2=-s3
10775 C Derivatives in gamma(i-1)
10778 s1=dipderg(1,jj,i)*dip(1,kk,k)
10780 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10781 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10782 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10783 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10785 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10787 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10789 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10791 C Derivatives in gamma(k-1)
10793 s1=dip(1,jj,i)*dipderg(1,kk,k)
10795 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10796 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10797 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10798 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10799 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10800 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10801 vv(1)=pizda(1,1)-pizda(2,2)
10802 vv(2)=pizda(1,2)+pizda(2,1)
10803 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10805 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10807 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10809 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10810 C Derivatives in gamma(j-1) or gamma(l-1)
10813 s1=dipderg(3,jj,i)*dip(1,kk,k)
10815 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10816 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10817 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10818 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10819 vv(1)=pizda(1,1)-pizda(2,2)
10820 vv(2)=pizda(1,2)+pizda(2,1)
10821 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10824 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10826 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10829 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10830 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10832 C Derivatives in gamma(l-1) or gamma(j-1)
10835 s1=dip(1,jj,i)*dipderg(3,kk,k)
10837 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10838 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10839 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10840 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10841 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10842 vv(1)=pizda(1,1)-pizda(2,2)
10843 vv(2)=pizda(1,2)+pizda(2,1)
10844 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10847 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10849 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10852 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10853 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10855 C Cartesian derivatives.
10857 write (2,*) 'In eello6_graph2'
10859 write (2,*) 'iii=',iii
10861 write (2,*) 'kkk=',kkk
10863 write (2,'(3(2f10.5),5x)')
10864 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10874 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10876 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10879 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10881 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10882 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10884 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10885 call transpose2(EUg(1,1,k),auxmat(1,1))
10886 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10888 vv(1)=pizda(1,1)-pizda(2,2)
10889 vv(2)=pizda(1,2)+pizda(2,1)
10890 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10891 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10893 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10895 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10898 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10900 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10907 c----------------------------------------------------------------------------
10908 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10909 implicit real*8 (a-h,o-z)
10910 include 'DIMENSIONS'
10911 include 'COMMON.IOUNITS'
10912 include 'COMMON.CHAIN'
10913 include 'COMMON.DERIV'
10914 include 'COMMON.INTERACT'
10915 include 'COMMON.CONTACTS'
10916 include 'COMMON.CONTMAT'
10917 include 'COMMON.CORRMAT'
10918 include 'COMMON.TORSION'
10919 include 'COMMON.VAR'
10920 include 'COMMON.GEO'
10921 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10923 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10925 C Parallel Antiparallel C
10930 C /| o |o o| o |\ C
10931 C j|/k\| / |/k\|l / C
10936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10938 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10939 C energy moment and not to the cluster cumulant.
10940 iti=itortyp(itype(i))
10941 if (j.lt.nres-1) then
10942 itj1=itype2loc(itype(j+1))
10946 itk=itype2loc(itype(k))
10947 itk1=itype2loc(itype(k+1))
10948 if (l.lt.nres-1) then
10949 itl1=itype2loc(itype(l+1))
10954 s1=dip(4,jj,i)*dip(4,kk,k)
10956 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10957 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10958 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10959 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10960 call transpose2(EE(1,1,k),auxmat(1,1))
10961 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10962 vv(1)=pizda(1,1)+pizda(2,2)
10963 vv(2)=pizda(2,1)-pizda(1,2)
10964 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10965 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10966 cd & "sum",-(s2+s3+s4)
10968 eello6_graph3=-(s1+s2+s3+s4)
10970 eello6_graph3=-(s2+s3+s4)
10972 c eello6_graph3=-s4
10973 C Derivatives in gamma(k-1)
10974 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10975 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10976 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10977 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10978 C Derivatives in gamma(l-1)
10979 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10980 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10981 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10982 vv(1)=pizda(1,1)+pizda(2,2)
10983 vv(2)=pizda(2,1)-pizda(1,2)
10984 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10985 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10986 C Cartesian derivatives.
10992 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10994 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10997 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10999 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11000 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11002 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11003 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11005 vv(1)=pizda(1,1)+pizda(2,2)
11006 vv(2)=pizda(2,1)-pizda(1,2)
11007 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11009 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11011 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11014 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11016 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11018 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11024 c----------------------------------------------------------------------------
11025 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11026 implicit real*8 (a-h,o-z)
11027 include 'DIMENSIONS'
11028 include 'COMMON.IOUNITS'
11029 include 'COMMON.CHAIN'
11030 include 'COMMON.DERIV'
11031 include 'COMMON.INTERACT'
11032 include 'COMMON.CONTACTS'
11033 include 'COMMON.CONTMAT'
11034 include 'COMMON.CORRMAT'
11035 include 'COMMON.TORSION'
11036 include 'COMMON.VAR'
11037 include 'COMMON.GEO'
11038 include 'COMMON.FFIELD'
11039 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11040 & auxvec1(2),auxmat1(2,2)
11042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11044 C Parallel Antiparallel C
11049 C /| o |o o| o |\ C
11050 C \ j|/k\| \ |/k\|l C
11055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11057 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11058 C energy moment and not to the cluster cumulant.
11059 cd write (2,*) 'eello_graph4: wturn6',wturn6
11060 iti=itype2loc(itype(i))
11061 itj=itype2loc(itype(j))
11062 if (j.lt.nres-1) then
11063 itj1=itype2loc(itype(j+1))
11067 itk=itype2loc(itype(k))
11068 if (k.lt.nres-1) then
11069 itk1=itype2loc(itype(k+1))
11073 itl=itype2loc(itype(l))
11074 if (l.lt.nres-1) then
11075 itl1=itype2loc(itype(l+1))
11079 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11080 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11081 cd & ' itl',itl,' itl1',itl1
11083 if (imat.eq.1) then
11084 s1=dip(3,jj,i)*dip(3,kk,k)
11086 s1=dip(2,jj,j)*dip(2,kk,l)
11089 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11090 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11092 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11093 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11095 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11096 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11098 call transpose2(EUg(1,1,k),auxmat(1,1))
11099 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11100 vv(1)=pizda(1,1)-pizda(2,2)
11101 vv(2)=pizda(2,1)+pizda(1,2)
11102 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11103 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11105 eello6_graph4=-(s1+s2+s3+s4)
11107 eello6_graph4=-(s2+s3+s4)
11109 C Derivatives in gamma(i-1)
11112 if (imat.eq.1) then
11113 s1=dipderg(2,jj,i)*dip(3,kk,k)
11115 s1=dipderg(4,jj,j)*dip(2,kk,l)
11118 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11120 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11121 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11123 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11124 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11126 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11127 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11128 cd write (2,*) 'turn6 derivatives'
11130 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11132 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11136 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11138 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11142 C Derivatives in gamma(k-1)
11144 if (imat.eq.1) then
11145 s1=dip(3,jj,i)*dipderg(2,kk,k)
11147 s1=dip(2,jj,j)*dipderg(4,kk,l)
11150 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11151 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11153 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11154 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11156 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11157 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11159 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11160 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11161 vv(1)=pizda(1,1)-pizda(2,2)
11162 vv(2)=pizda(2,1)+pizda(1,2)
11163 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11164 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11166 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11168 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11172 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11174 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11177 C Derivatives in gamma(j-1) or gamma(l-1)
11178 if (l.eq.j+1 .and. l.gt.1) then
11179 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11180 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11181 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11182 vv(1)=pizda(1,1)-pizda(2,2)
11183 vv(2)=pizda(2,1)+pizda(1,2)
11184 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11185 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11186 else if (j.gt.1) then
11187 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11188 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11189 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11190 vv(1)=pizda(1,1)-pizda(2,2)
11191 vv(2)=pizda(2,1)+pizda(1,2)
11192 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11193 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11194 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11196 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11199 C Cartesian derivatives.
11205 if (imat.eq.1) then
11206 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11208 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11211 if (imat.eq.1) then
11212 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11214 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11218 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11220 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11222 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11223 & b1(1,j+1),auxvec(1))
11224 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11226 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11227 & b1(1,l+1),auxvec(1))
11228 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11230 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11232 vv(1)=pizda(1,1)-pizda(2,2)
11233 vv(2)=pizda(2,1)+pizda(1,2)
11234 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11236 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11238 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11241 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11244 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11247 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11249 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11251 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11255 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11257 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11260 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11262 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11270 c----------------------------------------------------------------------------
11271 double precision function eello_turn6(i,jj,kk)
11272 implicit real*8 (a-h,o-z)
11273 include 'DIMENSIONS'
11274 include 'COMMON.IOUNITS'
11275 include 'COMMON.CHAIN'
11276 include 'COMMON.DERIV'
11277 include 'COMMON.INTERACT'
11278 include 'COMMON.CONTACTS'
11279 include 'COMMON.CONTMAT'
11280 include 'COMMON.CORRMAT'
11281 include 'COMMON.TORSION'
11282 include 'COMMON.VAR'
11283 include 'COMMON.GEO'
11284 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11285 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11287 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11288 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11289 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11290 C the respective energy moment and not to the cluster cumulant.
11299 iti=itype2loc(itype(i))
11300 itk=itype2loc(itype(k))
11301 itk1=itype2loc(itype(k+1))
11302 itl=itype2loc(itype(l))
11303 itj=itype2loc(itype(j))
11304 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11305 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11306 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11311 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11313 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11317 derx_turn(lll,kkk,iii)=0.0d0
11324 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11326 cd write (2,*) 'eello6_5',eello6_5
11328 call transpose2(AEA(1,1,1),auxmat(1,1))
11329 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11330 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11331 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11333 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11334 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11335 s2 = scalar2(b1(1,k),vtemp1(1))
11337 call transpose2(AEA(1,1,2),atemp(1,1))
11338 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11339 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11340 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11342 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11343 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11344 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11346 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11347 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11348 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11349 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11350 ss13 = scalar2(b1(1,k),vtemp4(1))
11351 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11353 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11359 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11360 C Derivatives in gamma(i+2)
11364 call transpose2(AEA(1,1,1),auxmatd(1,1))
11365 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11366 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11367 call transpose2(AEAderg(1,1,2),atempd(1,1))
11368 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11369 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11371 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11372 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11373 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11379 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11380 C Derivatives in gamma(i+3)
11382 call transpose2(AEA(1,1,1),auxmatd(1,1))
11383 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11384 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11385 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11387 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11388 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11389 s2d = scalar2(b1(1,k),vtemp1d(1))
11391 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11392 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11394 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11396 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11397 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11398 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11406 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11407 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11409 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11410 & -0.5d0*ekont*(s2d+s12d)
11412 C Derivatives in gamma(i+4)
11413 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11414 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11415 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11417 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11418 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11419 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11427 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11429 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11431 C Derivatives in gamma(i+5)
11433 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11434 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11435 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11437 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11438 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11439 s2d = scalar2(b1(1,k),vtemp1d(1))
11441 call transpose2(AEA(1,1,2),atempd(1,1))
11442 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11443 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11445 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11446 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11448 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11449 ss13d = scalar2(b1(1,k),vtemp4d(1))
11450 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11458 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11459 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11461 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11462 & -0.5d0*ekont*(s2d+s12d)
11464 C Cartesian derivatives
11469 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11470 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11471 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11473 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11474 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11476 s2d = scalar2(b1(1,k),vtemp1d(1))
11478 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11479 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11480 s8d = -(atempd(1,1)+atempd(2,2))*
11481 & scalar2(cc(1,1,l),vtemp2(1))
11483 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11485 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11486 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11493 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11494 & - 0.5d0*(s1d+s2d)
11496 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11500 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11501 & - 0.5d0*(s8d+s12d)
11503 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11512 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11513 & achuj_tempd(1,1))
11514 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11515 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11516 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11517 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11518 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11520 ss13d = scalar2(b1(1,k),vtemp4d(1))
11521 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11522 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11526 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11527 cd & 16*eel_turn6_num
11529 if (j.lt.nres-1) then
11536 if (l.lt.nres-1) then
11544 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11545 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11546 cgrad ghalf=0.5d0*ggg1(ll)
11548 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11549 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11550 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11551 & +ekont*derx_turn(ll,2,1)
11552 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11553 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11554 & +ekont*derx_turn(ll,4,1)
11555 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11556 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11557 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11558 cgrad ghalf=0.5d0*ggg2(ll)
11560 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11561 & +ekont*derx_turn(ll,2,2)
11562 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11563 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11564 & +ekont*derx_turn(ll,4,2)
11565 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11566 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11567 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11572 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11577 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11583 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11588 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11592 cd write (2,*) iii,g_corr6_loc(iii)
11594 eello_turn6=ekont*eel_turn6
11595 cd write (2,*) 'ekont',ekont
11596 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11599 C-----------------------------------------------------------------------------
11601 double precision function scalar(u,v)
11602 !DIR$ INLINEALWAYS scalar
11604 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11607 double precision u(3),v(3)
11608 cd double precision sc
11616 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11619 crc-------------------------------------------------
11620 SUBROUTINE MATVEC2(A1,V1,V2)
11621 !DIR$ INLINEALWAYS MATVEC2
11623 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11625 implicit real*8 (a-h,o-z)
11626 include 'DIMENSIONS'
11627 DIMENSION A1(2,2),V1(2),V2(2)
11631 c 3 VI=VI+A1(I,K)*V1(K)
11635 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11636 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11641 C---------------------------------------
11642 SUBROUTINE MATMAT2(A1,A2,A3)
11644 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11646 implicit real*8 (a-h,o-z)
11647 include 'DIMENSIONS'
11648 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11649 c DIMENSION AI3(2,2)
11653 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11659 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11660 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11661 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11662 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11670 c-------------------------------------------------------------------------
11671 double precision function scalar2(u,v)
11672 !DIR$ INLINEALWAYS scalar2
11674 double precision u(2),v(2)
11675 double precision sc
11677 scalar2=u(1)*v(1)+u(2)*v(2)
11681 C-----------------------------------------------------------------------------
11683 subroutine transpose2(a,at)
11684 !DIR$ INLINEALWAYS transpose2
11686 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11689 double precision a(2,2),at(2,2)
11696 c--------------------------------------------------------------------------
11697 subroutine transpose(n,a,at)
11700 double precision a(n,n),at(n,n)
11708 C---------------------------------------------------------------------------
11709 subroutine prodmat3(a1,a2,kk,transp,prod)
11710 !DIR$ INLINEALWAYS prodmat3
11712 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11716 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11718 crc double precision auxmat(2,2),prod_(2,2)
11721 crc call transpose2(kk(1,1),auxmat(1,1))
11722 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11723 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11725 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11726 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11727 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11728 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11729 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11730 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11731 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11732 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11735 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11736 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11738 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11739 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11740 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11741 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11742 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11743 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11744 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11745 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11748 c call transpose2(a2(1,1),a2t(1,1))
11751 crc print *,((prod_(i,j),i=1,2),j=1,2)
11752 crc print *,((prod(i,j),i=1,2),j=1,2)
11756 CCC----------------------------------------------
11757 subroutine Eliptransfer(eliptran)
11758 implicit real*8 (a-h,o-z)
11759 include 'DIMENSIONS'
11760 include 'COMMON.GEO'
11761 include 'COMMON.VAR'
11762 include 'COMMON.LOCAL'
11763 include 'COMMON.CHAIN'
11764 include 'COMMON.DERIV'
11765 include 'COMMON.NAMES'
11766 include 'COMMON.INTERACT'
11767 include 'COMMON.IOUNITS'
11768 include 'COMMON.CALC'
11769 include 'COMMON.CONTROL'
11770 include 'COMMON.SPLITELE'
11771 include 'COMMON.SBRIDGE'
11772 C this is done by Adasko
11773 C print *,"wchodze"
11774 C structure of box:
11776 C--bordliptop-- buffore starts
11777 C--bufliptop--- here true lipid starts
11779 C--buflipbot--- lipid ends buffore starts
11780 C--bordlipbot--buffore ends
11782 do i=ilip_start,ilip_end
11784 if (itype(i).eq.ntyp1) cycle
11786 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11787 if (positi.le.0.0) positi=positi+boxzsize
11789 C first for peptide groups
11790 c for each residue check if it is in lipid or lipid water border area
11791 if ((positi.gt.bordlipbot)
11792 &.and.(positi.lt.bordliptop)) then
11793 C the energy transfer exist
11794 if (positi.lt.buflipbot) then
11795 C what fraction I am in
11797 & ((positi-bordlipbot)/lipbufthick)
11798 C lipbufthick is thickenes of lipid buffore
11799 sslip=sscalelip(fracinbuf)
11800 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11801 eliptran=eliptran+sslip*pepliptran
11802 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11803 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11804 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11806 C print *,"doing sccale for lower part"
11807 C print *,i,sslip,fracinbuf,ssgradlip
11808 elseif (positi.gt.bufliptop) then
11809 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11810 sslip=sscalelip(fracinbuf)
11811 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11812 eliptran=eliptran+sslip*pepliptran
11813 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11814 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11815 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11816 C print *, "doing sscalefor top part"
11817 C print *,i,sslip,fracinbuf,ssgradlip
11819 eliptran=eliptran+pepliptran
11820 C print *,"I am in true lipid"
11823 C eliptran=elpitran+0.0 ! I am in water
11826 C print *, "nic nie bylo w lipidzie?"
11827 C now multiply all by the peptide group transfer factor
11828 C eliptran=eliptran*pepliptran
11829 C now the same for side chains
11831 do i=ilip_start,ilip_end
11832 if (itype(i).eq.ntyp1) cycle
11833 positi=(mod(c(3,i+nres),boxzsize))
11834 if (positi.le.0) positi=positi+boxzsize
11835 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11836 c for each residue check if it is in lipid or lipid water border area
11837 C respos=mod(c(3,i+nres),boxzsize)
11838 C print *,positi,bordlipbot,buflipbot
11839 if ((positi.gt.bordlipbot)
11840 & .and.(positi.lt.bordliptop)) then
11841 C the energy transfer exist
11842 if (positi.lt.buflipbot) then
11844 & ((positi-bordlipbot)/lipbufthick)
11845 C lipbufthick is thickenes of lipid buffore
11846 sslip=sscalelip(fracinbuf)
11847 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11848 eliptran=eliptran+sslip*liptranene(itype(i))
11849 gliptranx(3,i)=gliptranx(3,i)
11850 &+ssgradlip*liptranene(itype(i))
11851 gliptranc(3,i-1)= gliptranc(3,i-1)
11852 &+ssgradlip*liptranene(itype(i))
11853 C print *,"doing sccale for lower part"
11854 elseif (positi.gt.bufliptop) then
11856 &((bordliptop-positi)/lipbufthick)
11857 sslip=sscalelip(fracinbuf)
11858 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11859 eliptran=eliptran+sslip*liptranene(itype(i))
11860 gliptranx(3,i)=gliptranx(3,i)
11861 &+ssgradlip*liptranene(itype(i))
11862 gliptranc(3,i-1)= gliptranc(3,i-1)
11863 &+ssgradlip*liptranene(itype(i))
11864 C print *, "doing sscalefor top part",sslip,fracinbuf
11866 eliptran=eliptran+liptranene(itype(i))
11867 C print *,"I am in true lipid"
11869 endif ! if in lipid or buffor
11871 C eliptran=elpitran+0.0 ! I am in water
11875 C---------------------------------------------------------
11876 C AFM soubroutine for constant force
11877 subroutine AFMforce(Eafmforce)
11878 implicit real*8 (a-h,o-z)
11879 include 'DIMENSIONS'
11880 include 'COMMON.GEO'
11881 include 'COMMON.VAR'
11882 include 'COMMON.LOCAL'
11883 include 'COMMON.CHAIN'
11884 include 'COMMON.DERIV'
11885 include 'COMMON.NAMES'
11886 include 'COMMON.INTERACT'
11887 include 'COMMON.IOUNITS'
11888 include 'COMMON.CALC'
11889 include 'COMMON.CONTROL'
11890 include 'COMMON.SPLITELE'
11891 include 'COMMON.SBRIDGE'
11896 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11897 dist=dist+diffafm(i)**2
11900 Eafmforce=-forceAFMconst*(dist-distafminit)
11902 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11903 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11905 C print *,'AFM',Eafmforce
11908 C---------------------------------------------------------
11909 C AFM subroutine with pseudoconstant velocity
11910 subroutine AFMvel(Eafmforce)
11911 implicit real*8 (a-h,o-z)
11912 include 'DIMENSIONS'
11913 include 'COMMON.GEO'
11914 include 'COMMON.VAR'
11915 include 'COMMON.LOCAL'
11916 include 'COMMON.CHAIN'
11917 include 'COMMON.DERIV'
11918 include 'COMMON.NAMES'
11919 include 'COMMON.INTERACT'
11920 include 'COMMON.IOUNITS'
11921 include 'COMMON.CALC'
11922 include 'COMMON.CONTROL'
11923 include 'COMMON.SPLITELE'
11924 include 'COMMON.SBRIDGE'
11926 C Only for check grad COMMENT if not used for checkgrad
11928 C--------------------------------------------------------
11929 C print *,"wchodze"
11933 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11934 dist=dist+diffafm(i)**2
11937 Eafmforce=0.5d0*forceAFMconst
11938 & *(distafminit+totTafm*velAFMconst-dist)**2
11939 C Eafmforce=-forceAFMconst*(dist-distafminit)
11941 gradafm(i,afmend-1)=-forceAFMconst*
11942 &(distafminit+totTafm*velAFMconst-dist)
11944 gradafm(i,afmbeg-1)=forceAFMconst*
11945 &(distafminit+totTafm*velAFMconst-dist)
11948 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11951 C-----------------------------------------------------------
11952 C first for shielding is setting of function of side-chains
11953 subroutine set_shield_fac
11954 implicit real*8 (a-h,o-z)
11955 include 'DIMENSIONS'
11956 include 'COMMON.CHAIN'
11957 include 'COMMON.DERIV'
11958 include 'COMMON.IOUNITS'
11959 include 'COMMON.SHIELD'
11960 include 'COMMON.INTERACT'
11961 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11962 double precision div77_81/0.974996043d0/,
11963 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11965 C the vector between center of side_chain and peptide group
11966 double precision pep_side(3),long,side_calf(3),
11967 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11968 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11969 C the line belowe needs to be changed for FGPROC>1
11971 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11973 Cif there two consequtive dummy atoms there is no peptide group between them
11974 C the line below has to be changed for FGPROC>1
11977 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11981 C first lets set vector conecting the ithe side-chain with kth side-chain
11982 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11983 C pep_side(j)=2.0d0
11984 C and vector conecting the side-chain with its proper calfa
11985 side_calf(j)=c(j,k+nres)-c(j,k)
11986 C side_calf(j)=2.0d0
11987 pept_group(j)=c(j,i)-c(j,i+1)
11988 C lets have their lenght
11989 dist_pep_side=pep_side(j)**2+dist_pep_side
11990 dist_side_calf=dist_side_calf+side_calf(j)**2
11991 dist_pept_group=dist_pept_group+pept_group(j)**2
11993 dist_pep_side=dsqrt(dist_pep_side)
11994 dist_pept_group=dsqrt(dist_pept_group)
11995 dist_side_calf=dsqrt(dist_side_calf)
11997 pep_side_norm(j)=pep_side(j)/dist_pep_side
11998 side_calf_norm(j)=dist_side_calf
12000 C now sscale fraction
12001 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12002 C print *,buff_shield,"buff"
12004 if (sh_frac_dist.le.0.0) cycle
12005 C If we reach here it means that this side chain reaches the shielding sphere
12006 C Lets add him to the list for gradient
12007 ishield_list(i)=ishield_list(i)+1
12008 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12009 C this list is essential otherwise problem would be O3
12010 shield_list(ishield_list(i),i)=k
12011 C Lets have the sscale value
12012 if (sh_frac_dist.gt.1.0) then
12013 scale_fac_dist=1.0d0
12015 sh_frac_dist_grad(j)=0.0d0
12018 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12019 & *(2.0*sh_frac_dist-3.0d0)
12020 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12021 & /dist_pep_side/buff_shield*0.5
12022 C remember for the final gradient multiply sh_frac_dist_grad(j)
12023 C for side_chain by factor -2 !
12025 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12026 C print *,"jestem",scale_fac_dist,fac_help_scale,
12027 C & sh_frac_dist_grad(j)
12030 C if ((i.eq.3).and.(k.eq.2)) then
12031 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12035 C this is what is now we have the distance scaling now volume...
12036 short=short_r_sidechain(itype(k))
12037 long=long_r_sidechain(itype(k))
12038 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12041 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12042 C costhet_fac=0.0d0
12044 costhet_grad(j)=costhet_fac*pep_side(j)
12046 C remember for the final gradient multiply costhet_grad(j)
12047 C for side_chain by factor -2 !
12048 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12049 C pep_side0pept_group is vector multiplication
12050 pep_side0pept_group=0.0
12052 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12054 cosalfa=(pep_side0pept_group/
12055 & (dist_pep_side*dist_side_calf))
12056 fac_alfa_sin=1.0-cosalfa**2
12057 fac_alfa_sin=dsqrt(fac_alfa_sin)
12058 rkprim=fac_alfa_sin*(long-short)+short
12060 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12061 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12064 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12065 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12066 &*(long-short)/fac_alfa_sin*cosalfa/
12067 &((dist_pep_side*dist_side_calf))*
12068 &((side_calf(j))-cosalfa*
12069 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12071 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12072 &*(long-short)/fac_alfa_sin*cosalfa
12073 &/((dist_pep_side*dist_side_calf))*
12075 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12078 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12081 C now the gradient...
12082 C grad_shield is gradient of Calfa for peptide groups
12083 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12085 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12086 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12088 grad_shield(j,i)=grad_shield(j,i)
12089 C gradient po skalowaniu
12090 & +(sh_frac_dist_grad(j)
12091 C gradient po costhet
12092 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12093 &-scale_fac_dist*(cosphi_grad_long(j))
12094 &/(1.0-cosphi) )*div77_81
12096 C grad_shield_side is Cbeta sidechain gradient
12097 grad_shield_side(j,ishield_list(i),i)=
12098 & (sh_frac_dist_grad(j)*(-2.0d0)
12099 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12100 & +scale_fac_dist*(cosphi_grad_long(j))
12101 & *2.0d0/(1.0-cosphi))
12102 & *div77_81*VofOverlap
12104 grad_shield_loc(j,ishield_list(i),i)=
12105 & scale_fac_dist*cosphi_grad_loc(j)
12106 & *2.0d0/(1.0-cosphi)
12107 & *div77_81*VofOverlap
12109 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12111 fac_shield(i)=VolumeTotal*div77_81+div4_81
12112 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12116 C--------------------------------------------------------------------------
12117 double precision function tschebyshev(m,n,x,y)
12119 include "DIMENSIONS"
12121 double precision x(n),y,yy(0:maxvar),aux
12122 c Tschebyshev polynomial. Note that the first term is omitted
12123 c m=0: the constant term is included
12124 c m=1: the constant term is not included
12128 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12137 C--------------------------------------------------------------------------
12138 double precision function gradtschebyshev(m,n,x,y)
12140 include "DIMENSIONS"
12142 double precision x(n+1),y,yy(0:maxvar),aux
12143 c Tschebyshev polynomial. Note that the first term is omitted
12144 c m=0: the constant term is included
12145 c m=1: the constant term is not included
12149 yy(i)=2*y*yy(i-1)-yy(i-2)
12153 aux=aux+x(i+1)*yy(i)*(i+1)
12154 C print *, x(i+1),yy(i),i
12156 gradtschebyshev=aux
12159 C------------------------------------------------------------------------
12160 C first for shielding is setting of function of side-chains
12161 subroutine set_shield_fac2
12162 implicit real*8 (a-h,o-z)
12163 include 'DIMENSIONS'
12164 include 'COMMON.CHAIN'
12165 include 'COMMON.DERIV'
12166 include 'COMMON.IOUNITS'
12167 include 'COMMON.SHIELD'
12168 include 'COMMON.INTERACT'
12169 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12170 double precision div77_81/0.974996043d0/,
12171 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12173 C the vector between center of side_chain and peptide group
12174 double precision pep_side(3),long,side_calf(3),
12175 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12176 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12177 C the line belowe needs to be changed for FGPROC>1
12179 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12181 Cif there two consequtive dummy atoms there is no peptide group between them
12182 C the line below has to be changed for FGPROC>1
12185 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12189 C first lets set vector conecting the ithe side-chain with kth side-chain
12190 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12191 C pep_side(j)=2.0d0
12192 C and vector conecting the side-chain with its proper calfa
12193 side_calf(j)=c(j,k+nres)-c(j,k)
12194 C side_calf(j)=2.0d0
12195 pept_group(j)=c(j,i)-c(j,i+1)
12196 C lets have their lenght
12197 dist_pep_side=pep_side(j)**2+dist_pep_side
12198 dist_side_calf=dist_side_calf+side_calf(j)**2
12199 dist_pept_group=dist_pept_group+pept_group(j)**2
12201 dist_pep_side=dsqrt(dist_pep_side)
12202 dist_pept_group=dsqrt(dist_pept_group)
12203 dist_side_calf=dsqrt(dist_side_calf)
12205 pep_side_norm(j)=pep_side(j)/dist_pep_side
12206 side_calf_norm(j)=dist_side_calf
12208 C now sscale fraction
12209 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12210 C print *,buff_shield,"buff"
12212 if (sh_frac_dist.le.0.0) cycle
12213 C If we reach here it means that this side chain reaches the shielding sphere
12214 C Lets add him to the list for gradient
12215 ishield_list(i)=ishield_list(i)+1
12216 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12217 C this list is essential otherwise problem would be O3
12218 shield_list(ishield_list(i),i)=k
12219 C Lets have the sscale value
12220 if (sh_frac_dist.gt.1.0) then
12221 scale_fac_dist=1.0d0
12223 sh_frac_dist_grad(j)=0.0d0
12226 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12227 & *(2.0d0*sh_frac_dist-3.0d0)
12228 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12229 & /dist_pep_side/buff_shield*0.5d0
12230 C remember for the final gradient multiply sh_frac_dist_grad(j)
12231 C for side_chain by factor -2 !
12233 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12234 C sh_frac_dist_grad(j)=0.0d0
12235 C scale_fac_dist=1.0d0
12236 C print *,"jestem",scale_fac_dist,fac_help_scale,
12237 C & sh_frac_dist_grad(j)
12240 C this is what is now we have the distance scaling now volume...
12241 short=short_r_sidechain(itype(k))
12242 long=long_r_sidechain(itype(k))
12243 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12244 sinthet=short/dist_pep_side*costhet
12248 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12249 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12250 C & -short/dist_pep_side**2/costhet)
12251 C costhet_fac=0.0d0
12253 costhet_grad(j)=costhet_fac*pep_side(j)
12255 C remember for the final gradient multiply costhet_grad(j)
12256 C for side_chain by factor -2 !
12257 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12258 C pep_side0pept_group is vector multiplication
12259 pep_side0pept_group=0.0d0
12261 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12263 cosalfa=(pep_side0pept_group/
12264 & (dist_pep_side*dist_side_calf))
12265 fac_alfa_sin=1.0d0-cosalfa**2
12266 fac_alfa_sin=dsqrt(fac_alfa_sin)
12267 rkprim=fac_alfa_sin*(long-short)+short
12271 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12273 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12274 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12275 & dist_pep_side**2)
12278 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12279 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12280 &*(long-short)/fac_alfa_sin*cosalfa/
12281 &((dist_pep_side*dist_side_calf))*
12282 &((side_calf(j))-cosalfa*
12283 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12284 C cosphi_grad_long(j)=0.0d0
12285 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12286 &*(long-short)/fac_alfa_sin*cosalfa
12287 &/((dist_pep_side*dist_side_calf))*
12289 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12290 C cosphi_grad_loc(j)=0.0d0
12292 C print *,sinphi,sinthet
12293 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12294 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12295 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12298 C now the gradient...
12300 grad_shield(j,i)=grad_shield(j,i)
12301 C gradient po skalowaniu
12302 & +(sh_frac_dist_grad(j)*VofOverlap
12303 C gradient po costhet
12304 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12305 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12306 & sinphi/sinthet*costhet*costhet_grad(j)
12307 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12309 C grad_shield_side is Cbeta sidechain gradient
12310 grad_shield_side(j,ishield_list(i),i)=
12311 & (sh_frac_dist_grad(j)*(-2.0d0)
12313 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12314 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12315 & sinphi/sinthet*costhet*costhet_grad(j)
12316 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12319 grad_shield_loc(j,ishield_list(i),i)=
12320 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12321 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12322 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12326 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12328 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12330 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12331 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12332 c & " wshield",wshield
12333 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12337 C-----------------------------------------------------------------------
12338 C-----------------------------------------------------------
12339 C This subroutine is to mimic the histone like structure but as well can be
12340 C utilizet to nanostructures (infinit) small modification has to be used to
12341 C make it finite (z gradient at the ends has to be changes as well as the x,y
12342 C gradient has to be modified at the ends
12343 C The energy function is Kihara potential
12344 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12345 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12346 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12347 C simple Kihara potential
12348 subroutine calctube(Etube)
12349 implicit real*8 (a-h,o-z)
12350 include 'DIMENSIONS'
12351 include 'COMMON.GEO'
12352 include 'COMMON.VAR'
12353 include 'COMMON.LOCAL'
12354 include 'COMMON.CHAIN'
12355 include 'COMMON.DERIV'
12356 include 'COMMON.NAMES'
12357 include 'COMMON.INTERACT'
12358 include 'COMMON.IOUNITS'
12359 include 'COMMON.CALC'
12360 include 'COMMON.CONTROL'
12361 include 'COMMON.SPLITELE'
12362 include 'COMMON.SBRIDGE'
12363 double precision tub_r,vectube(3),enetube(maxres*2)
12368 C first we calculate the distance from tube center
12369 C first sugare-phosphate group for NARES this would be peptide group
12372 C lets ommit dummy atoms for now
12373 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12374 C now calculate distance from center of tube and direction vectors
12375 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12376 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12377 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12378 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12379 vectube(1)=vectube(1)-tubecenter(1)
12380 vectube(2)=vectube(2)-tubecenter(2)
12382 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12383 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12385 C as the tube is infinity we do not calculate the Z-vector use of Z
12388 C now calculte the distance
12389 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12390 C now normalize vector
12391 vectube(1)=vectube(1)/tub_r
12392 vectube(2)=vectube(2)/tub_r
12393 C calculte rdiffrence between r and r0
12396 rdiff6=rdiff**6.0d0
12397 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12398 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12399 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12400 C print *,rdiff,rdiff6,pep_aa_tube
12401 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12402 C now we calculate gradient
12403 fac=(-12.0d0*pep_aa_tube/rdiff6+
12404 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12405 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12408 C now direction of gg_tube vector
12410 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12411 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12414 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12416 C Lets not jump over memory as we use many times iti
12418 C lets ommit dummy atoms for now
12420 C in UNRES uncomment the line below as GLY has no side-chain...
12423 vectube(1)=c(1,i+nres)
12424 vectube(1)=mod(vectube(1),boxxsize)
12425 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12426 vectube(2)=c(2,i+nres)
12427 vectube(2)=mod(vectube(2),boxxsize)
12428 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12430 vectube(1)=vectube(1)-tubecenter(1)
12431 vectube(2)=vectube(2)-tubecenter(2)
12433 C as the tube is infinity we do not calculate the Z-vector use of Z
12436 C now calculte the distance
12437 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12438 C now normalize vector
12439 vectube(1)=vectube(1)/tub_r
12440 vectube(2)=vectube(2)/tub_r
12441 C calculte rdiffrence between r and r0
12444 rdiff6=rdiff**6.0d0
12445 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12446 sc_aa_tube=sc_aa_tube_par(iti)
12447 sc_bb_tube=sc_bb_tube_par(iti)
12448 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12449 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12450 C now we calculate gradient
12451 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12452 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12453 C now direction of gg_tube vector
12455 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12456 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12460 Etube=Etube+enetube(i)
12462 C print *,"ETUBE", etube
12465 C TO DO 1) add to total energy
12466 C 2) add to gradient summation
12467 C 3) add reading parameters (AND of course oppening of PARAM file)
12468 C 4) add reading the center of tube
12470 C 6) add to zerograd
12472 C-----------------------------------------------------------------------
12473 C-----------------------------------------------------------
12474 C This subroutine is to mimic the histone like structure but as well can be
12475 C utilizet to nanostructures (infinit) small modification has to be used to
12476 C make it finite (z gradient at the ends has to be changes as well as the x,y
12477 C gradient has to be modified at the ends
12478 C The energy function is Kihara potential
12479 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12480 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12481 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12482 C simple Kihara potential
12483 subroutine calctube2(Etube)
12484 implicit real*8 (a-h,o-z)
12485 include 'DIMENSIONS'
12486 include 'COMMON.GEO'
12487 include 'COMMON.VAR'
12488 include 'COMMON.LOCAL'
12489 include 'COMMON.CHAIN'
12490 include 'COMMON.DERIV'
12491 include 'COMMON.NAMES'
12492 include 'COMMON.INTERACT'
12493 include 'COMMON.IOUNITS'
12494 include 'COMMON.CALC'
12495 include 'COMMON.CONTROL'
12496 include 'COMMON.SPLITELE'
12497 include 'COMMON.SBRIDGE'
12498 double precision tub_r,vectube(3),enetube(maxres*2)
12503 C first we calculate the distance from tube center
12504 C first sugare-phosphate group for NARES this would be peptide group
12507 C lets ommit dummy atoms for now
12508 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12509 C now calculate distance from center of tube and direction vectors
12510 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12511 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12512 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12513 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12514 vectube(1)=vectube(1)-tubecenter(1)
12515 vectube(2)=vectube(2)-tubecenter(2)
12517 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12518 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12520 C as the tube is infinity we do not calculate the Z-vector use of Z
12523 C now calculte the distance
12524 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12525 C now normalize vector
12526 vectube(1)=vectube(1)/tub_r
12527 vectube(2)=vectube(2)/tub_r
12528 C calculte rdiffrence between r and r0
12531 rdiff6=rdiff**6.0d0
12532 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12533 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12534 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12535 C print *,rdiff,rdiff6,pep_aa_tube
12536 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12537 C now we calculate gradient
12538 fac=(-12.0d0*pep_aa_tube/rdiff6+
12539 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12540 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12543 C now direction of gg_tube vector
12545 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12546 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12549 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12551 C Lets not jump over memory as we use many times iti
12553 C lets ommit dummy atoms for now
12555 C in UNRES uncomment the line below as GLY has no side-chain...
12558 vectube(1)=c(1,i+nres)
12559 vectube(1)=mod(vectube(1),boxxsize)
12560 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12561 vectube(2)=c(2,i+nres)
12562 vectube(2)=mod(vectube(2),boxxsize)
12563 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12565 vectube(1)=vectube(1)-tubecenter(1)
12566 vectube(2)=vectube(2)-tubecenter(2)
12567 C THIS FRAGMENT MAKES TUBE FINITE
12568 positi=(mod(c(3,i+nres),boxzsize))
12569 if (positi.le.0) positi=positi+boxzsize
12570 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12571 c for each residue check if it is in lipid or lipid water border area
12572 C respos=mod(c(3,i+nres),boxzsize)
12573 print *,positi,bordtubebot,buftubebot,bordtubetop
12574 if ((positi.gt.bordtubebot)
12575 & .and.(positi.lt.bordtubetop)) then
12576 C the energy transfer exist
12577 if (positi.lt.buftubebot) then
12579 & ((positi-bordtubebot)/tubebufthick)
12580 C lipbufthick is thickenes of lipid buffore
12581 sstube=sscalelip(fracinbuf)
12582 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12583 print *,ssgradtube, sstube,tubetranene(itype(i))
12584 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12585 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12586 &+ssgradtube*tubetranene(itype(i))
12587 gg_tube(3,i-1)= gg_tube(3,i-1)
12588 &+ssgradtube*tubetranene(itype(i))
12589 C print *,"doing sccale for lower part"
12590 elseif (positi.gt.buftubetop) then
12592 &((bordtubetop-positi)/tubebufthick)
12593 sstube=sscalelip(fracinbuf)
12594 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12595 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12596 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12597 C &+ssgradtube*tubetranene(itype(i))
12598 C gg_tube(3,i-1)= gg_tube(3,i-1)
12599 C &+ssgradtube*tubetranene(itype(i))
12600 C print *, "doing sscalefor top part",sslip,fracinbuf
12604 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12605 C print *,"I am in true lipid"
12611 endif ! if in lipid or buffor
12612 CEND OF FINITE FRAGMENT
12613 C as the tube is infinity we do not calculate the Z-vector use of Z
12616 C now calculte the distance
12617 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12618 C now normalize vector
12619 vectube(1)=vectube(1)/tub_r
12620 vectube(2)=vectube(2)/tub_r
12621 C calculte rdiffrence between r and r0
12624 rdiff6=rdiff**6.0d0
12625 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12626 sc_aa_tube=sc_aa_tube_par(iti)
12627 sc_bb_tube=sc_bb_tube_par(iti)
12628 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12629 & *sstube+enetube(i+nres)
12630 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12631 C now we calculate gradient
12632 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12633 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12634 C now direction of gg_tube vector
12636 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12637 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12639 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12640 &+ssgradtube*enetube(i+nres)/sstube
12641 gg_tube(3,i-1)= gg_tube(3,i-1)
12642 &+ssgradtube*enetube(i+nres)/sstube
12646 Etube=Etube+enetube(i)
12648 C print *,"ETUBE", etube
12651 C TO DO 1) add to total energy
12652 C 2) add to gradient summation
12653 C 3) add reading parameters (AND of course oppening of PARAM file)
12654 C 4) add reading the center of tube
12656 C 6) add to zerograd
12657 c----------------------------------------------------------------------------
12658 subroutine e_saxs(Esaxs_constr)
12660 include 'DIMENSIONS'
12663 include "COMMON.SETUP"
12666 include 'COMMON.SBRIDGE'
12667 include 'COMMON.CHAIN'
12668 include 'COMMON.GEO'
12669 include 'COMMON.DERIV'
12670 include 'COMMON.LOCAL'
12671 include 'COMMON.INTERACT'
12672 include 'COMMON.VAR'
12673 include 'COMMON.IOUNITS'
12674 c include 'COMMON.MD'
12677 include 'COMMON.LANGEVIN.lang0.5diag'
12679 include 'COMMON.LANGEVIN.lang0'
12682 include 'COMMON.LANGEVIN'
12684 include 'COMMON.CONTROL'
12685 include 'COMMON.SAXS'
12686 include 'COMMON.NAMES'
12687 include 'COMMON.TIME1'
12688 include 'COMMON.FFIELD'
12690 double precision Esaxs_constr
12691 integer i,iint,j,k,l
12692 double precision PgradC(maxSAXS,3,maxres),
12693 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12695 double precision PgradC_(maxSAXS,3,maxres),
12696 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12698 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12699 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12700 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12701 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12702 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12703 double precision dist,mygauss,mygaussder
12705 integer llicz,lllicz
12706 double precision time01
12707 c SAXS restraint penalty function
12709 write(iout,*) "------- SAXS penalty function start -------"
12710 write (iout,*) "nsaxs",nsaxs
12711 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12712 write (iout,*) "Psaxs"
12714 write (iout,'(i5,e15.5)') i, Psaxs(i)
12720 Esaxs_constr = 0.0d0
12725 PgradC(k,l,j)=0.0d0
12726 PgradX(k,l,j)=0.0d0
12731 do i=iatsc_s,iatsc_e
12732 if (itype(i).eq.ntyp1) cycle
12733 do iint=1,nint_gr(i)
12734 do j=istart(i,iint),iend(i,iint)
12735 if (itype(j).eq.ntyp1) cycle
12738 dijCASC=dist(i,j+nres)
12739 dijSCCA=dist(i+nres,j)
12740 dijSCSC=dist(i+nres,j+nres)
12741 sigma2CACA=2.0d0/(pstok**2)
12742 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12743 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12744 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12747 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12748 if (itype(j).ne.10) then
12749 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12753 if (itype(i).ne.10) then
12754 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12758 if (itype(i).ne.10 .and. itype(j).ne.10) then
12759 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12763 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12765 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12767 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12768 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12769 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12770 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12773 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12774 PgradC(k,l,i) = PgradC(k,l,i)-aux
12775 PgradC(k,l,j) = PgradC(k,l,j)+aux
12777 if (itype(j).ne.10) then
12778 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12779 PgradC(k,l,i) = PgradC(k,l,i)-aux
12780 PgradC(k,l,j) = PgradC(k,l,j)+aux
12781 PgradX(k,l,j) = PgradX(k,l,j)+aux
12784 if (itype(i).ne.10) then
12785 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12786 PgradX(k,l,i) = PgradX(k,l,i)-aux
12787 PgradC(k,l,i) = PgradC(k,l,i)-aux
12788 PgradC(k,l,j) = PgradC(k,l,j)+aux
12791 if (itype(i).ne.10 .and. itype(j).ne.10) then
12792 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12793 PgradC(k,l,i) = PgradC(k,l,i)-aux
12794 PgradC(k,l,j) = PgradC(k,l,j)+aux
12795 PgradX(k,l,i) = PgradX(k,l,i)-aux
12796 PgradX(k,l,j) = PgradX(k,l,j)+aux
12802 sigma2CACA=scal_rad**2*0.25d0/
12803 & (restok(itype(j))**2+restok(itype(i))**2)
12804 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12805 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12807 sigmaCACA=dsqrt(sigma2CACA)
12808 threesig=3.0d0/sigmaCACA
12812 if (dabs(dijCACA-dk).ge.threesig) cycle
12815 aux = sigmaCACA*(dijCACA-dk)
12816 expCACA = mygauss(aux)
12817 c if (expcaca.eq.0.0d0) cycle
12818 Pcalc(k) = Pcalc(k)+expCACA
12819 CACAgrad = -sigmaCACA*mygaussder(aux)
12820 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12822 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12823 PgradC(k,l,i) = PgradC(k,l,i)-aux
12824 PgradC(k,l,j) = PgradC(k,l,j)+aux
12827 c write (iout,*) "i",i," j",j," llicz",llicz
12829 IF (saxs_cutoff.eq.0) THEN
12832 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12833 Pcalc(k) = Pcalc(k)+expCACA
12834 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12836 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12837 PgradC(k,l,i) = PgradC(k,l,i)-aux
12838 PgradC(k,l,j) = PgradC(k,l,j)+aux
12842 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12845 c write (2,*) "ijk",i,j,k
12846 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12847 if (sss2.eq.0.0d0) cycle
12848 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12849 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12850 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12851 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
12853 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12854 Pcalc(k) = Pcalc(k)+expCACA
12856 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12858 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12859 & ssgrad2*expCACA/sss2
12862 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12863 PgradC(k,l,i) = PgradC(k,l,i)+aux
12864 PgradC(k,l,j) = PgradC(k,l,j)-aux
12874 c time_SAXS=time_SAXS+MPI_Wtime()-time01
12876 c write (iout,*) "lllicz",lllicz
12878 c time01=MPI_Wtime()
12881 if (nfgtasks.gt.1) then
12882 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12883 & MPI_SUM,FG_COMM,IERR)
12884 c if (fg_rank.eq.king) then
12886 Pcalc(k) = Pcalc_(k)
12889 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12890 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12891 c if (fg_rank.eq.king) then
12895 c PgradC(k,l,i) = PgradC_(k,l,i)
12901 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12902 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12903 c if (fg_rank.eq.king) then
12907 c PgradX(k,l,i) = PgradX_(k,l,i)
12917 Cnorm = Cnorm + Pcalc(k)
12920 if (fg_rank.eq.king) then
12922 Esaxs_constr = dlog(Cnorm)-wsaxs0
12924 if (Pcalc(k).gt.0.0d0)
12925 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12927 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12931 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12946 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12947 auxC1 = auxC1+PgradC(k,l,i)
12949 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12950 auxX1 = auxX1+PgradX(k,l,i)
12953 gsaxsC(l,i) = auxC - auxC1/Cnorm
12955 gsaxsX(l,i) = auxX - auxX1/Cnorm
12957 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12958 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
12959 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12960 c * " gradX",wsaxs*gsaxsX(l,i)
12964 time_SAXS=time_SAXS+MPI_Wtime()-time01
12967 write (iout,*) "gsaxsc"
12969 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12977 c----------------------------------------------------------------------------
12978 subroutine e_saxsC(Esaxs_constr)
12980 include 'DIMENSIONS'
12983 include "COMMON.SETUP"
12986 include 'COMMON.SBRIDGE'
12987 include 'COMMON.CHAIN'
12988 include 'COMMON.GEO'
12989 include 'COMMON.DERIV'
12990 include 'COMMON.LOCAL'
12991 include 'COMMON.INTERACT'
12992 include 'COMMON.VAR'
12993 include 'COMMON.IOUNITS'
12994 c include 'COMMON.MD'
12997 include 'COMMON.LANGEVIN.lang0.5diag'
12999 include 'COMMON.LANGEVIN.lang0'
13002 include 'COMMON.LANGEVIN'
13004 include 'COMMON.CONTROL'
13005 include 'COMMON.SAXS'
13006 include 'COMMON.NAMES'
13007 include 'COMMON.TIME1'
13008 include 'COMMON.FFIELD'
13010 double precision Esaxs_constr
13011 integer i,iint,j,k,l
13012 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13014 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13016 double precision dk,dijCASPH,dijSCSPH,
13017 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13018 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13020 c SAXS restraint penalty function
13022 write(iout,*) "------- SAXS penalty function start -------"
13023 write (iout,*) "nsaxs",nsaxs
13026 print *,MyRank,"C",i,(C(j,i),j=1,3)
13029 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13032 Esaxs_constr = 0.0d0
13034 do j=isaxs_start,isaxs_end
13043 if (itype(i).eq.ntyp1) cycle
13047 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13049 if (itype(i).ne.10) then
13051 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13054 sigma2CA=2.0d0/pstok**2
13055 sigma2SC=4.0d0/restok(itype(i))**2
13056 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13057 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13058 Pcalc = Pcalc+expCASPH+expSCSPH
13060 write(*,*) "processor i j Pcalc",
13061 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13063 CASPHgrad = sigma2CA*expCASPH
13064 SCSPHgrad = sigma2SC*expSCSPH
13066 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13067 PgradX(l,i) = PgradX(l,i) + aux
13068 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13073 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13074 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13077 logPtot = logPtot - dlog(Pcalc)
13078 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13079 c & " logPtot",logPtot
13082 if (nfgtasks.gt.1) then
13083 c write (iout,*) "logPtot before reduction",logPtot
13084 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13085 & MPI_SUM,king,FG_COMM,IERR)
13087 c write (iout,*) "logPtot after reduction",logPtot
13088 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13089 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13090 if (fg_rank.eq.king) then
13093 gsaxsC(l,i) = gsaxsC_(l,i)
13097 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13098 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13099 if (fg_rank.eq.king) then
13102 gsaxsX(l,i) = gsaxsX_(l,i)
13108 Esaxs_constr = logPtot
13111 c----------------------------------------------------------------------------
13112 double precision function sscale2(r,r_cut,r0,rlamb)
13114 double precision r,gamm,r_cut,r0,rlamb,rr
13116 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13117 c write (2,*) "rr",rr
13118 if(rr.lt.r_cut-rlamb) then
13120 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13121 gamm=(rr-(r_cut-rlamb))/rlamb
13122 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13128 C-----------------------------------------------------------------------
13129 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13131 double precision r,gamm,r_cut,r0,rlamb,rr
13133 if(rr.lt.r_cut-rlamb) then
13135 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13136 gamm=(rr-(r_cut-rlamb))/rlamb
13138 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13140 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13147 c------------------------------------------------------------------------
13148 double precision function boxshift(x,boxsize)
13150 double precision x,boxsize
13151 double precision xtemp
13152 xtemp=dmod(x,boxsize)
13153 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13154 boxshift=xtemp-boxsize
13155 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13156 boxshift=xtemp+boxsize
13162 c--------------------------------------------------------------------------
13163 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13164 include 'DIMENSIONS'
13165 include 'COMMON.CHAIN'
13166 integer xshift,yshift,zshift,subchap
13167 double precision dist_init,xj_safe,yj_safe,zj_safe,
13168 & xj_temp,yj_temp,zj_temp,dist_temp
13172 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13177 xj=xj_safe+xshift*boxxsize
13178 yj=yj_safe+yshift*boxysize
13179 zj=zj_safe+zshift*boxzsize
13180 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13181 if(dist_temp.lt.dist_init) then
13182 dist_init=dist_temp
13191 if (subchap.eq.1) then
13202 c--------------------------------------------------------------------------
13203 subroutine to_box(xi,yi,zi)
13205 include 'DIMENSIONS'
13206 include 'COMMON.CHAIN'
13207 double precision xi,yi,zi
13208 xi=dmod(xi,boxxsize)
13209 if (xi.lt.0.0d0) xi=xi+boxxsize
13210 yi=dmod(yi,boxysize)
13211 if (yi.lt.0.0d0) yi=yi+boxysize
13212 zi=dmod(zi,boxzsize)
13213 if (zi.lt.0.0d0) zi=zi+boxzsize
13216 c--------------------------------------------------------------------------
13217 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13219 include 'DIMENSIONS'
13220 include 'COMMON.CHAIN'
13221 double precision xi,yi,zi,sslipi,ssgradlipi
13222 double precision fracinbuf
13223 double precision sscalelip,sscagradlip
13225 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13226 C the energy transfer exist
13227 if (zi.lt.buflipbot) then
13228 C what fraction I am in
13229 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13230 C lipbufthick is thickenes of lipid buffore
13231 sslipi=sscalelip(fracinbuf)
13232 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13233 elseif (zi.gt.bufliptop) then
13234 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13235 sslipi=sscalelip(fracinbuf)
13236 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick