source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28       include 'COMMON.TORCNSTR'
  29 #ifdef MPI
  30 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  31 c     & " nfgtasks",nfgtasks
  32       if (nfgtasks.gt.1) then
  33         time00=MPI_Wtime()
  34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  35         if (fg_rank.eq.0) then
  36           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  37 c          print *,"Processor",myrank," BROADCAST iorder"
  38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  39 C FG slaves as WEIGHTS array.
  40           weights_(1)=wsc
  41           weights_(2)=wscp
  42           weights_(3)=welec
  43           weights_(4)=wcorr
  44           weights_(5)=wcorr5
  45           weights_(6)=wcorr6
  46           weights_(7)=wel_loc
  47           weights_(8)=wturn3
  48           weights_(9)=wturn4
  49           weights_(10)=wturn6
  50           weights_(11)=wang
  51           weights_(12)=wscloc
  52           weights_(13)=wtor
  53           weights_(14)=wtor_d
  54           weights_(15)=wstrain
  55           weights_(16)=wvdwpp
  56           weights_(17)=wbond
  57           weights_(18)=scal14
  58           weights_(21)=wsccor
  59           weights_(22)=wtube
  60
  61 C FG Master broadcasts the WEIGHTS_ array
  62           call MPI_Bcast(weights_(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64         else
  65 C FG slaves receive the WEIGHTS array
  66           call MPI_Bcast(weights(1),n_ene,
  67      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  68           wsc=weights(1)
  69           wscp=weights(2)
  70           welec=weights(3)
  71           wcorr=weights(4)
  72           wcorr5=weights(5)
  73           wcorr6=weights(6)
  74           wel_loc=weights(7)
  75           wturn3=weights(8)
  76           wturn4=weights(9)
  77           wturn6=weights(10)
  78           wang=weights(11)
  79           wscloc=weights(12)
  80           wtor=weights(13)
  81           wtor_d=weights(14)
  82           wstrain=weights(15)
  83           wvdwpp=weights(16)
  84           wbond=weights(17)
  85           scal14=weights(18)
  86           wsccor=weights(21)
  87           wtube=weights(22)
  88         endif
  89         time_Bcast=time_Bcast+MPI_Wtime()-time00
  90         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  91 c        call chainbuild_cart
  92       endif
  93 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  94 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  95 #else
  96 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  97 c        call int_from_cart1(.false.)
  98 c      endif
  99 #endif
 100 #ifdef TIMING
 101       time00=MPI_Wtime()
 102 #endif
 103 C
 104 C Compute the side-chain and electrostatic interaction energy
 105 C
 106 C      print *,ipot
 107       goto (101,102,103,104,105,106) ipot
 108 C Lennard-Jones potential.
 109   101 call elj(evdw)
 110 cd    print '(a)','Exit ELJ'
 111       goto 107
 112 C Lennard-Jones-Kihara potential (shifted).
 113   102 call eljk(evdw)
 114       goto 107
 115 C Berne-Pechukas potential (dilated LJ, angular dependence).
 116   103 call ebp(evdw)
 117       goto 107
 118 C Gay-Berne potential (shifted LJ, angular dependence).
 119   104 call egb(evdw)
 120 C      print *,"bylem w egb"
 121       goto 107
 122 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 123   105 call egbv(evdw)
 124       goto 107
 125 C Soft-sphere potential
 126   106 call e_softsphere(evdw)
 127 C
 128 C Calculate electrostatic (H-bonding) energy of the main chain.
 129 C
 130   107 continue
 131 cmc
 132 cmc Sep-06: egb takes care of dynamic ss bonds too
 133 cmc
 134 c      if (dyn_ss) call dyn_set_nss
 135
 136 c      print *,"Processor",myrank," computed USCSC"
 137 #ifdef TIMING
 138       time01=MPI_Wtime()
 139 #endif
 140       call vec_and_deriv
 141 #ifdef TIMING
 142       time_vec=time_vec+MPI_Wtime()-time01
 143 #endif
 144 C Introduction of shielding effect first for each peptide group
 145 C the shielding factor is set this factor is describing how each
 146 C peptide group is shielded by side-chains
 147 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 148 C      write (iout,*) "shield_mode",shield_mode
 149       if (shield_mode.eq.1) then
 150        call set_shield_fac
 151       else if  (shield_mode.eq.2) then
 152        call set_shield_fac2
 153       endif
 154 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 155       if (ipot.lt.6) then
 156 #ifdef SPLITELE
 157          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 158      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 159      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 160      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 161 #else
 162          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 163      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 164      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 165      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 166 #endif
 167             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 168          else
 169             ees=0.0d0
 170             evdw1=0.0d0
 171             eel_loc=0.0d0
 172             eello_turn3=0.0d0
 173             eello_turn4=0.0d0
 174          endif
 175       else
 176         write (iout,*) "Soft-spheer ELEC potential"
 177 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 178 c     &   eello_turn4)
 179       endif
 180 c      print *,"Processor",myrank," computed UELEC"
 181 C
 182 C Calculate excluded-volume interaction energy between peptide groups
 183 C and side chains.
 184 C
 185       if (ipot.lt.6) then
 186        if(wscp.gt.0d0) then
 187         call escp(evdw2,evdw2_14)
 188        else
 189         evdw2=0
 190         evdw2_14=0
 191        endif
 192       else
 193 c        write (iout,*) "Soft-sphere SCP potential"
 194         call escp_soft_sphere(evdw2,evdw2_14)
 195       endif
 196 c
 197 c Calculate the bond-stretching energy
 198 c
 199       call ebond(estr)
 200 C
 201 C Calculate the disulfide-bridge and other energy and the contributions
 202 C from other distance constraints.
 203 cd    print *,'Calling EHPB'
 204       call edis(ehpb)
 205 cd    print *,'EHPB exitted succesfully.'
 206 C
 207 C Calculate the virtual-bond-angle energy.
 208 C
 209       if (wang.gt.0d0) then
 210        if (tor_mode.eq.0) then
 211          call ebend(ebe)
 212        else
 213 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 214 C energy function
 215          call ebend_kcc(ebe)
 216        endif
 217       else
 218         ebe=0.0d0
 219       endif
 220       ethetacnstr=0.0d0
 221       if (with_theta_constr) call etheta_constr(ethetacnstr)
 222 c      print *,"Processor",myrank," computed UB"
 223 C
 224 C Calculate the SC local energy.
 225 C
 226 C      print *,"TU DOCHODZE?"
 227       call esc(escloc)
 228 c      print *,"Processor",myrank," computed USC"
 229 C
 230 C Calculate the virtual-bond torsional energy.
 231 C
 232 cd    print *,'nterm=',nterm
 233 C      print *,"tor",tor_mode
 234       if (wtor.gt.0.0d0) then
 235          if (tor_mode.eq.0) then
 236            call etor(etors)
 237          else
 238 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 239 C energy function
 240            call etor_kcc(etors)
 241          endif
 242       else
 243         etors=0.0d0
 244       endif
 245       edihcnstr=0.0d0
 246       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 247 c      print *,"Processor",myrank," computed Utor"
 248 C
 249 C 6/23/01 Calculate double-torsional energy
 250 C
 251       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 252         call etor_d(etors_d)
 253       else
 254         etors_d=0
 255       endif
 256 c      print *,"Processor",myrank," computed Utord"
 257 C
 258 C 21/5/07 Calculate local sicdechain correlation energy
 259 C
 260       if (wsccor.gt.0.0d0) then
 261         call eback_sc_corr(esccor)
 262       else
 263         esccor=0.0d0
 264       endif
 265 C      print *,"PRZED MULIt"
 266 c      print *,"Processor",myrank," computed Usccorr"
 267 C
 268 C 12/1/95 Multi-body terms
 269 C
 270       n_corr=0
 271       n_corr1=0
 272       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 273      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 274          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 275 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 276 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 277 c        call flush(iout)
 278       else
 279          ecorr=0.0d0
 280          ecorr5=0.0d0
 281          ecorr6=0.0d0
 282          eturn6=0.0d0
 283       endif
 284       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 285 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 286 c     &     n_corr,n_corr1
 287 c         call flush(iout)
 288          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 289 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 290 c     &     n_corr1
 291 c         call flush(iout)
 292       endif
 293 c      print *,"Processor",myrank," computed Ucorr"
 294 C
 295 C If performing constraint dynamics, call the constraint energy
 296 C  after the equilibration time
 297 c      if(usampl.and.totT.gt.eq_time) then
 298 c      write (iout,*) "usampl",usampl
 299       if(usampl) then
 300          call EconstrQ
 301          if (loc_qlike) then
 302            call Econstr_back_qlike
 303          else
 304            call Econstr_back
 305          endif
 306       else
 307          Uconst=0.0d0
 308          Uconst_back=0.0d0
 309       endif
 310 C 01/27/2015 added by adasko
 311 C the energy component below is energy transfer into lipid environment
 312 C based on partition function
 313 C      print *,"przed lipidami"
 314       if (wliptran.gt.0) then
 315         call Eliptransfer(eliptran)
 316       endif
 317 C      print *,"za lipidami"
 318       if (AFMlog.gt.0) then
 319         call AFMforce(Eafmforce)
 320       else if (selfguide.gt.0) then
 321         call AFMvel(Eafmforce)
 322       endif
 323       if (TUBElog.eq.1) then
 324 C      print *,"just before call"
 325         call calctube(Etube)
 326        elseif (TUBElog.eq.2) then
 327         call calctube2(Etube)
 328        else
 329        Etube=0.0d0
 330        endif
 331
 332 #ifdef TIMING
 333       time_enecalc=time_enecalc+MPI_Wtime()-time00
 334 #endif
 335 c      print *,"Processor",myrank," computed Uconstr"
 336 #ifdef TIMING
 337       time00=MPI_Wtime()
 338 #endif
 339 c
 340 C Sum the energies
 341 C
 342       energia(1)=evdw
 343 #ifdef SCP14
 344       energia(2)=evdw2-evdw2_14
 345       energia(18)=evdw2_14
 346 #else
 347       energia(2)=evdw2
 348       energia(18)=0.0d0
 349 #endif
 350 #ifdef SPLITELE
 351       energia(3)=ees
 352       energia(16)=evdw1
 353 #else
 354       energia(3)=ees+evdw1
 355       energia(16)=0.0d0
 356 #endif
 357       energia(4)=ecorr
 358       energia(5)=ecorr5
 359       energia(6)=ecorr6
 360       energia(7)=eel_loc
 361       energia(8)=eello_turn3
 362       energia(9)=eello_turn4
 363       energia(10)=eturn6
 364       energia(11)=ebe
 365       energia(12)=escloc
 366       energia(13)=etors
 367       energia(14)=etors_d
 368       energia(15)=ehpb
 369       energia(19)=edihcnstr
 370       energia(17)=estr
 371       energia(20)=Uconst+Uconst_back
 372       energia(21)=esccor
 373       energia(22)=eliptran
 374       energia(23)=Eafmforce
 375       energia(24)=ethetacnstr
 376       energia(25)=Etube
 377 c    Here are the energies showed per procesor if the are more processors
 378 c    per molecule then we sum it up in sum_energy subroutine
 379 c      print *," Processor",myrank," calls SUM_ENERGY"
 380       call sum_energy(energia,.true.)
 381       if (dyn_ss) call dyn_set_nss
 382 c      print *," Processor",myrank," left SUM_ENERGY"
 383 #ifdef TIMING
 384       time_sumene=time_sumene+MPI_Wtime()-time00
 385 #endif
 386       return
 387       end
 388 c-------------------------------------------------------------------------------
 389       subroutine sum_energy(energia,reduce)
 390       implicit real*8 (a-h,o-z)
 391       include 'DIMENSIONS'
 392 #ifndef ISNAN
 393       external proc_proc
 394 #ifdef WINPGI
 395 cMS$ATTRIBUTES C ::  proc_proc
 396 #endif
 397 #endif
 398 #ifdef MPI
 399       include "mpif.h"
 400 #endif
 401       include 'COMMON.SETUP'
 402       include 'COMMON.IOUNITS'
 403       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 404       include 'COMMON.FFIELD'
 405       include 'COMMON.DERIV'
 406       include 'COMMON.INTERACT'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.CHAIN'
 409       include 'COMMON.VAR'
 410       include 'COMMON.CONTROL'
 411       include 'COMMON.TIME1'
 412       logical reduce
 413 #ifdef MPI
 414       if (nfgtasks.gt.1 .and. reduce) then
 415 #ifdef DEBUG
 416         write (iout,*) "energies before REDUCE"
 417         call enerprint(energia)
 418         call flush(iout)
 419 #endif
 420         do i=0,n_ene
 421           enebuff(i)=energia(i)
 422         enddo
 423         time00=MPI_Wtime()
 424         call MPI_Barrier(FG_COMM,IERR)
 425         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 426         time00=MPI_Wtime()
 427         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 428      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 429 #ifdef DEBUG
 430         write (iout,*) "energies after REDUCE"
 431         call enerprint(energia)
 432         call flush(iout)
 433 #endif
 434         time_Reduce=time_Reduce+MPI_Wtime()-time00
 435       endif
 436       if (fg_rank.eq.0) then
 437 #endif
 438       evdw=energia(1)
 439 #ifdef SCP14
 440       evdw2=energia(2)+energia(18)
 441       evdw2_14=energia(18)
 442 #else
 443       evdw2=energia(2)
 444 #endif
 445 #ifdef SPLITELE
 446       ees=energia(3)
 447       evdw1=energia(16)
 448 #else
 449       ees=energia(3)
 450       evdw1=0.0d0
 451 #endif
 452       ecorr=energia(4)
 453       ecorr5=energia(5)
 454       ecorr6=energia(6)
 455       eel_loc=energia(7)
 456       eello_turn3=energia(8)
 457       eello_turn4=energia(9)
 458       eturn6=energia(10)
 459       ebe=energia(11)
 460       escloc=energia(12)
 461       etors=energia(13)
 462       etors_d=energia(14)
 463       ehpb=energia(15)
 464       edihcnstr=energia(19)
 465       estr=energia(17)
 466       Uconst=energia(20)
 467       esccor=energia(21)
 468       eliptran=energia(22)
 469       Eafmforce=energia(23)
 470       ethetacnstr=energia(24)
 471       Etube=energia(25)
 472 #ifdef SPLITELE
 473       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 474      & +wang*ebe+wtor*etors+wscloc*escloc
 475      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 476      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 477      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 478      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 479      & +ethetacnstr+wtube*Etube
 480 #else
 481       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 482      & +wang*ebe+wtor*etors+wscloc*escloc
 483      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 484      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 485      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 486      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 487      & +Eafmforce
 488      & +ethetacnstr+wtube*Etube
 489 #endif
 490       energia(0)=etot
 491 c detecting NaNQ
 492 #ifdef ISNAN
 493 #ifdef AIX
 494       if (isnan(etot).ne.0) energia(0)=1.0d+99
 495 #else
 496       if (isnan(etot)) energia(0)=1.0d+99
 497 #endif
 498 #else
 499       i=0
 500 #ifdef WINPGI
 501       idumm=proc_proc(etot,i)
 502 #else
 503       call proc_proc(etot,i)
 504 #endif
 505       if(i.eq.1)energia(0)=1.0d+99
 506 #endif
 507 #ifdef MPI
 508       endif
 509 #endif
 510       return
 511       end
 512 c-------------------------------------------------------------------------------
 513       subroutine sum_gradient
 514       implicit real*8 (a-h,o-z)
 515       include 'DIMENSIONS'
 516 #ifndef ISNAN
 517       external proc_proc
 518 #ifdef WINPGI
 519 cMS$ATTRIBUTES C ::  proc_proc
 520 #endif
 521 #endif
 522 #ifdef MPI
 523       include 'mpif.h'
 524 #endif
 525       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 526      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 527      & ,gloc_scbuf(3,-1:maxres)
 528       include 'COMMON.SETUP'
 529       include 'COMMON.IOUNITS'
 530       include 'COMMON.FFIELD'
 531       include 'COMMON.DERIV'
 532       include 'COMMON.INTERACT'
 533       include 'COMMON.SBRIDGE'
 534       include 'COMMON.CHAIN'
 535       include 'COMMON.VAR'
 536       include 'COMMON.CONTROL'
 537       include 'COMMON.TIME1'
 538       include 'COMMON.MAXGRAD'
 539       include 'COMMON.SCCOR'
 540 #ifdef TIMING
 541       time01=MPI_Wtime()
 542 #endif
 543 #ifdef DEBUG
 544       write (iout,*) "sum_gradient gvdwc, gvdwx"
 545       do i=1,nres
 546         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 547      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 548       enddo
 549       call flush(iout)
 550 #endif
 551 #ifdef MPI
 552 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 553         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 554      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 555 #endif
 556 C
 557 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 558 C            in virtual-bond-vector coordinates
 559 C
 560 #ifdef DEBUG
 561 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 562 c      do i=1,nres-1
 563 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 564 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 565 c      enddo
 566 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 567 c      do i=1,nres-1
 568 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 569 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 570 c      enddo
 571       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 572       do i=1,nres
 573         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 574      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 575      &   g_corr5_loc(i)
 576       enddo
 577       call flush(iout)
 578 #endif
 579 #ifdef SPLITELE
 580       do i=0,nct
 581         do j=1,3
 582           gradbufc(j,i)=wsc*gvdwc(j,i)+
 583      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 584      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 585      &                wel_loc*gel_loc_long(j,i)+
 586      &                wcorr*gradcorr_long(j,i)+
 587      &                wcorr5*gradcorr5_long(j,i)+
 588      &                wcorr6*gradcorr6_long(j,i)+
 589      &                wturn6*gcorr6_turn_long(j,i)+
 590      &                wstrain*ghpbc(j,i)
 591      &                +wliptran*gliptranc(j,i)
 592      &                +gradafm(j,i)
 593      &                 +welec*gshieldc(j,i)
 594      &                 +wcorr*gshieldc_ec(j,i)
 595      &                 +wturn3*gshieldc_t3(j,i)
 596      &                 +wturn4*gshieldc_t4(j,i)
 597      &                 +wel_loc*gshieldc_ll(j,i)
 598      &                +wtube*gg_tube(j,i)
 599
 600
 601
 602         enddo
 603       enddo
 604 #else
 605       do i=0,nct
 606         do j=1,3
 607           gradbufc(j,i)=wsc*gvdwc(j,i)+
 608      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 609      &                welec*gelc_long(j,i)+
 610      &                wbond*gradb(j,i)+
 611      &                wel_loc*gel_loc_long(j,i)+
 612      &                wcorr*gradcorr_long(j,i)+
 613      &                wcorr5*gradcorr5_long(j,i)+
 614      &                wcorr6*gradcorr6_long(j,i)+
 615      &                wturn6*gcorr6_turn_long(j,i)+
 616      &                wstrain*ghpbc(j,i)
 617      &                +wliptran*gliptranc(j,i)
 618      &                +gradafm(j,i)
 619      &                 +welec*gshieldc(j,i)
 620      &                 +wcorr*gshieldc_ec(j,i)
 621      &                 +wturn4*gshieldc_t4(j,i)
 622      &                 +wel_loc*gshieldc_ll(j,i)
 623      &                +wtube*gg_tube(j,i)
 624
 625
 626
 627         enddo
 628       enddo
 629 #endif
 630 #ifdef MPI
 631       if (nfgtasks.gt.1) then
 632       time00=MPI_Wtime()
 633 #ifdef DEBUG
 634       write (iout,*) "gradbufc before allreduce"
 635       do i=1,nres
 636         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640       do i=0,nres
 641         do j=1,3
 642           gradbufc_sum(j,i)=gradbufc(j,i)
 643         enddo
 644       enddo
 645 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 646 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 647 c      time_reduce=time_reduce+MPI_Wtime()-time00
 648 #ifdef DEBUG
 649 c      write (iout,*) "gradbufc_sum after allreduce"
 650 c      do i=1,nres
 651 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 652 c      enddo
 653 c      call flush(iout)
 654 #endif
 655 #ifdef TIMING
 656 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 657 #endif
 658       do i=nnt,nres
 659         do k=1,3
 660           gradbufc(k,i)=0.0d0
 661         enddo
 662       enddo
 663 #ifdef DEBUG
 664       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 665       write (iout,*) (i," jgrad_start",jgrad_start(i),
 666      &                  " jgrad_end  ",jgrad_end(i),
 667      &                  i=igrad_start,igrad_end)
 668 #endif
 669 c
 670 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 671 c do not parallelize this part.
 672 c
 673 c      do i=igrad_start,igrad_end
 674 c        do j=jgrad_start(i),jgrad_end(i)
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680       do j=1,3
 681         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 682       enddo
 683       do i=nres-2,-1,-1
 684         do j=1,3
 685           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gradbufc after summing"
 690       do i=1,nres
 691         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 692       enddo
 693       call flush(iout)
 694 #endif
 695       else
 696 #endif
 697 #ifdef DEBUG
 698       write (iout,*) "gradbufc"
 699       do i=1,nres
 700         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 701       enddo
 702       call flush(iout)
 703 #endif
 704       do i=-1,nres
 705         do j=1,3
 706           gradbufc_sum(j,i)=gradbufc(j,i)
 707           gradbufc(j,i)=0.0d0
 708         enddo
 709       enddo
 710       do j=1,3
 711         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 712       enddo
 713       do i=nres-2,-1,-1
 714         do j=1,3
 715           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 716         enddo
 717       enddo
 718 c      do i=nnt,nres-1
 719 c        do k=1,3
 720 c          gradbufc(k,i)=0.0d0
 721 c        enddo
 722 c        do j=i+1,nres
 723 c          do k=1,3
 724 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 725 c          enddo
 726 c        enddo
 727 c      enddo
 728 #ifdef DEBUG
 729       write (iout,*) "gradbufc after summing"
 730       do i=1,nres
 731         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 732       enddo
 733       call flush(iout)
 734 #endif
 735 #ifdef MPI
 736       endif
 737 #endif
 738       do k=1,3
 739         gradbufc(k,nres)=0.0d0
 740       enddo
 741       do i=-1,nct
 742         do j=1,3
 743 #ifdef SPLITELE
 744 C          print *,gradbufc(1,13)
 745 C          print *,welec*gelc(1,13)
 746 C          print *,wel_loc*gel_loc(1,13)
 747 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 748 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 749 C          print *,wel_loc*gel_loc_long(1,13)
 750 C          print *,gradafm(1,13),"AFM"
 751           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 752      &                wel_loc*gel_loc(j,i)+
 753      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 754      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 755      &                wel_loc*gel_loc_long(j,i)+
 756      &                wcorr*gradcorr_long(j,i)+
 757      &                wcorr5*gradcorr5_long(j,i)+
 758      &                wcorr6*gradcorr6_long(j,i)+
 759      &                wturn6*gcorr6_turn_long(j,i))+
 760      &                wbond*gradb(j,i)+
 761      &                wcorr*gradcorr(j,i)+
 762      &                wturn3*gcorr3_turn(j,i)+
 763      &                wturn4*gcorr4_turn(j,i)+
 764      &                wcorr5*gradcorr5(j,i)+
 765      &                wcorr6*gradcorr6(j,i)+
 766      &                wturn6*gcorr6_turn(j,i)+
 767      &                wsccor*gsccorc(j,i)
 768      &               +wscloc*gscloc(j,i)
 769      &               +wliptran*gliptranc(j,i)
 770      &                +gradafm(j,i)
 771      &                 +welec*gshieldc(j,i)
 772      &                 +welec*gshieldc_loc(j,i)
 773      &                 +wcorr*gshieldc_ec(j,i)
 774      &                 +wcorr*gshieldc_loc_ec(j,i)
 775      &                 +wturn3*gshieldc_t3(j,i)
 776      &                 +wturn3*gshieldc_loc_t3(j,i)
 777      &                 +wturn4*gshieldc_t4(j,i)
 778      &                 +wturn4*gshieldc_loc_t4(j,i)
 779      &                 +wel_loc*gshieldc_ll(j,i)
 780      &                 +wel_loc*gshieldc_loc_ll(j,i)
 781      &                +wtube*gg_tube(j,i)
 782
 783 #else
 784           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 785      &                wel_loc*gel_loc(j,i)+
 786      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 787      &                welec*gelc_long(j,i)+
 788      &                wel_loc*gel_loc_long(j,i)+
 789      &                wcorr*gcorr_long(j,i)+
 790      &                wcorr5*gradcorr5_long(j,i)+
 791      &                wcorr6*gradcorr6_long(j,i)+
 792      &                wturn6*gcorr6_turn_long(j,i))+
 793      &                wbond*gradb(j,i)+
 794      &                wcorr*gradcorr(j,i)+
 795      &                wturn3*gcorr3_turn(j,i)+
 796      &                wturn4*gcorr4_turn(j,i)+
 797      &                wcorr5*gradcorr5(j,i)+
 798      &                wcorr6*gradcorr6(j,i)+
 799      &                wturn6*gcorr6_turn(j,i)+
 800      &                wsccor*gsccorc(j,i)
 801      &               +wscloc*gscloc(j,i)
 802      &               +wliptran*gliptranc(j,i)
 803      &                +gradafm(j,i)
 804      &                 +welec*gshieldc(j,i)
 805      &                 +welec*gshieldc_loc(j,i)
 806      &                 +wcorr*gshieldc_ec(j,i)
 807      &                 +wcorr*gshieldc_loc_ec(j,i)
 808      &                 +wturn3*gshieldc_t3(j,i)
 809      &                 +wturn3*gshieldc_loc_t3(j,i)
 810      &                 +wturn4*gshieldc_t4(j,i)
 811      &                 +wturn4*gshieldc_loc_t4(j,i)
 812      &                 +wel_loc*gshieldc_ll(j,i)
 813      &                 +wel_loc*gshieldc_loc_ll(j,i)
 814      &                +wtube*gg_tube(j,i)
 815
 816
 817 #endif
 818           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 819      &                  wbond*gradbx(j,i)+
 820      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 821      &                  wsccor*gsccorx(j,i)
 822      &                 +wscloc*gsclocx(j,i)
 823      &                 +wliptran*gliptranx(j,i)
 824      &                 +welec*gshieldx(j,i)
 825      &                 +wcorr*gshieldx_ec(j,i)
 826      &                 +wturn3*gshieldx_t3(j,i)
 827      &                 +wturn4*gshieldx_t4(j,i)
 828      &                 +wel_loc*gshieldx_ll(j,i)
 829      &                 +wtube*gg_tube_sc(j,i)
 830
 831
 832
 833         enddo
 834       enddo
 835 #ifdef DEBUG
 836       write (iout,*) "gloc before adding corr"
 837       do i=1,4*nres
 838         write (iout,*) i,gloc(i,icg)
 839       enddo
 840 #endif
 841       do i=1,nres-3
 842         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 843      &   +wcorr5*g_corr5_loc(i)
 844      &   +wcorr6*g_corr6_loc(i)
 845      &   +wturn4*gel_loc_turn4(i)
 846      &   +wturn3*gel_loc_turn3(i)
 847      &   +wturn6*gel_loc_turn6(i)
 848      &   +wel_loc*gel_loc_loc(i)
 849       enddo
 850 #ifdef DEBUG
 851       write (iout,*) "gloc after adding corr"
 852       do i=1,4*nres
 853         write (iout,*) i,gloc(i,icg)
 854       enddo
 855 #endif
 856 #ifdef MPI
 857       if (nfgtasks.gt.1) then
 858         do j=1,3
 859           do i=1,nres
 860             gradbufc(j,i)=gradc(j,i,icg)
 861             gradbufx(j,i)=gradx(j,i,icg)
 862           enddo
 863         enddo
 864         do i=1,4*nres
 865           glocbuf(i)=gloc(i,icg)
 866         enddo
 867 c#define DEBUG
 868 #ifdef DEBUG
 869       write (iout,*) "gloc_sc before reduce"
 870       do i=1,nres
 871        do j=1,1
 872         write (iout,*) i,j,gloc_sc(j,i,icg)
 873        enddo
 874       enddo
 875 #endif
 876 c#undef DEBUG
 877         do i=1,nres
 878          do j=1,3
 879           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 880          enddo
 881         enddo
 882         time00=MPI_Wtime()
 883         call MPI_Barrier(FG_COMM,IERR)
 884         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 885         time00=MPI_Wtime()
 886         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 891      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 892         time_reduce=time_reduce+MPI_Wtime()-time00
 893         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 894      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 895         time_reduce=time_reduce+MPI_Wtime()-time00
 896 c#define DEBUG
 897 #ifdef DEBUG
 898       write (iout,*) "gloc_sc after reduce"
 899       do i=1,nres
 900        do j=1,1
 901         write (iout,*) i,j,gloc_sc(j,i,icg)
 902        enddo
 903       enddo
 904 #endif
 905 c#undef DEBUG
 906 #ifdef DEBUG
 907       write (iout,*) "gloc after reduce"
 908       do i=1,4*nres
 909         write (iout,*) i,gloc(i,icg)
 910       enddo
 911 #endif
 912       endif
 913 #endif
 914       if (gnorm_check) then
 915 c
 916 c Compute the maximum elements of the gradient
 917 c
 918       gvdwc_max=0.0d0
 919       gvdwc_scp_max=0.0d0
 920       gelc_max=0.0d0
 921       gvdwpp_max=0.0d0
 922       gradb_max=0.0d0
 923       ghpbc_max=0.0d0
 924       gradcorr_max=0.0d0
 925       gel_loc_max=0.0d0
 926       gcorr3_turn_max=0.0d0
 927       gcorr4_turn_max=0.0d0
 928       gradcorr5_max=0.0d0
 929       gradcorr6_max=0.0d0
 930       gcorr6_turn_max=0.0d0
 931       gsccorc_max=0.0d0
 932       gscloc_max=0.0d0
 933       gvdwx_max=0.0d0
 934       gradx_scp_max=0.0d0
 935       ghpbx_max=0.0d0
 936       gradxorr_max=0.0d0
 937       gsccorx_max=0.0d0
 938       gsclocx_max=0.0d0
 939       do i=1,nct
 940         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 941         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 942         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 943         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 944      &   gvdwc_scp_max=gvdwc_scp_norm
 945         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 946         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 947         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 948         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 949         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 950         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 951         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 952         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 953         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 954         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 955         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 956         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 957         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 958      &    gcorr3_turn(1,i)))
 959         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 960      &    gcorr3_turn_max=gcorr3_turn_norm
 961         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 962      &    gcorr4_turn(1,i)))
 963         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 964      &    gcorr4_turn_max=gcorr4_turn_norm
 965         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 966         if (gradcorr5_norm.gt.gradcorr5_max)
 967      &    gradcorr5_max=gradcorr5_norm
 968         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 969         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 970         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 971      &    gcorr6_turn(1,i)))
 972         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 973      &    gcorr6_turn_max=gcorr6_turn_norm
 974         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 975         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 976         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 977         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 978         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 981         if (gradx_scp_norm.gt.gradx_scp_max)
 982      &    gradx_scp_max=gradx_scp_norm
 983         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 984         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 985         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 986         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 987         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 988         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 989         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 990         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 991       enddo
 992       if (gradout) then
 993 #if (defined AIX || defined CRAY)
 994         open(istat,file=statname,position="append")
 995 #else
 996         open(istat,file=statname,access="append")
 997 #endif
 998         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 999      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1000      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1001      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1002      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1003      &     gsccorx_max,gsclocx_max
1004         close(istat)
1005         if (gvdwc_max.gt.1.0d4) then
1006           write (iout,*) "gvdwc gvdwx gradb gradbx"
1007           do i=nnt,nct
1008             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1009      &        gradb(j,i),gradbx(j,i),j=1,3)
1010           enddo
1011           call pdbout(0.0d0,'cipiszcze',iout)
1012           call flush(iout)
1013         endif
1014       endif
1015       endif
1016 #ifdef DEBUG
1017       write (iout,*) "gradc gradx gloc"
1018       do i=1,nres
1019         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1020      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1021       enddo
1022 #endif
1023 #ifdef TIMING
1024       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1025 #endif
1026       return
1027       end
1028 c-------------------------------------------------------------------------------
1029       subroutine rescale_weights(t_bath)
1030       implicit real*8 (a-h,o-z)
1031       include 'DIMENSIONS'
1032       include 'COMMON.IOUNITS'
1033       include 'COMMON.FFIELD'
1034       include 'COMMON.SBRIDGE'
1035       include 'COMMON.CONTROL'
1036       double precision kfac /2.4d0/
1037       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1038 c      facT=temp0/t_bath
1039 c      facT=2*temp0/(t_bath+temp0)
1040       if (rescale_mode.eq.0) then
1041         facT=1.0d0
1042         facT2=1.0d0
1043         facT3=1.0d0
1044         facT4=1.0d0
1045         facT5=1.0d0
1046       else if (rescale_mode.eq.1) then
1047         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1048         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1049         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1050         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1051         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1052       else if (rescale_mode.eq.2) then
1053         x=t_bath/temp0
1054         x2=x*x
1055         x3=x2*x
1056         x4=x3*x
1057         x5=x4*x
1058         facT=licznik/dlog(dexp(x)+dexp(-x))
1059         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1060         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1061         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1062         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1063       else
1064         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1065         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1066 #ifdef MPI
1067        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1068 #endif
1069        stop 555
1070       endif
1071       if (shield_mode.gt.0) then
1072        wscp=weights(2)*fact
1073        wsc=weights(1)*fact
1074        wvdwpp=weights(16)*fact
1075       endif
1076       welec=weights(3)*fact
1077       wcorr=weights(4)*fact3
1078       wcorr5=weights(5)*fact4
1079       wcorr6=weights(6)*fact5
1080       wel_loc=weights(7)*fact2
1081       wturn3=weights(8)*fact2
1082       wturn4=weights(9)*fact3
1083       wturn6=weights(10)*fact5
1084       wtor=weights(13)*fact
1085       wtor_d=weights(14)*fact2
1086       wsccor=weights(21)*fact
1087       if (scale_umb) wumb=t_bath/temp0
1088 c      write (iout,*) "scale_umb",scale_umb
1089 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1090
1091       return
1092       end
1093 C------------------------------------------------------------------------
1094       subroutine enerprint(energia)
1095       implicit real*8 (a-h,o-z)
1096       include 'DIMENSIONS'
1097       include 'COMMON.IOUNITS'
1098       include 'COMMON.FFIELD'
1099       include 'COMMON.SBRIDGE'
1100       include 'COMMON.MD'
1101       double precision energia(0:n_ene)
1102       etot=energia(0)
1103       evdw=energia(1)
1104       evdw2=energia(2)
1105 #ifdef SCP14
1106       evdw2=energia(2)+energia(18)
1107 #else
1108       evdw2=energia(2)
1109 #endif
1110       ees=energia(3)
1111 #ifdef SPLITELE
1112       evdw1=energia(16)
1113 #endif
1114       ecorr=energia(4)
1115       ecorr5=energia(5)
1116       ecorr6=energia(6)
1117       eel_loc=energia(7)
1118       eello_turn3=energia(8)
1119       eello_turn4=energia(9)
1120       eello_turn6=energia(10)
1121       ebe=energia(11)
1122       escloc=energia(12)
1123       etors=energia(13)
1124       etors_d=energia(14)
1125       ehpb=energia(15)
1126       edihcnstr=energia(19)
1127       estr=energia(17)
1128       Uconst=energia(20)
1129       esccor=energia(21)
1130       eliptran=energia(22)
1131       Eafmforce=energia(23)
1132       ethetacnstr=energia(24)
1133       etube=energia(25)
1134 #ifdef SPLITELE
1135       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1136      &  estr,wbond,ebe,wang,
1137      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1138      &  ecorr,wcorr,
1139      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1140      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1141      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1142      &  etube,wtube,
1143      &  etot
1144    10 format (/'Virtual-chain energies:'//
1145      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1146      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1147      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1148      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1149      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1150      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1151      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1152      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1153      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1154      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1155      & ' (SS bridges & dist. cnstr.)'/
1156      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1157      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1158      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1159      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1160      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1161      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1162      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1163      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1164      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1165      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1166      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1167      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1168      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1169      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1170      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1171      & 'ETOT=  ',1pE16.6,' (total)')
1172
1173 #else
1174       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1175      &  estr,wbond,ebe,wang,
1176      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1177      &  ecorr,wcorr,
1178      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1179      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1180      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1181      &  etube,wtube,
1182      &  etot
1183    10 format (/'Virtual-chain energies:'//
1184      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1185      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1186      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1187      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1188      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1189      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1190      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1191      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1192      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1193      & ' (SS bridges & dist. cnstr.)'/
1194      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1195      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1196      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1197      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1198      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1199      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1200      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1201      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1202      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1203      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1204      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1205      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1206      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1207      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1208      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1209      & 'ETOT=  ',1pE16.6,' (total)')
1210 #endif
1211       return
1212       end
1213 C-----------------------------------------------------------------------
1214       subroutine elj(evdw)
1215 C
1216 C This subroutine calculates the interaction energy of nonbonded side chains
1217 C assuming the LJ potential of interaction.
1218 C
1219       implicit real*8 (a-h,o-z)
1220       include 'DIMENSIONS'
1221       parameter (accur=1.0d-10)
1222       include 'COMMON.GEO'
1223       include 'COMMON.VAR'
1224       include 'COMMON.LOCAL'
1225       include 'COMMON.CHAIN'
1226       include 'COMMON.DERIV'
1227       include 'COMMON.INTERACT'
1228       include 'COMMON.TORSION'
1229       include 'COMMON.SBRIDGE'
1230       include 'COMMON.NAMES'
1231       include 'COMMON.IOUNITS'
1232       include 'COMMON.CONTACTS'
1233       dimension gg(3)
1234 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1235       evdw=0.0D0
1236       do i=iatsc_s,iatsc_e
1237         itypi=iabs(itype(i))
1238         if (itypi.eq.ntyp1) cycle
1239         itypi1=iabs(itype(i+1))
1240         xi=c(1,nres+i)
1241         yi=c(2,nres+i)
1242         zi=c(3,nres+i)
1243 C Change 12/1/95
1244         num_conti=0
1245 C
1246 C Calculate SC interaction energy.
1247 C
1248         do iint=1,nint_gr(i)
1249 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1250 cd   &                  'iend=',iend(i,iint)
1251           do j=istart(i,iint),iend(i,iint)
1252             itypj=iabs(itype(j))
1253             if (itypj.eq.ntyp1) cycle
1254             xj=c(1,nres+j)-xi
1255             yj=c(2,nres+j)-yi
1256             zj=c(3,nres+j)-zi
1257 C Change 12/1/95 to calculate four-body interactions
1258             rij=xj*xj+yj*yj+zj*zj
1259             rrij=1.0D0/rij
1260 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1261             eps0ij=eps(itypi,itypj)
1262             fac=rrij**expon2
1263 C have you changed here?
1264             e1=fac*fac*aa
1265             e2=fac*bb
1266             evdwij=e1+e2
1267 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1268 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1269 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1270 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1271 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1272 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1273             evdw=evdw+evdwij
1274 C
1275 C Calculate the components of the gradient in DC and X
1276 C
1277             fac=-rrij*(e1+evdwij)
1278             gg(1)=xj*fac
1279             gg(2)=yj*fac
1280             gg(3)=zj*fac
1281             do k=1,3
1282               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1283               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1284               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1285               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1286             enddo
1287 cgrad            do k=i,j-1
1288 cgrad              do l=1,3
1289 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1290 cgrad              enddo
1291 cgrad            enddo
1292 C
1293 C 12/1/95, revised on 5/20/97
1294 C
1295 C Calculate the contact function. The ith column of the array JCONT will
1296 C contain the numbers of atoms that make contacts with the atom I (of numbers
1297 C greater than I). The arrays FACONT and GACONT will contain the values of
1298 C the contact function and its derivative.
1299 C
1300 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1301 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1302 C Uncomment next line, if the correlation interactions are contact function only
1303             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1304               rij=dsqrt(rij)
1305               sigij=sigma(itypi,itypj)
1306               r0ij=rs0(itypi,itypj)
1307 C
1308 C Check whether the SC's are not too far to make a contact.
1309 C
1310               rcut=1.5d0*r0ij
1311               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1312 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1313 C
1314               if (fcont.gt.0.0D0) then
1315 C If the SC-SC distance if close to sigma, apply spline.
1316 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1317 cAdam &             fcont1,fprimcont1)
1318 cAdam           fcont1=1.0d0-fcont1
1319 cAdam           if (fcont1.gt.0.0d0) then
1320 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1321 cAdam             fcont=fcont*fcont1
1322 cAdam           endif
1323 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1324 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1325 cga             do k=1,3
1326 cga               gg(k)=gg(k)*eps0ij
1327 cga             enddo
1328 cga             eps0ij=-evdwij*eps0ij
1329 C Uncomment for AL's type of SC correlation interactions.
1330 cadam           eps0ij=-evdwij
1331                 num_conti=num_conti+1
1332                 jcont(num_conti,i)=j
1333                 facont(num_conti,i)=fcont*eps0ij
1334                 fprimcont=eps0ij*fprimcont/rij
1335                 fcont=expon*fcont
1336 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1337 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1338 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1339 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1340                 gacont(1,num_conti,i)=-fprimcont*xj
1341                 gacont(2,num_conti,i)=-fprimcont*yj
1342                 gacont(3,num_conti,i)=-fprimcont*zj
1343 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1344 cd              write (iout,'(2i3,3f10.5)')
1345 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1346               endif
1347             endif
1348           enddo      ! j
1349         enddo        ! iint
1350 C Change 12/1/95
1351         num_cont(i)=num_conti
1352       enddo          ! i
1353       do i=1,nct
1354         do j=1,3
1355           gvdwc(j,i)=expon*gvdwc(j,i)
1356           gvdwx(j,i)=expon*gvdwx(j,i)
1357         enddo
1358       enddo
1359 C******************************************************************************
1360 C
1361 C                              N O T E !!!
1362 C
1363 C To save time, the factor of EXPON has been extracted from ALL components
1364 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1365 C use!
1366 C
1367 C******************************************************************************
1368       return
1369       end
1370 C-----------------------------------------------------------------------------
1371       subroutine eljk(evdw)
1372 C
1373 C This subroutine calculates the interaction energy of nonbonded side chains
1374 C assuming the LJK potential of interaction.
1375 C
1376       implicit real*8 (a-h,o-z)
1377       include 'DIMENSIONS'
1378       include 'COMMON.GEO'
1379       include 'COMMON.VAR'
1380       include 'COMMON.LOCAL'
1381       include 'COMMON.CHAIN'
1382       include 'COMMON.DERIV'
1383       include 'COMMON.INTERACT'
1384       include 'COMMON.IOUNITS'
1385       include 'COMMON.NAMES'
1386       dimension gg(3)
1387       logical scheck
1388 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1389       evdw=0.0D0
1390       do i=iatsc_s,iatsc_e
1391         itypi=iabs(itype(i))
1392         if (itypi.eq.ntyp1) cycle
1393         itypi1=iabs(itype(i+1))
1394         xi=c(1,nres+i)
1395         yi=c(2,nres+i)
1396         zi=c(3,nres+i)
1397 C
1398 C Calculate SC interaction energy.
1399 C
1400         do iint=1,nint_gr(i)
1401           do j=istart(i,iint),iend(i,iint)
1402             itypj=iabs(itype(j))
1403             if (itypj.eq.ntyp1) cycle
1404             xj=c(1,nres+j)-xi
1405             yj=c(2,nres+j)-yi
1406             zj=c(3,nres+j)-zi
1407             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1408             fac_augm=rrij**expon
1409             e_augm=augm(itypi,itypj)*fac_augm
1410             r_inv_ij=dsqrt(rrij)
1411             rij=1.0D0/r_inv_ij
1412             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1413             fac=r_shift_inv**expon
1414 C have you changed here?
1415             e1=fac*fac*aa
1416             e2=fac*bb
1417             evdwij=e_augm+e1+e2
1418 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1419 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1420 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1421 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1422 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1423 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1424 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1425             evdw=evdw+evdwij
1426 C
1427 C Calculate the components of the gradient in DC and X
1428 C
1429             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1430             gg(1)=xj*fac
1431             gg(2)=yj*fac
1432             gg(3)=zj*fac
1433             do k=1,3
1434               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1435               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1436               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1437               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1438             enddo
1439 cgrad            do k=i,j-1
1440 cgrad              do l=1,3
1441 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1442 cgrad              enddo
1443 cgrad            enddo
1444           enddo      ! j
1445         enddo        ! iint
1446       enddo          ! i
1447       do i=1,nct
1448         do j=1,3
1449           gvdwc(j,i)=expon*gvdwc(j,i)
1450           gvdwx(j,i)=expon*gvdwx(j,i)
1451         enddo
1452       enddo
1453       return
1454       end
1455 C-----------------------------------------------------------------------------
1456       subroutine ebp(evdw)
1457 C
1458 C This subroutine calculates the interaction energy of nonbonded side chains
1459 C assuming the Berne-Pechukas potential of interaction.
1460 C
1461       implicit real*8 (a-h,o-z)
1462       include 'DIMENSIONS'
1463       include 'COMMON.GEO'
1464       include 'COMMON.VAR'
1465       include 'COMMON.LOCAL'
1466       include 'COMMON.CHAIN'
1467       include 'COMMON.DERIV'
1468       include 'COMMON.NAMES'
1469       include 'COMMON.INTERACT'
1470       include 'COMMON.IOUNITS'
1471       include 'COMMON.CALC'
1472       common /srutu/ icall
1473 c     double precision rrsave(maxdim)
1474       logical lprn
1475       evdw=0.0D0
1476 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1477       evdw=0.0D0
1478 c     if (icall.eq.0) then
1479 c       lprn=.true.
1480 c     else
1481         lprn=.false.
1482 c     endif
1483       ind=0
1484       do i=iatsc_s,iatsc_e
1485         itypi=iabs(itype(i))
1486         if (itypi.eq.ntyp1) cycle
1487         itypi1=iabs(itype(i+1))
1488         xi=c(1,nres+i)
1489         yi=c(2,nres+i)
1490         zi=c(3,nres+i)
1491         dxi=dc_norm(1,nres+i)
1492         dyi=dc_norm(2,nres+i)
1493         dzi=dc_norm(3,nres+i)
1494 c        dsci_inv=dsc_inv(itypi)
1495         dsci_inv=vbld_inv(i+nres)
1496 C
1497 C Calculate SC interaction energy.
1498 C
1499         do iint=1,nint_gr(i)
1500           do j=istart(i,iint),iend(i,iint)
1501             ind=ind+1
1502             itypj=iabs(itype(j))
1503             if (itypj.eq.ntyp1) cycle
1504 c            dscj_inv=dsc_inv(itypj)
1505             dscj_inv=vbld_inv(j+nres)
1506             chi1=chi(itypi,itypj)
1507             chi2=chi(itypj,itypi)
1508             chi12=chi1*chi2
1509             chip1=chip(itypi)
1510             chip2=chip(itypj)
1511             chip12=chip1*chip2
1512             alf1=alp(itypi)
1513             alf2=alp(itypj)
1514             alf12=0.5D0*(alf1+alf2)
1515 C For diagnostics only!!!
1516 c           chi1=0.0D0
1517 c           chi2=0.0D0
1518 c           chi12=0.0D0
1519 c           chip1=0.0D0
1520 c           chip2=0.0D0
1521 c           chip12=0.0D0
1522 c           alf1=0.0D0
1523 c           alf2=0.0D0
1524 c           alf12=0.0D0
1525             xj=c(1,nres+j)-xi
1526             yj=c(2,nres+j)-yi
1527             zj=c(3,nres+j)-zi
1528             dxj=dc_norm(1,nres+j)
1529             dyj=dc_norm(2,nres+j)
1530             dzj=dc_norm(3,nres+j)
1531             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532 cd          if (icall.eq.0) then
1533 cd            rrsave(ind)=rrij
1534 cd          else
1535 cd            rrij=rrsave(ind)
1536 cd          endif
1537             rij=dsqrt(rrij)
1538 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1539             call sc_angular
1540 C Calculate whole angle-dependent part of epsilon and contributions
1541 C to its derivatives
1542 C have you changed here?
1543             fac=(rrij*sigsq)**expon2
1544             e1=fac*fac*aa
1545             e2=fac*bb
1546             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1547             eps2der=evdwij*eps3rt
1548             eps3der=evdwij*eps2rt
1549             evdwij=evdwij*eps2rt*eps3rt
1550             evdw=evdw+evdwij
1551             if (lprn) then
1552             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1553             epsi=bb**2/aa
1554 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1555 cd     &        restyp(itypi),i,restyp(itypj),j,
1556 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1557 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1558 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1559 cd     &        evdwij
1560             endif
1561 C Calculate gradient components.
1562             e1=e1*eps1*eps2rt**2*eps3rt**2
1563             fac=-expon*(e1+evdwij)
1564             sigder=fac/sigsq
1565             fac=rrij*fac
1566 C Calculate radial part of the gradient
1567             gg(1)=xj*fac
1568             gg(2)=yj*fac
1569             gg(3)=zj*fac
1570 C Calculate the angular part of the gradient and sum add the contributions
1571 C to the appropriate components of the Cartesian gradient.
1572             call sc_grad
1573           enddo      ! j
1574         enddo        ! iint
1575       enddo          ! i
1576 c     stop
1577       return
1578       end
1579 C-----------------------------------------------------------------------------
1580       subroutine egb(evdw)
1581 C
1582 C This subroutine calculates the interaction energy of nonbonded side chains
1583 C assuming the Gay-Berne potential of interaction.
1584 C
1585       implicit real*8 (a-h,o-z)
1586       include 'DIMENSIONS'
1587       include 'COMMON.GEO'
1588       include 'COMMON.VAR'
1589       include 'COMMON.LOCAL'
1590       include 'COMMON.CHAIN'
1591       include 'COMMON.DERIV'
1592       include 'COMMON.NAMES'
1593       include 'COMMON.INTERACT'
1594       include 'COMMON.IOUNITS'
1595       include 'COMMON.CALC'
1596       include 'COMMON.CONTROL'
1597       include 'COMMON.SPLITELE'
1598       include 'COMMON.SBRIDGE'
1599       logical lprn
1600       integer xshift,yshift,zshift
1601
1602       evdw=0.0D0
1603 ccccc      energy_dec=.false.
1604 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1605       evdw=0.0D0
1606       lprn=.false.
1607 c     if (icall.eq.0) lprn=.false.
1608       ind=0
1609 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1610 C we have the original box)
1611 C      do xshift=-1,1
1612 C      do yshift=-1,1
1613 C      do zshift=-1,1
1614       do i=iatsc_s,iatsc_e
1615         itypi=iabs(itype(i))
1616         if (itypi.eq.ntyp1) cycle
1617         itypi1=iabs(itype(i+1))
1618         xi=c(1,nres+i)
1619         yi=c(2,nres+i)
1620         zi=c(3,nres+i)
1621 C Return atom into box, boxxsize is size of box in x dimension
1622 c  134   continue
1623 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1624 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1625 C Condition for being inside the proper box
1626 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1627 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1628 c        go to 134
1629 c        endif
1630 c  135   continue
1631 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1632 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1633 C Condition for being inside the proper box
1634 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1635 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1636 c        go to 135
1637 c        endif
1638 c  136   continue
1639 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1640 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1641 C Condition for being inside the proper box
1642 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1643 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1644 c        go to 136
1645 c        endif
1646           xi=mod(xi,boxxsize)
1647           if (xi.lt.0) xi=xi+boxxsize
1648           yi=mod(yi,boxysize)
1649           if (yi.lt.0) yi=yi+boxysize
1650           zi=mod(zi,boxzsize)
1651           if (zi.lt.0) zi=zi+boxzsize
1652 C define scaling factor for lipids
1653
1654 C        if (positi.le.0) positi=positi+boxzsize
1655 C        print *,i
1656 C first for peptide groups
1657 c for each residue check if it is in lipid or lipid water border area
1658        if ((zi.gt.bordlipbot)
1659      &.and.(zi.lt.bordliptop)) then
1660 C the energy transfer exist
1661         if (zi.lt.buflipbot) then
1662 C what fraction I am in
1663          fracinbuf=1.0d0-
1664      &        ((zi-bordlipbot)/lipbufthick)
1665 C lipbufthick is thickenes of lipid buffore
1666          sslipi=sscalelip(fracinbuf)
1667          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1668         elseif (zi.gt.bufliptop) then
1669          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1670          sslipi=sscalelip(fracinbuf)
1671          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1672         else
1673          sslipi=1.0d0
1674          ssgradlipi=0.0
1675         endif
1676        else
1677          sslipi=0.0d0
1678          ssgradlipi=0.0
1679        endif
1680
1681 C          xi=xi+xshift*boxxsize
1682 C          yi=yi+yshift*boxysize
1683 C          zi=zi+zshift*boxzsize
1684
1685         dxi=dc_norm(1,nres+i)
1686         dyi=dc_norm(2,nres+i)
1687         dzi=dc_norm(3,nres+i)
1688 c        dsci_inv=dsc_inv(itypi)
1689         dsci_inv=vbld_inv(i+nres)
1690 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1691 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1692 C
1693 C Calculate SC interaction energy.
1694 C
1695         do iint=1,nint_gr(i)
1696           do j=istart(i,iint),iend(i,iint)
1697             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1698
1699 c              write(iout,*) "PRZED ZWYKLE", evdwij
1700               call dyn_ssbond_ene(i,j,evdwij)
1701 c              write(iout,*) "PO ZWYKLE", evdwij
1702
1703               evdw=evdw+evdwij
1704               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1705      &                        'evdw',i,j,evdwij,' ss'
1706 C triple bond artifac removal
1707              do k=j+1,iend(i,iint)
1708 C search over all next residues
1709               if (dyn_ss_mask(k)) then
1710 C check if they are cysteins
1711 C              write(iout,*) 'k=',k
1712
1713 c              write(iout,*) "PRZED TRI", evdwij
1714                evdwij_przed_tri=evdwij
1715               call triple_ssbond_ene(i,j,k,evdwij)
1716 c               if(evdwij_przed_tri.ne.evdwij) then
1717 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1718 c               endif
1719
1720 c              write(iout,*) "PO TRI", evdwij
1721 C call the energy function that removes the artifical triple disulfide
1722 C bond the soubroutine is located in ssMD.F
1723               evdw=evdw+evdwij
1724               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1725      &                        'evdw',i,j,evdwij,'tss'
1726               endif!dyn_ss_mask(k)
1727              enddo! k
1728             ELSE
1729             ind=ind+1
1730             itypj=iabs(itype(j))
1731             if (itypj.eq.ntyp1) cycle
1732 c            dscj_inv=dsc_inv(itypj)
1733             dscj_inv=vbld_inv(j+nres)
1734 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1735 c     &       1.0d0/vbld(j+nres)
1736 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1737             sig0ij=sigma(itypi,itypj)
1738             chi1=chi(itypi,itypj)
1739             chi2=chi(itypj,itypi)
1740             chi12=chi1*chi2
1741             chip1=chip(itypi)
1742             chip2=chip(itypj)
1743             chip12=chip1*chip2
1744             alf1=alp(itypi)
1745             alf2=alp(itypj)
1746             alf12=0.5D0*(alf1+alf2)
1747 C For diagnostics only!!!
1748 c           chi1=0.0D0
1749 c           chi2=0.0D0
1750 c           chi12=0.0D0
1751 c           chip1=0.0D0
1752 c           chip2=0.0D0
1753 c           chip12=0.0D0
1754 c           alf1=0.0D0
1755 c           alf2=0.0D0
1756 c           alf12=0.0D0
1757             xj=c(1,nres+j)
1758             yj=c(2,nres+j)
1759             zj=c(3,nres+j)
1760 C Return atom J into box the original box
1761 c  137   continue
1762 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1763 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1764 C Condition for being inside the proper box
1765 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1766 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1767 c        go to 137
1768 c        endif
1769 c  138   continue
1770 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1771 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1772 C Condition for being inside the proper box
1773 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1774 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1775 c        go to 138
1776 c        endif
1777 c  139   continue
1778 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1779 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1780 C Condition for being inside the proper box
1781 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1782 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1783 c        go to 139
1784 c        endif
1785           xj=mod(xj,boxxsize)
1786           if (xj.lt.0) xj=xj+boxxsize
1787           yj=mod(yj,boxysize)
1788           if (yj.lt.0) yj=yj+boxysize
1789           zj=mod(zj,boxzsize)
1790           if (zj.lt.0) zj=zj+boxzsize
1791        if ((zj.gt.bordlipbot)
1792      &.and.(zj.lt.bordliptop)) then
1793 C the energy transfer exist
1794         if (zj.lt.buflipbot) then
1795 C what fraction I am in
1796          fracinbuf=1.0d0-
1797      &        ((zj-bordlipbot)/lipbufthick)
1798 C lipbufthick is thickenes of lipid buffore
1799          sslipj=sscalelip(fracinbuf)
1800          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1801         elseif (zj.gt.bufliptop) then
1802          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1803          sslipj=sscalelip(fracinbuf)
1804          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1805         else
1806          sslipj=1.0d0
1807          ssgradlipj=0.0
1808         endif
1809        else
1810          sslipj=0.0d0
1811          ssgradlipj=0.0
1812        endif
1813       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1814      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1815       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1816      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1817 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1818 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1819 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1820 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1821 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1822       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1823       xj_safe=xj
1824       yj_safe=yj
1825       zj_safe=zj
1826       subchap=0
1827       do xshift=-1,1
1828       do yshift=-1,1
1829       do zshift=-1,1
1830           xj=xj_safe+xshift*boxxsize
1831           yj=yj_safe+yshift*boxysize
1832           zj=zj_safe+zshift*boxzsize
1833           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1834           if(dist_temp.lt.dist_init) then
1835             dist_init=dist_temp
1836             xj_temp=xj
1837             yj_temp=yj
1838             zj_temp=zj
1839             subchap=1
1840           endif
1841        enddo
1842        enddo
1843        enddo
1844        if (subchap.eq.1) then
1845           xj=xj_temp-xi
1846           yj=yj_temp-yi
1847           zj=zj_temp-zi
1848        else
1849           xj=xj_safe-xi
1850           yj=yj_safe-yi
1851           zj=zj_safe-zi
1852        endif
1853             dxj=dc_norm(1,nres+j)
1854             dyj=dc_norm(2,nres+j)
1855             dzj=dc_norm(3,nres+j)
1856 C            xj=xj-xi
1857 C            yj=yj-yi
1858 C            zj=zj-zi
1859 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1860 c            write (iout,*) "j",j," dc_norm",
1861 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1862             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1863             rij=dsqrt(rrij)
1864             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1865             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1866
1867 c            write (iout,'(a7,4f8.3)')
1868 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1869             if (sss.gt.0.0d0) then
1870 C Calculate angle-dependent terms of energy and contributions to their
1871 C derivatives.
1872             call sc_angular
1873             sigsq=1.0D0/sigsq
1874             sig=sig0ij*dsqrt(sigsq)
1875             rij_shift=1.0D0/rij-sig+sig0ij
1876 c for diagnostics; uncomment
1877 c            rij_shift=1.2*sig0ij
1878 C I hate to put IF's in the loops, but here don't have another choice!!!!
1879             if (rij_shift.le.0.0D0) then
1880               evdw=1.0D20
1881 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1882 cd     &        restyp(itypi),i,restyp(itypj),j,
1883 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1884               return
1885             endif
1886             sigder=-sig*sigsq
1887 c---------------------------------------------------------------
1888             rij_shift=1.0D0/rij_shift
1889             fac=rij_shift**expon
1890 C here to start with
1891 C            if (c(i,3).gt.
1892             faclip=fac
1893             e1=fac*fac*aa
1894             e2=fac*bb
1895             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1896             eps2der=evdwij*eps3rt
1897             eps3der=evdwij*eps2rt
1898 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1899 C     &((sslipi+sslipj)/2.0d0+
1900 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1901 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1902 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1903             evdwij=evdwij*eps2rt*eps3rt
1904             evdw=evdw+evdwij*sss
1905             if (lprn) then
1906             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1907             epsi=bb**2/aa
1908             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1909      &        restyp(itypi),i,restyp(itypj),j,
1910      &        epsi,sigm,chi1,chi2,chip1,chip2,
1911      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1912      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1913      &        evdwij
1914             endif
1915
1916             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1917      &                        'evdw',i,j,evdwij
1918
1919 C Calculate gradient components.
1920             e1=e1*eps1*eps2rt**2*eps3rt**2
1921             fac=-expon*(e1+evdwij)*rij_shift
1922             sigder=fac*sigder
1923             fac=rij*fac
1924 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1925 c     &      evdwij,fac,sigma(itypi,itypj),expon
1926             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1927 c            fac=0.0d0
1928 C Calculate the radial part of the gradient
1929             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1930      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1931      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1932      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1933             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1934             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1935 C            gg_lipi(3)=0.0d0
1936 C            gg_lipj(3)=0.0d0
1937             gg(1)=xj*fac
1938             gg(2)=yj*fac
1939             gg(3)=zj*fac
1940 C Calculate angular part of the gradient.
1941             call sc_grad
1942             endif
1943             ENDIF    ! dyn_ss
1944           enddo      ! j
1945         enddo        ! iint
1946       enddo          ! i
1947 C      enddo          ! zshift
1948 C      enddo          ! yshift
1949 C      enddo          ! xshift
1950 c      write (iout,*) "Number of loop steps in EGB:",ind
1951 cccc      energy_dec=.false.
1952       return
1953       end
1954 C-----------------------------------------------------------------------------
1955       subroutine egbv(evdw)
1956 C
1957 C This subroutine calculates the interaction energy of nonbonded side chains
1958 C assuming the Gay-Berne-Vorobjev potential of interaction.
1959 C
1960       implicit real*8 (a-h,o-z)
1961       include 'DIMENSIONS'
1962       include 'COMMON.CONTROL'
1963       include 'COMMON.GEO'
1964       include 'COMMON.VAR'
1965       include 'COMMON.LOCAL'
1966       include 'COMMON.CHAIN'
1967       include 'COMMON.DERIV'
1968       include 'COMMON.NAMES'
1969       include 'COMMON.INTERACT'
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.CALC'
1972       include 'COMMON.SPLITELE'
1973       include 'COMMON.SBRIDGE'
1974       integer xshift,yshift,zshift
1975       common /srutu/ icall
1976       logical lprn
1977       evdw=0.0D0
1978 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1979       evdw=0.0D0
1980       lprn=.false.
1981 c     if (icall.eq.0) lprn=.true.
1982       ind=0
1983       do i=iatsc_s,iatsc_e
1984         itypi=iabs(itype(i))
1985         if (itypi.eq.ntyp1) cycle
1986         itypi1=iabs(itype(i+1))
1987         xi=c(1,nres+i)
1988         yi=c(2,nres+i)
1989         zi=c(3,nres+i)
1990 c        write (iout,*)"xi yi zi box",xi,yi,zi,boxxsize,boxysize,boxzsize
1991         xi=mod(xi,boxxsize)
1992         if (xi.lt.0) xi=xi+boxxsize
1993         yi=mod(yi,boxysize)
1994         if (yi.lt.0) yi=yi+boxysize
1995         zi=mod(zi,boxzsize)
1996         if (zi.lt.0) zi=zi+boxzsize
1997 c        write (iout,*)"xi yi zi box",xi,yi,zi,boxxsize,boxysize,boxzsize
1998 C define scaling factor for lipids
1999
2000 C        if (positi.le.0) positi=positi+boxzsize
2001 C        print *,i
2002 C first for peptide groups
2003 c for each residue check if it is in lipid or lipid water border area
2004         if ((zi.gt.bordlipbot)
2005      &   .and.(zi.lt.bordliptop)) then
2006 C the energy transfer exist
2007           if (zi.lt.buflipbot) then
2008 C what fraction I am in
2009             fracinbuf=1.0d0-
2010      &        ((zi-bordlipbot)/lipbufthick)
2011 C lipbufthick is thickenes of lipid buffore
2012             sslipi=sscalelip(fracinbuf)
2013             ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2014           elseif (zi.gt.bufliptop) then
2015             fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2016             sslipi=sscalelip(fracinbuf)
2017             ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2018           else
2019             sslipi=1.0d0
2020             ssgradlipi=0.0
2021           endif
2022         else
2023           sslipi=0.0d0
2024           ssgradlipi=0.0
2025         endif
2026
2027         dxi=dc_norm(1,nres+i)
2028         dyi=dc_norm(2,nres+i)
2029         dzi=dc_norm(3,nres+i)
2030 c        dsci_inv=dsc_inv(itypi)
2031         dsci_inv=vbld_inv(i+nres)
2032 C
2033 C Calculate SC interaction energy.
2034 C
2035         do iint=1,nint_gr(i)
2036           do j=istart(i,iint),iend(i,iint)
2037             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2038
2039               call dyn_ssbond_ene(i,j,evdwij)
2040               evdw=evdw+evdwij
2041               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2042      &                        'evdw',i,j,evdwij,' ss'
2043 C triple bond artifac removal
2044              do k=j+1,iend(i,iint)
2045 C search over all next residues
2046               if (dyn_ss_mask(k)) then
2047 C check if they are cysteins
2048 C              write(iout,*) 'k=',k
2049
2050 c              write(iout,*) "PRZED TRI", evdwij
2051                evdwij_przed_tri=evdwij
2052               call triple_ssbond_ene(i,j,k,evdwij)
2053 c               if(evdwij_przed_tri.ne.evdwij) then
2054 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2055 c               endif
2056
2057 c              write(iout,*) "PO TRI", evdwij
2058 C call the energy function that removes the artifical triple disulfide
2059 C bond the soubroutine is located in ssMD.F
2060               evdw=evdw+evdwij
2061               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2062      &                        'evdw',i,j,evdwij,'tss'
2063               endif!dyn_ss_mask(k)
2064              enddo! k
2065             ELSE
2066             ind=ind+1
2067             itypj=iabs(itype(j))
2068             if (itypj.eq.ntyp1) cycle
2069 c            dscj_inv=dsc_inv(itypj)
2070             dscj_inv=vbld_inv(j+nres)
2071             sig0ij=sigma(itypi,itypj)
2072             r0ij=r0(itypi,itypj)
2073             chi1=chi(itypi,itypj)
2074             chi2=chi(itypj,itypi)
2075             chi12=chi1*chi2
2076             chip1=chip(itypi)
2077             chip2=chip(itypj)
2078             chip12=chip1*chip2
2079             alf1=alp(itypi)
2080             alf2=alp(itypj)
2081             alf12=0.5D0*(alf1+alf2)
2082 C For diagnostics only!!!
2083 c           chi1=0.0D0
2084 c           chi2=0.0D0
2085 c           chi12=0.0D0
2086 c           chip1=0.0D0
2087 c           chip2=0.0D0
2088 c           chip12=0.0D0
2089 c           alf1=0.0D0
2090 c           alf2=0.0D0
2091 c           alf12=0.0D0
2092 C            xj=c(1,nres+j)-xi
2093 C            yj=c(2,nres+j)-yi
2094 C            zj=c(3,nres+j)-zi
2095             xj=c(1,nres+j)
2096             yj=c(2,nres+j)
2097             zj=c(3,nres+j)
2098 c        write (iout,*)"xj yj zj box",xj,yj,zj,boxxsize,boxysize,boxzsize
2099             xj=mod(xj,boxxsize)
2100             if (xj.lt.0) xj=xj+boxxsize
2101             yj=mod(yj,boxysize)
2102             if (yj.lt.0) yj=yj+boxysize
2103             zj=mod(zj,boxzsize)
2104             if (zj.lt.0) zj=zj+boxzsize
2105 c        write (iout,*)"xj yj zj box",xj,yj,zj,boxxsize,boxysize,boxzsize
2106             if ((zj.gt.bordlipbot)
2107      &        .and.(zj.lt.bordliptop)) then
2108 C the energy transfer exist
2109               if (zj.lt.buflipbot) then
2110 C what fraction I am in
2111                 fracinbuf=1.0d0-
2112      &          ((zj-bordlipbot)/lipbufthick)
2113 C lipbufthick is thickenes of lipid buffore
2114                 sslipj=sscalelip(fracinbuf)
2115                 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2116               elseif (zj.gt.bufliptop) then
2117                 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2118                 sslipj=sscalelip(fracinbuf)
2119                 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2120               else
2121                 sslipj=1.0d0
2122                 ssgradlipj=0.0
2123               endif
2124             else
2125               sslipj=0.0d0
2126               ssgradlipj=0.0
2127             endif
2128             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2129      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2130             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2131      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2132             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2133 c            write (iout,*) "dist_init",dist_init
2134             xj_safe=xj
2135             yj_safe=yj
2136             zj_safe=zj
2137             subchap=0
2138             do xshift=-1,1
2139               do yshift=-1,1
2140                 do zshift=-1,1
2141                   xj=xj_safe+xshift*boxxsize
2142                   yj=yj_safe+yshift*boxysize
2143                   zj=zj_safe+zshift*boxzsize
2144                   dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2145                   if(dist_temp.lt.dist_init) then
2146                     dist_init=dist_temp
2147                     xj_temp=xj
2148                     yj_temp=yj
2149                     zj_temp=zj
2150                     subchap=1
2151                   endif
2152                 enddo
2153               enddo
2154             enddo
2155             if (subchap.eq.1) then
2156               xj=xj_temp-xi
2157               yj=yj_temp-yi
2158               zj=zj_temp-zi
2159             else
2160               xj=xj_safe-xi
2161               yj=yj_safe-yi
2162               zj=zj_safe-zi
2163             endif
2164             dxj=dc_norm(1,nres+j)
2165             dyj=dc_norm(2,nres+j)
2166             dzj=dc_norm(3,nres+j)
2167             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2168             rij=dsqrt(rrij)
2169             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2170             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2171
2172             if (sss.gt.0.0d0) then
2173
2174 C Calculate angle-dependent terms of energy and contributions to their
2175 C derivatives.
2176             call sc_angular
2177             sigsq=1.0D0/sigsq
2178             sig=sig0ij*dsqrt(sigsq)
2179             rij_shift=1.0D0/rij-sig+r0ij
2180 C I hate to put IF's in the loops, but here don't have another choice!!!!
2181             if (rij_shift.le.0.0D0) then
2182               evdw=1.0D20
2183               return
2184             endif
2185             sigder=-sig*sigsq
2186 c---------------------------------------------------------------
2187             rij_shift=1.0D0/rij_shift
2188             fac=rij_shift**expon
2189             e1=fac*fac*aa
2190             e2=fac*bb
2191             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2192             eps2der=evdwij*eps3rt
2193             eps3der=evdwij*eps2rt
2194             fac_augm=rrij**expon
2195             e_augm=augm(itypi,itypj)*fac_augm
2196             evdwij=evdwij*eps2rt*eps3rt
2197             evdw=evdw+evdwij+e_augm
2198             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2199      &                        'evdw',i,j,evdwij
2200             if (lprn) then
2201             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2202             epsi=bb**2/aa
2203             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2204      &        restyp(itypi),i,restyp(itypj),j,
2205      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2206      &        chi1,chi2,chip1,chip2,
2207      &        eps1,eps2rt**2,eps3rt**2,
2208      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2209      &        evdwij+e_augm
2210             endif
2211 C Calculate gradient components.
2212             e1=e1*eps1*eps2rt**2*eps3rt**2
2213             fac=-expon*(e1+evdwij)*rij_shift
2214             sigder=fac*sigder
2215             fac=rij*fac-2*expon*rrij*e_augm
2216             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2217 C Calculate the radial part of the gradient
2218             gg(1)=xj*fac
2219             gg(2)=yj*fac
2220             gg(3)=zj*fac
2221 c            write (iout,*) "sss",sss," fac",fac," gg",gg
2222 C Calculate angular part of the gradient.
2223             call sc_grad
2224             endif
2225             ENDIF
2226           enddo      ! j
2227         enddo        ! iint
2228       enddo          ! i
2229       end
2230 C-----------------------------------------------------------------------------
2231       subroutine sc_angular
2232 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2233 C om12. Called by ebp, egb, and egbv.
2234       implicit none
2235       include 'COMMON.CALC'
2236       include 'COMMON.IOUNITS'
2237       erij(1)=xj*rij
2238       erij(2)=yj*rij
2239       erij(3)=zj*rij
2240       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2241       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2242       om12=dxi*dxj+dyi*dyj+dzi*dzj
2243       chiom12=chi12*om12
2244 C Calculate eps1(om12) and its derivative in om12
2245       faceps1=1.0D0-om12*chiom12
2246       faceps1_inv=1.0D0/faceps1
2247       eps1=dsqrt(faceps1_inv)
2248 C Following variable is eps1*deps1/dom12
2249       eps1_om12=faceps1_inv*chiom12
2250 c diagnostics only
2251 c      faceps1_inv=om12
2252 c      eps1=om12
2253 c      eps1_om12=1.0d0
2254 c      write (iout,*) "om12",om12," eps1",eps1
2255 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2256 C and om12.
2257       om1om2=om1*om2
2258       chiom1=chi1*om1
2259       chiom2=chi2*om2
2260       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2261       sigsq=1.0D0-facsig*faceps1_inv
2262       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2263       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2264       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2265 c diagnostics only
2266 c      sigsq=1.0d0
2267 c      sigsq_om1=0.0d0
2268 c      sigsq_om2=0.0d0
2269 c      sigsq_om12=0.0d0
2270 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2271 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2272 c     &    " eps1",eps1
2273 C Calculate eps2 and its derivatives in om1, om2, and om12.
2274       chipom1=chip1*om1
2275       chipom2=chip2*om2
2276       chipom12=chip12*om12
2277       facp=1.0D0-om12*chipom12
2278       facp_inv=1.0D0/facp
2279       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2280 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2281 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2282 C Following variable is the square root of eps2
2283       eps2rt=1.0D0-facp1*facp_inv
2284 C Following three variables are the derivatives of the square root of eps
2285 C in om1, om2, and om12.
2286       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2287       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2288       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2289 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2290       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2291 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2292 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2293 c     &  " eps2rt_om12",eps2rt_om12
2294 C Calculate whole angle-dependent part of epsilon and contributions
2295 C to its derivatives
2296       return
2297       end
2298 C----------------------------------------------------------------------------
2299       subroutine sc_grad
2300       implicit real*8 (a-h,o-z)
2301       include 'DIMENSIONS'
2302       include 'COMMON.CHAIN'
2303       include 'COMMON.DERIV'
2304       include 'COMMON.CALC'
2305       include 'COMMON.IOUNITS'
2306       double precision dcosom1(3),dcosom2(3)
2307 cc      print *,'sss=',sss
2308       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2309       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2310       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2311      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2312 c diagnostics only
2313 c      eom1=0.0d0
2314 c      eom2=0.0d0
2315 c      eom12=evdwij*eps1_om12
2316 c end diagnostics
2317 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2318 c     &  " sigder",sigder
2319 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2320 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2321       do k=1,3
2322         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2323         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2324       enddo
2325       do k=1,3
2326         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2327       enddo
2328 c      write (iout,*) "gg",(gg(k),k=1,3)
2329       do k=1,3
2330         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2331      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2332      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2333         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2334      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2335      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2336 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2337 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2338 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2339 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2340       enddo
2341 C
2342 C Calculate the components of the gradient in DC and X
2343 C
2344 cgrad      do k=i,j-1
2345 cgrad        do l=1,3
2346 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2347 cgrad        enddo
2348 cgrad      enddo
2349       do l=1,3
2350         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2351         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2352       enddo
2353       return
2354       end
2355 C-----------------------------------------------------------------------
2356       subroutine e_softsphere(evdw)
2357 C
2358 C This subroutine calculates the interaction energy of nonbonded side chains
2359 C assuming the LJ potential of interaction.
2360 C
2361       implicit real*8 (a-h,o-z)
2362       include 'DIMENSIONS'
2363       parameter (accur=1.0d-10)
2364       include 'COMMON.GEO'
2365       include 'COMMON.VAR'
2366       include 'COMMON.LOCAL'
2367       include 'COMMON.CHAIN'
2368       include 'COMMON.DERIV'
2369       include 'COMMON.INTERACT'
2370       include 'COMMON.TORSION'
2371       include 'COMMON.SBRIDGE'
2372       include 'COMMON.NAMES'
2373       include 'COMMON.IOUNITS'
2374       include 'COMMON.CONTACTS'
2375       dimension gg(3)
2376 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2377       evdw=0.0D0
2378       do i=iatsc_s,iatsc_e
2379         itypi=iabs(itype(i))
2380         if (itypi.eq.ntyp1) cycle
2381         itypi1=iabs(itype(i+1))
2382         xi=c(1,nres+i)
2383         yi=c(2,nres+i)
2384         zi=c(3,nres+i)
2385 C
2386 C Calculate SC interaction energy.
2387 C
2388         do iint=1,nint_gr(i)
2389 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2390 cd   &                  'iend=',iend(i,iint)
2391           do j=istart(i,iint),iend(i,iint)
2392             itypj=iabs(itype(j))
2393             if (itypj.eq.ntyp1) cycle
2394             xj=c(1,nres+j)-xi
2395             yj=c(2,nres+j)-yi
2396             zj=c(3,nres+j)-zi
2397             rij=xj*xj+yj*yj+zj*zj
2398 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2399             r0ij=r0(itypi,itypj)
2400             r0ijsq=r0ij*r0ij
2401 c            print *,i,j,r0ij,dsqrt(rij)
2402             if (rij.lt.r0ijsq) then
2403               evdwij=0.25d0*(rij-r0ijsq)**2
2404               fac=rij-r0ijsq
2405             else
2406               evdwij=0.0d0
2407               fac=0.0d0
2408             endif
2409             evdw=evdw+evdwij
2410 C
2411 C Calculate the components of the gradient in DC and X
2412 C
2413             gg(1)=xj*fac
2414             gg(2)=yj*fac
2415             gg(3)=zj*fac
2416             do k=1,3
2417               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2418               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2419               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2420               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2421             enddo
2422 cgrad            do k=i,j-1
2423 cgrad              do l=1,3
2424 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2425 cgrad              enddo
2426 cgrad            enddo
2427           enddo ! j
2428         enddo ! iint
2429       enddo ! i
2430       return
2431       end
2432 C--------------------------------------------------------------------------
2433       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2434      &              eello_turn4)
2435 C
2436 C Soft-sphere potential of p-p interaction
2437 C
2438       implicit real*8 (a-h,o-z)
2439       include 'DIMENSIONS'
2440       include 'COMMON.CONTROL'
2441       include 'COMMON.IOUNITS'
2442       include 'COMMON.GEO'
2443       include 'COMMON.VAR'
2444       include 'COMMON.LOCAL'
2445       include 'COMMON.CHAIN'
2446       include 'COMMON.DERIV'
2447       include 'COMMON.INTERACT'
2448       include 'COMMON.CONTACTS'
2449       include 'COMMON.TORSION'
2450       include 'COMMON.VECTORS'
2451       include 'COMMON.FFIELD'
2452       dimension ggg(3)
2453       integer xshift,yshift,zshift
2454 C      write(iout,*) 'In EELEC_soft_sphere'
2455       ees=0.0D0
2456       evdw1=0.0D0
2457       eel_loc=0.0d0
2458       eello_turn3=0.0d0
2459       eello_turn4=0.0d0
2460       ind=0
2461       do i=iatel_s,iatel_e
2462         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2463         dxi=dc(1,i)
2464         dyi=dc(2,i)
2465         dzi=dc(3,i)
2466         xmedi=c(1,i)+0.5d0*dxi
2467         ymedi=c(2,i)+0.5d0*dyi
2468         zmedi=c(3,i)+0.5d0*dzi
2469           xmedi=mod(xmedi,boxxsize)
2470           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2471           ymedi=mod(ymedi,boxysize)
2472           if (ymedi.lt.0) ymedi=ymedi+boxysize
2473           zmedi=mod(zmedi,boxzsize)
2474           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2475         num_conti=0
2476 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2477         do j=ielstart(i),ielend(i)
2478           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2479           ind=ind+1
2480           iteli=itel(i)
2481           itelj=itel(j)
2482           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2483           r0ij=rpp(iteli,itelj)
2484           r0ijsq=r0ij*r0ij
2485           dxj=dc(1,j)
2486           dyj=dc(2,j)
2487           dzj=dc(3,j)
2488           xj=c(1,j)+0.5D0*dxj
2489           yj=c(2,j)+0.5D0*dyj
2490           zj=c(3,j)+0.5D0*dzj
2491           xj=mod(xj,boxxsize)
2492           if (xj.lt.0) xj=xj+boxxsize
2493           yj=mod(yj,boxysize)
2494           if (yj.lt.0) yj=yj+boxysize
2495           zj=mod(zj,boxzsize)
2496           if (zj.lt.0) zj=zj+boxzsize
2497       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2498       xj_safe=xj
2499       yj_safe=yj
2500       zj_safe=zj
2501       isubchap=0
2502       do xshift=-1,1
2503       do yshift=-1,1
2504       do zshift=-1,1
2505           xj=xj_safe+xshift*boxxsize
2506           yj=yj_safe+yshift*boxysize
2507           zj=zj_safe+zshift*boxzsize
2508           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2509           if(dist_temp.lt.dist_init) then
2510             dist_init=dist_temp
2511             xj_temp=xj
2512             yj_temp=yj
2513             zj_temp=zj
2514             isubchap=1
2515           endif
2516        enddo
2517        enddo
2518        enddo
2519        if (isubchap.eq.1) then
2520           xj=xj_temp-xmedi
2521           yj=yj_temp-ymedi
2522           zj=zj_temp-zmedi
2523        else
2524           xj=xj_safe-xmedi
2525           yj=yj_safe-ymedi
2526           zj=zj_safe-zmedi
2527        endif
2528           rij=xj*xj+yj*yj+zj*zj
2529             sss=sscale(sqrt(rij))
2530             sssgrad=sscagrad(sqrt(rij))
2531           if (rij.lt.r0ijsq) then
2532             evdw1ij=0.25d0*(rij-r0ijsq)**2
2533             fac=rij-r0ijsq
2534           else
2535             evdw1ij=0.0d0
2536             fac=0.0d0
2537           endif
2538           evdw1=evdw1+evdw1ij*sss
2539 C
2540 C Calculate contributions to the Cartesian gradient.
2541 C
2542           ggg(1)=fac*xj*sssgrad
2543           ggg(2)=fac*yj*sssgrad
2544           ggg(3)=fac*zj*sssgrad
2545           do k=1,3
2546             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2547             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2548           enddo
2549 *
2550 * Loop over residues i+1 thru j-1.
2551 *
2552 cgrad          do k=i+1,j-1
2553 cgrad            do l=1,3
2554 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2555 cgrad            enddo
2556 cgrad          enddo
2557         enddo ! j
2558       enddo   ! i
2559 cgrad      do i=nnt,nct-1
2560 cgrad        do k=1,3
2561 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2562 cgrad        enddo
2563 cgrad        do j=i+1,nct-1
2564 cgrad          do k=1,3
2565 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2566 cgrad          enddo
2567 cgrad        enddo
2568 cgrad      enddo
2569       return
2570       end
2571 c------------------------------------------------------------------------------
2572       subroutine vec_and_deriv
2573       implicit real*8 (a-h,o-z)
2574       include 'DIMENSIONS'
2575 #ifdef MPI
2576       include 'mpif.h'
2577 #endif
2578       include 'COMMON.IOUNITS'
2579       include 'COMMON.GEO'
2580       include 'COMMON.VAR'
2581       include 'COMMON.LOCAL'
2582       include 'COMMON.CHAIN'
2583       include 'COMMON.VECTORS'
2584       include 'COMMON.SETUP'
2585       include 'COMMON.TIME1'
2586       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2587 C Compute the local reference systems. For reference system (i), the
2588 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2589 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2590 #ifdef PARVEC
2591       do i=ivec_start,ivec_end
2592 #else
2593       do i=1,nres-1
2594 #endif
2595           if (i.eq.nres-1) then
2596 C Case of the last full residue
2597 C Compute the Z-axis
2598             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2599             costh=dcos(pi-theta(nres))
2600             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2601             do k=1,3
2602               uz(k,i)=fac*uz(k,i)
2603             enddo
2604 C Compute the derivatives of uz
2605             uzder(1,1,1)= 0.0d0
2606             uzder(2,1,1)=-dc_norm(3,i-1)
2607             uzder(3,1,1)= dc_norm(2,i-1)
2608             uzder(1,2,1)= dc_norm(3,i-1)
2609             uzder(2,2,1)= 0.0d0
2610             uzder(3,2,1)=-dc_norm(1,i-1)
2611             uzder(1,3,1)=-dc_norm(2,i-1)
2612             uzder(2,3,1)= dc_norm(1,i-1)
2613             uzder(3,3,1)= 0.0d0
2614             uzder(1,1,2)= 0.0d0
2615             uzder(2,1,2)= dc_norm(3,i)
2616             uzder(3,1,2)=-dc_norm(2,i)
2617             uzder(1,2,2)=-dc_norm(3,i)
2618             uzder(2,2,2)= 0.0d0
2619             uzder(3,2,2)= dc_norm(1,i)
2620             uzder(1,3,2)= dc_norm(2,i)
2621             uzder(2,3,2)=-dc_norm(1,i)
2622             uzder(3,3,2)= 0.0d0
2623 C Compute the Y-axis
2624             facy=fac
2625             do k=1,3
2626               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2627             enddo
2628 C Compute the derivatives of uy
2629             do j=1,3
2630               do k=1,3
2631                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2632      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2633                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2634               enddo
2635               uyder(j,j,1)=uyder(j,j,1)-costh
2636               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2637             enddo
2638             do j=1,2
2639               do k=1,3
2640                 do l=1,3
2641                   uygrad(l,k,j,i)=uyder(l,k,j)
2642                   uzgrad(l,k,j,i)=uzder(l,k,j)
2643                 enddo
2644               enddo
2645             enddo
2646             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2647             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2648             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2649             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2650           else
2651 C Other residues
2652 C Compute the Z-axis
2653             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2654             costh=dcos(pi-theta(i+2))
2655             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2656             do k=1,3
2657               uz(k,i)=fac*uz(k,i)
2658             enddo
2659 C Compute the derivatives of uz
2660             uzder(1,1,1)= 0.0d0
2661             uzder(2,1,1)=-dc_norm(3,i+1)
2662             uzder(3,1,1)= dc_norm(2,i+1)
2663             uzder(1,2,1)= dc_norm(3,i+1)
2664             uzder(2,2,1)= 0.0d0
2665             uzder(3,2,1)=-dc_norm(1,i+1)
2666             uzder(1,3,1)=-dc_norm(2,i+1)
2667             uzder(2,3,1)= dc_norm(1,i+1)
2668             uzder(3,3,1)= 0.0d0
2669             uzder(1,1,2)= 0.0d0
2670             uzder(2,1,2)= dc_norm(3,i)
2671             uzder(3,1,2)=-dc_norm(2,i)
2672             uzder(1,2,2)=-dc_norm(3,i)
2673             uzder(2,2,2)= 0.0d0
2674             uzder(3,2,2)= dc_norm(1,i)
2675             uzder(1,3,2)= dc_norm(2,i)
2676             uzder(2,3,2)=-dc_norm(1,i)
2677             uzder(3,3,2)= 0.0d0
2678 C Compute the Y-axis
2679             facy=fac
2680             do k=1,3
2681               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2682             enddo
2683 C Compute the derivatives of uy
2684             do j=1,3
2685               do k=1,3
2686                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2687      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2688                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2689               enddo
2690               uyder(j,j,1)=uyder(j,j,1)-costh
2691               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2692             enddo
2693             do j=1,2
2694               do k=1,3
2695                 do l=1,3
2696                   uygrad(l,k,j,i)=uyder(l,k,j)
2697                   uzgrad(l,k,j,i)=uzder(l,k,j)
2698                 enddo
2699               enddo
2700             enddo
2701             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2702             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2703             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2704             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2705           endif
2706       enddo
2707       do i=1,nres-1
2708         vbld_inv_temp(1)=vbld_inv(i+1)
2709         if (i.lt.nres-1) then
2710           vbld_inv_temp(2)=vbld_inv(i+2)
2711           else
2712           vbld_inv_temp(2)=vbld_inv(i)
2713           endif
2714         do j=1,2
2715           do k=1,3
2716             do l=1,3
2717               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2718               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2719             enddo
2720           enddo
2721         enddo
2722       enddo
2723 #if defined(PARVEC) && defined(MPI)
2724       if (nfgtasks1.gt.1) then
2725         time00=MPI_Wtime()
2726 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2727 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2728 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2729         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2733      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2734      &   FG_COMM1,IERR)
2735         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2736      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2737      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2738         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2739      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2740      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2741         time_gather=time_gather+MPI_Wtime()-time00
2742       endif
2743 #endif
2744 #ifdef DEBUG
2745       if (fg_rank.eq.0) then
2746         write (iout,*) "Arrays UY and UZ"
2747         do i=1,nres-1
2748           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2749      &     (uz(k,i),k=1,3)
2750         enddo
2751       endif
2752 #endif
2753       return
2754       end
2755 C-----------------------------------------------------------------------------
2756       subroutine check_vecgrad
2757       implicit real*8 (a-h,o-z)
2758       include 'DIMENSIONS'
2759       include 'COMMON.IOUNITS'
2760       include 'COMMON.GEO'
2761       include 'COMMON.VAR'
2762       include 'COMMON.LOCAL'
2763       include 'COMMON.CHAIN'
2764       include 'COMMON.VECTORS'
2765       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2766       dimension uyt(3,maxres),uzt(3,maxres)
2767       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2768       double precision delta /1.0d-7/
2769       call vec_and_deriv
2770 cd      do i=1,nres
2771 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2772 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2773 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2774 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2775 cd     &     (dc_norm(if90,i),if90=1,3)
2776 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2777 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2778 cd          write(iout,'(a)')
2779 cd      enddo
2780       do i=1,nres
2781         do j=1,2
2782           do k=1,3
2783             do l=1,3
2784               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2785               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2786             enddo
2787           enddo
2788         enddo
2789       enddo
2790       call vec_and_deriv
2791       do i=1,nres
2792         do j=1,3
2793           uyt(j,i)=uy(j,i)
2794           uzt(j,i)=uz(j,i)
2795         enddo
2796       enddo
2797       do i=1,nres
2798 cd        write (iout,*) 'i=',i
2799         do k=1,3
2800           erij(k)=dc_norm(k,i)
2801         enddo
2802         do j=1,3
2803           do k=1,3
2804             dc_norm(k,i)=erij(k)
2805           enddo
2806           dc_norm(j,i)=dc_norm(j,i)+delta
2807 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2808 c          do k=1,3
2809 c            dc_norm(k,i)=dc_norm(k,i)/fac
2810 c          enddo
2811 c          write (iout,*) (dc_norm(k,i),k=1,3)
2812 c          write (iout,*) (erij(k),k=1,3)
2813           call vec_and_deriv
2814           do k=1,3
2815             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2816             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2817             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2818             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2819           enddo
2820 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2821 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2822 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2823         enddo
2824         do k=1,3
2825           dc_norm(k,i)=erij(k)
2826         enddo
2827 cd        do k=1,3
2828 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2829 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2830 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2831 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2832 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2833 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2834 cd          write (iout,'(a)')
2835 cd        enddo
2836       enddo
2837       return
2838       end
2839 C--------------------------------------------------------------------------
2840       subroutine set_matrices
2841       implicit real*8 (a-h,o-z)
2842       include 'DIMENSIONS'
2843 #ifdef MPI
2844       include "mpif.h"
2845       include "COMMON.SETUP"
2846       integer IERR
2847       integer status(MPI_STATUS_SIZE)
2848 #endif
2849       include 'COMMON.IOUNITS'
2850       include 'COMMON.GEO'
2851       include 'COMMON.VAR'
2852       include 'COMMON.LOCAL'
2853       include 'COMMON.CHAIN'
2854       include 'COMMON.DERIV'
2855       include 'COMMON.INTERACT'
2856       include 'COMMON.CONTACTS'
2857       include 'COMMON.TORSION'
2858       include 'COMMON.VECTORS'
2859       include 'COMMON.FFIELD'
2860       double precision auxvec(2),auxmat(2,2)
2861 C
2862 C Compute the virtual-bond-torsional-angle dependent quantities needed
2863 C to calculate the el-loc multibody terms of various order.
2864 C
2865 c      write(iout,*) 'nphi=',nphi,nres
2866 c      write(iout,*) "itype2loc",itype2loc
2867 #ifdef PARMAT
2868       do i=ivec_start+2,ivec_end+2
2869 #else
2870       do i=3,nres+1
2871 #endif
2872         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2873           iti = itype2loc(itype(i-2))
2874         else
2875           iti=nloctyp
2876         endif
2877 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2878         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2879           iti1 = itype2loc(itype(i-1))
2880         else
2881           iti1=nloctyp
2882         endif
2883 c        write(iout,*),i
2884 #ifdef NEWCORR
2885         cost1=dcos(theta(i-1))
2886         sint1=dsin(theta(i-1))
2887         sint1sq=sint1*sint1
2888         sint1cub=sint1sq*sint1
2889         sint1cost1=2*sint1*cost1
2890 c        write (iout,*) "bnew1",i,iti
2891 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2892 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2893 c        write (iout,*) "bnew2",i,iti
2894 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2895 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2896         do k=1,2
2897           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2898           b1(k,i-2)=sint1*b1k
2899           gtb1(k,i-2)=cost1*b1k-sint1sq*
2900      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2901           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2902           b2(k,i-2)=sint1*b2k
2903           gtb2(k,i-2)=cost1*b2k-sint1sq*
2904      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2905         enddo
2906         do k=1,2
2907           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2908           cc(1,k,i-2)=sint1sq*aux
2909           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2910      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2911           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2912           dd(1,k,i-2)=sint1sq*aux
2913           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2914      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2915         enddo
2916         cc(2,1,i-2)=cc(1,2,i-2)
2917         cc(2,2,i-2)=-cc(1,1,i-2)
2918         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2919         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2920         dd(2,1,i-2)=dd(1,2,i-2)
2921         dd(2,2,i-2)=-dd(1,1,i-2)
2922         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2923         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2924         do k=1,2
2925           do l=1,2
2926             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2927             EE(l,k,i-2)=sint1sq*aux
2928             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2929           enddo
2930         enddo
2931         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2932         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2933         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2934         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2935         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2936         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2937         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2938 c        b1tilde(1,i-2)=b1(1,i-2)
2939 c        b1tilde(2,i-2)=-b1(2,i-2)
2940 c        b2tilde(1,i-2)=b2(1,i-2)
2941 c        b2tilde(2,i-2)=-b2(2,i-2)
2942 #ifdef DEBUG
2943         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2944         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2945         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2946         write (iout,*) 'theta=', theta(i-1)
2947 #endif
2948 #else
2949         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2950           iti = itype2loc(itype(i-2))
2951         else
2952           iti=nloctyp
2953         endif
2954 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2955 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2956         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2957           iti1 = itype2loc(itype(i-1))
2958         else
2959           iti1=nloctyp
2960         endif
2961         b1(1,i-2)=b(3,iti)
2962         b1(2,i-2)=b(5,iti)
2963         b2(1,i-2)=b(2,iti)
2964         b2(2,i-2)=b(4,iti)
2965         do k=1,2
2966           do l=1,2
2967            CC(k,l,i-2)=ccold(k,l,iti)
2968            DD(k,l,i-2)=ddold(k,l,iti)
2969            EE(k,l,i-2)=eeold(k,l,iti)
2970           enddo
2971         enddo
2972 #endif
2973         b1tilde(1,i-2)= b1(1,i-2)
2974         b1tilde(2,i-2)=-b1(2,i-2)
2975         b2tilde(1,i-2)= b2(1,i-2)
2976         b2tilde(2,i-2)=-b2(2,i-2)
2977 c
2978         Ctilde(1,1,i-2)= CC(1,1,i-2)
2979         Ctilde(1,2,i-2)= CC(1,2,i-2)
2980         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2981         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2982 c
2983         Dtilde(1,1,i-2)= DD(1,1,i-2)
2984         Dtilde(1,2,i-2)= DD(1,2,i-2)
2985         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2986         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2987 #ifdef DEBUG
2988         write(iout,*) "i",i," iti",iti
2989         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2990         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2991 #endif
2992       enddo
2993 #ifdef PARMAT
2994       do i=ivec_start+2,ivec_end+2
2995 #else
2996       do i=3,nres+1
2997 #endif
2998         if (i .lt. nres+1) then
2999           sin1=dsin(phi(i))
3000           cos1=dcos(phi(i))
3001           sintab(i-2)=sin1
3002           costab(i-2)=cos1
3003           obrot(1,i-2)=cos1
3004           obrot(2,i-2)=sin1
3005           sin2=dsin(2*phi(i))
3006           cos2=dcos(2*phi(i))
3007           sintab2(i-2)=sin2
3008           costab2(i-2)=cos2
3009           obrot2(1,i-2)=cos2
3010           obrot2(2,i-2)=sin2
3011           Ug(1,1,i-2)=-cos1
3012           Ug(1,2,i-2)=-sin1
3013           Ug(2,1,i-2)=-sin1
3014           Ug(2,2,i-2)= cos1
3015           Ug2(1,1,i-2)=-cos2
3016           Ug2(1,2,i-2)=-sin2
3017           Ug2(2,1,i-2)=-sin2
3018           Ug2(2,2,i-2)= cos2
3019         else
3020           costab(i-2)=1.0d0
3021           sintab(i-2)=0.0d0
3022           obrot(1,i-2)=1.0d0
3023           obrot(2,i-2)=0.0d0
3024           obrot2(1,i-2)=0.0d0
3025           obrot2(2,i-2)=0.0d0
3026           Ug(1,1,i-2)=1.0d0
3027           Ug(1,2,i-2)=0.0d0
3028           Ug(2,1,i-2)=0.0d0
3029           Ug(2,2,i-2)=1.0d0
3030           Ug2(1,1,i-2)=0.0d0
3031           Ug2(1,2,i-2)=0.0d0
3032           Ug2(2,1,i-2)=0.0d0
3033           Ug2(2,2,i-2)=0.0d0
3034         endif
3035         if (i .gt. 3 .and. i .lt. nres+1) then
3036           obrot_der(1,i-2)=-sin1
3037           obrot_der(2,i-2)= cos1
3038           Ugder(1,1,i-2)= sin1
3039           Ugder(1,2,i-2)=-cos1
3040           Ugder(2,1,i-2)=-cos1
3041           Ugder(2,2,i-2)=-sin1
3042           dwacos2=cos2+cos2
3043           dwasin2=sin2+sin2
3044           obrot2_der(1,i-2)=-dwasin2
3045           obrot2_der(2,i-2)= dwacos2
3046           Ug2der(1,1,i-2)= dwasin2
3047           Ug2der(1,2,i-2)=-dwacos2
3048           Ug2der(2,1,i-2)=-dwacos2
3049           Ug2der(2,2,i-2)=-dwasin2
3050         else
3051           obrot_der(1,i-2)=0.0d0
3052           obrot_der(2,i-2)=0.0d0
3053           Ugder(1,1,i-2)=0.0d0
3054           Ugder(1,2,i-2)=0.0d0
3055           Ugder(2,1,i-2)=0.0d0
3056           Ugder(2,2,i-2)=0.0d0
3057           obrot2_der(1,i-2)=0.0d0
3058           obrot2_der(2,i-2)=0.0d0
3059           Ug2der(1,1,i-2)=0.0d0
3060           Ug2der(1,2,i-2)=0.0d0
3061           Ug2der(2,1,i-2)=0.0d0
3062           Ug2der(2,2,i-2)=0.0d0
3063         endif
3064 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3065         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3066           iti = itype2loc(itype(i-2))
3067         else
3068           iti=nloctyp
3069         endif
3070 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3071         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3072           iti1 = itype2loc(itype(i-1))
3073         else
3074           iti1=nloctyp
3075         endif
3076 cd        write (iout,*) '*******i',i,' iti1',iti
3077 cd        write (iout,*) 'b1',b1(:,iti)
3078 cd        write (iout,*) 'b2',b2(:,iti)
3079 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3080 c        if (i .gt. iatel_s+2) then
3081         if (i .gt. nnt+2) then
3082           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3083 #ifdef NEWCORR
3084           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3085 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3086 #endif
3087 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3088 c     &    EE(1,2,iti),EE(2,2,i)
3089           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3090           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3091 c          write(iout,*) "Macierz EUG",
3092 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3093 c     &    eug(2,2,i-2)
3094           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3095      &    then
3096           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3097           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3098           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3099           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3100           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3101           endif
3102         else
3103           do k=1,2
3104             Ub2(k,i-2)=0.0d0
3105             Ctobr(k,i-2)=0.0d0
3106             Dtobr2(k,i-2)=0.0d0
3107             do l=1,2
3108               EUg(l,k,i-2)=0.0d0
3109               CUg(l,k,i-2)=0.0d0
3110               DUg(l,k,i-2)=0.0d0
3111               DtUg2(l,k,i-2)=0.0d0
3112             enddo
3113           enddo
3114         endif
3115         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3116         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3117         do k=1,2
3118           muder(k,i-2)=Ub2der(k,i-2)
3119         enddo
3120 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3121         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3122           if (itype(i-1).le.ntyp) then
3123             iti1 = itype2loc(itype(i-1))
3124           else
3125             iti1=nloctyp
3126           endif
3127         else
3128           iti1=nloctyp
3129         endif
3130         do k=1,2
3131           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3132 c          mu(k,i-2)=b1(k,i-1)
3133 c          mu(k,i-2)=Ub2(k,i-2)
3134         enddo
3135 #ifdef MUOUT
3136         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3137      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3138      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3139      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3140      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3141      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3142 #endif
3143 cd        write (iout,*) 'mu1',mu1(:,i-2)
3144 cd        write (iout,*) 'mu2',mu2(:,i-2)
3145 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3146         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3147      &  then
3148         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3149         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3150         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3151         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3152         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3153 C Vectors and matrices dependent on a single virtual-bond dihedral.
3154         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3155         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3156         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3157         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3158         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3159         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3160         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3161         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3162         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3163         endif
3164       enddo
3165 C Matrices dependent on two consecutive virtual-bond dihedrals.
3166 C The order of matrices is from left to right.
3167       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3168      &then
3169 c      do i=max0(ivec_start,2),ivec_end
3170       do i=2,nres-1
3171         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3172         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3173         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3174         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3175         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3176         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3177         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3178         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3179       enddo
3180       endif
3181 #if defined(MPI) && defined(PARMAT)
3182 #ifdef DEBUG
3183 c      if (fg_rank.eq.0) then
3184         write (iout,*) "Arrays UG and UGDER before GATHER"
3185         do i=1,nres-1
3186           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3187      &     ((ug(l,k,i),l=1,2),k=1,2),
3188      &     ((ugder(l,k,i),l=1,2),k=1,2)
3189         enddo
3190         write (iout,*) "Arrays UG2 and UG2DER"
3191         do i=1,nres-1
3192           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3193      &     ((ug2(l,k,i),l=1,2),k=1,2),
3194      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3195         enddo
3196         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3197         do i=1,nres-1
3198           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3199      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3200      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3201         enddo
3202         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3203         do i=1,nres-1
3204           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3205      &     costab(i),sintab(i),costab2(i),sintab2(i)
3206         enddo
3207         write (iout,*) "Array MUDER"
3208         do i=1,nres-1
3209           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3210         enddo
3211 c      endif
3212 #endif
3213       if (nfgtasks.gt.1) then
3214         time00=MPI_Wtime()
3215 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3216 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3217 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3218 #ifdef MATGATHER
3219         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3220      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3221      &   FG_COMM1,IERR)
3222         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3223      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3224      &   FG_COMM1,IERR)
3225         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3226      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3227      &   FG_COMM1,IERR)
3228         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3229      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3230      &   FG_COMM1,IERR)
3231         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3232      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3233      &   FG_COMM1,IERR)
3234         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3235      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3236      &   FG_COMM1,IERR)
3237         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3238      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3239      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3240         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3241      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3242      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3243         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3244      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3245      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3246         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3247      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3248      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3249         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3250      &  then
3251         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3253      &   FG_COMM1,IERR)
3254         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3259      &   FG_COMM1,IERR)
3260        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3261      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3262      &   FG_COMM1,IERR)
3263         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3264      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3267      &   ivec_count(fg_rank1),
3268      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3269      &   FG_COMM1,IERR)
3270         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3271      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3272      &   FG_COMM1,IERR)
3273         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3274      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3275      &   FG_COMM1,IERR)
3276         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3277      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278      &   FG_COMM1,IERR)
3279         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3280      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281      &   FG_COMM1,IERR)
3282         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3283      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3292      &   ivec_count(fg_rank1),
3293      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3297      &   FG_COMM1,IERR)
3298        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3299      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3300      &   FG_COMM1,IERR)
3301         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3302      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3303      &   FG_COMM1,IERR)
3304        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3305      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3308      &   ivec_count(fg_rank1),
3309      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3310      &   FG_COMM1,IERR)
3311         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3312      &   ivec_count(fg_rank1),
3313      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3314      &   FG_COMM1,IERR)
3315         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3316      &   ivec_count(fg_rank1),
3317      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3318      &   MPI_MAT2,FG_COMM1,IERR)
3319         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3320      &   ivec_count(fg_rank1),
3321      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3322      &   MPI_MAT2,FG_COMM1,IERR)
3323         endif
3324 #else
3325 c Passes matrix info through the ring
3326       isend=fg_rank1
3327       irecv=fg_rank1-1
3328       if (irecv.lt.0) irecv=nfgtasks1-1
3329       iprev=irecv
3330       inext=fg_rank1+1
3331       if (inext.ge.nfgtasks1) inext=0
3332       do i=1,nfgtasks1-1
3333 c        write (iout,*) "isend",isend," irecv",irecv
3334 c        call flush(iout)
3335         lensend=lentyp(isend)
3336         lenrecv=lentyp(irecv)
3337 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3338 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3339 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3340 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3341 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3342 c        write (iout,*) "Gather ROTAT1"
3343 c        call flush(iout)
3344 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3345 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3346 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3347 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3348 c        write (iout,*) "Gather ROTAT2"
3349 c        call flush(iout)
3350         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3351      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3352      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3353      &   iprev,4400+irecv,FG_COMM,status,IERR)
3354 c        write (iout,*) "Gather ROTAT_OLD"
3355 c        call flush(iout)
3356         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3357      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3358      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3359      &   iprev,5500+irecv,FG_COMM,status,IERR)
3360 c        write (iout,*) "Gather PRECOMP11"
3361 c        call flush(iout)
3362         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3363      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3364      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3365      &   iprev,6600+irecv,FG_COMM,status,IERR)
3366 c        write (iout,*) "Gather PRECOMP12"
3367 c        call flush(iout)
3368         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3369      &  then
3370         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3371      &   MPI_ROTAT2(lensend),inext,7700+isend,
3372      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3373      &   iprev,7700+irecv,FG_COMM,status,IERR)
3374 c        write (iout,*) "Gather PRECOMP21"
3375 c        call flush(iout)
3376         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3377      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3378      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3379      &   iprev,8800+irecv,FG_COMM,status,IERR)
3380 c        write (iout,*) "Gather PRECOMP22"
3381 c        call flush(iout)
3382         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3383      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3384      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3385      &   MPI_PRECOMP23(lenrecv),
3386      &   iprev,9900+irecv,FG_COMM,status,IERR)
3387 c        write (iout,*) "Gather PRECOMP23"
3388 c        call flush(iout)
3389         endif
3390         isend=irecv
3391         irecv=irecv-1
3392         if (irecv.lt.0) irecv=nfgtasks1-1
3393       enddo
3394 #endif
3395         time_gather=time_gather+MPI_Wtime()-time00
3396       endif
3397 #ifdef DEBUG
3398 c      if (fg_rank.eq.0) then
3399         write (iout,*) "Arrays UG and UGDER"
3400         do i=1,nres-1
3401           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3402      &     ((ug(l,k,i),l=1,2),k=1,2),
3403      &     ((ugder(l,k,i),l=1,2),k=1,2)
3404         enddo
3405         write (iout,*) "Arrays UG2 and UG2DER"
3406         do i=1,nres-1
3407           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3408      &     ((ug2(l,k,i),l=1,2),k=1,2),
3409      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3410         enddo
3411         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3412         do i=1,nres-1
3413           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3414      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3415      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3416         enddo
3417         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3418         do i=1,nres-1
3419           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3420      &     costab(i),sintab(i),costab2(i),sintab2(i)
3421         enddo
3422         write (iout,*) "Array MUDER"
3423         do i=1,nres-1
3424           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3425         enddo
3426 c      endif
3427 #endif
3428 #endif
3429 cd      do i=1,nres
3430 cd        iti = itype2loc(itype(i))
3431 cd        write (iout,*) i
3432 cd        do j=1,2
3433 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3434 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3435 cd        enddo
3436 cd      enddo
3437       return
3438       end
3439 C--------------------------------------------------------------------------
3440       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3441 C
3442 C This subroutine calculates the average interaction energy and its gradient
3443 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3444 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3445 C The potential depends both on the distance of peptide-group centers and on
3446 C the orientation of the CA-CA virtual bonds.
3447 C
3448       implicit real*8 (a-h,o-z)
3449 #ifdef MPI
3450       include 'mpif.h'
3451 #endif
3452       include 'DIMENSIONS'
3453       include 'COMMON.CONTROL'
3454       include 'COMMON.SETUP'
3455       include 'COMMON.IOUNITS'
3456       include 'COMMON.GEO'
3457       include 'COMMON.VAR'
3458       include 'COMMON.LOCAL'
3459       include 'COMMON.CHAIN'
3460       include 'COMMON.DERIV'
3461       include 'COMMON.INTERACT'
3462       include 'COMMON.CONTACTS'
3463       include 'COMMON.TORSION'
3464       include 'COMMON.VECTORS'
3465       include 'COMMON.FFIELD'
3466       include 'COMMON.TIME1'
3467       include 'COMMON.SPLITELE'
3468       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3469      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3470       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3471      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3472       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3473      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3474      &    num_conti,j1,j2
3475 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3476 #ifdef MOMENT
3477       double precision scal_el /1.0d0/
3478 #else
3479       double precision scal_el /0.5d0/
3480 #endif
3481 C 12/13/98
3482 C 13-go grudnia roku pamietnego...
3483       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3484      &                   0.0d0,1.0d0,0.0d0,
3485      &                   0.0d0,0.0d0,1.0d0/
3486 cd      write(iout,*) 'In EELEC'
3487 cd      do i=1,nloctyp
3488 cd        write(iout,*) 'Type',i
3489 cd        write(iout,*) 'B1',B1(:,i)
3490 cd        write(iout,*) 'B2',B2(:,i)
3491 cd        write(iout,*) 'CC',CC(:,:,i)
3492 cd        write(iout,*) 'DD',DD(:,:,i)
3493 cd        write(iout,*) 'EE',EE(:,:,i)
3494 cd      enddo
3495 cd      call check_vecgrad
3496 cd      stop
3497       if (icheckgrad.eq.1) then
3498         do i=1,nres-1
3499           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3500           do k=1,3
3501             dc_norm(k,i)=dc(k,i)*fac
3502           enddo
3503 c          write (iout,*) 'i',i,' fac',fac
3504         enddo
3505       endif
3506       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3507      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3508      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3509 c        call vec_and_deriv
3510 #ifdef TIMING
3511         time01=MPI_Wtime()
3512 #endif
3513         call set_matrices
3514 #ifdef TIMING
3515         time_mat=time_mat+MPI_Wtime()-time01
3516 #endif
3517       endif
3518 cd      do i=1,nres-1
3519 cd        write (iout,*) 'i=',i
3520 cd        do k=1,3
3521 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3522 cd        enddo
3523 cd        do k=1,3
3524 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3525 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3526 cd        enddo
3527 cd      enddo
3528       t_eelecij=0.0d0
3529       ees=0.0D0
3530       evdw1=0.0D0
3531       eel_loc=0.0d0
3532       eello_turn3=0.0d0
3533       eello_turn4=0.0d0
3534       ind=0
3535       do i=1,nres
3536         num_cont_hb(i)=0
3537       enddo
3538 cd      print '(a)','Enter EELEC'
3539 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3540       do i=1,nres
3541         gel_loc_loc(i)=0.0d0
3542         gcorr_loc(i)=0.0d0
3543       enddo
3544 c
3545 c
3546 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3547 C
3548 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3549 C
3550 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3551       do i=iturn3_start,iturn3_end
3552 c        if (i.le.1) cycle
3553 C        write(iout,*) "tu jest i",i
3554         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3555 C changes suggested by Ana to avoid out of bounds
3556 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3557 c     & .or.((i+4).gt.nres)
3558 c     & .or.((i-1).le.0)
3559 C end of changes by Ana
3560      &  .or. itype(i+2).eq.ntyp1
3561      &  .or. itype(i+3).eq.ntyp1) cycle
3562 C Adam: Instructions below will switch off existing interactions
3563 c        if(i.gt.1)then
3564 c          if(itype(i-1).eq.ntyp1)cycle
3565 c        end if
3566 c        if(i.LT.nres-3)then
3567 c          if (itype(i+4).eq.ntyp1) cycle
3568 c        end if
3569         dxi=dc(1,i)
3570         dyi=dc(2,i)
3571         dzi=dc(3,i)
3572         dx_normi=dc_norm(1,i)
3573         dy_normi=dc_norm(2,i)
3574         dz_normi=dc_norm(3,i)
3575         xmedi=c(1,i)+0.5d0*dxi
3576         ymedi=c(2,i)+0.5d0*dyi
3577         zmedi=c(3,i)+0.5d0*dzi
3578           xmedi=mod(xmedi,boxxsize)
3579           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3580           ymedi=mod(ymedi,boxysize)
3581           if (ymedi.lt.0) ymedi=ymedi+boxysize
3582           zmedi=mod(zmedi,boxzsize)
3583           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3584         num_conti=0
3585         call eelecij(i,i+2,ees,evdw1,eel_loc)
3586         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3587         num_cont_hb(i)=num_conti
3588       enddo
3589       do i=iturn4_start,iturn4_end
3590         if (i.lt.1) cycle
3591         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3592 C changes suggested by Ana to avoid out of bounds
3593 c     & .or.((i+5).gt.nres)
3594 c     & .or.((i-1).le.0)
3595 C end of changes suggested by Ana
3596      &    .or. itype(i+3).eq.ntyp1
3597      &    .or. itype(i+4).eq.ntyp1
3598 c     &    .or. itype(i+5).eq.ntyp1
3599 c     &    .or. itype(i).eq.ntyp1
3600 c     &    .or. itype(i-1).eq.ntyp1
3601      &                             ) cycle
3602         dxi=dc(1,i)
3603         dyi=dc(2,i)
3604         dzi=dc(3,i)
3605         dx_normi=dc_norm(1,i)
3606         dy_normi=dc_norm(2,i)
3607         dz_normi=dc_norm(3,i)
3608         xmedi=c(1,i)+0.5d0*dxi
3609         ymedi=c(2,i)+0.5d0*dyi
3610         zmedi=c(3,i)+0.5d0*dzi
3611 C Return atom into box, boxxsize is size of box in x dimension
3612 c  194   continue
3613 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3614 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3615 C Condition for being inside the proper box
3616 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3617 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3618 c        go to 194
3619 c        endif
3620 c  195   continue
3621 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3622 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3623 C Condition for being inside the proper box
3624 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3625 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3626 c        go to 195
3627 c        endif
3628 c  196   continue
3629 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3630 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3631 C Condition for being inside the proper box
3632 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3633 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3634 c        go to 196
3635 c        endif
3636           xmedi=mod(xmedi,boxxsize)
3637           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3638           ymedi=mod(ymedi,boxysize)
3639           if (ymedi.lt.0) ymedi=ymedi+boxysize
3640           zmedi=mod(zmedi,boxzsize)
3641           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3642
3643         num_conti=num_cont_hb(i)
3644 c        write(iout,*) "JESTEM W PETLI"
3645         call eelecij(i,i+3,ees,evdw1,eel_loc)
3646         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3647      &   call eturn4(i,eello_turn4)
3648         num_cont_hb(i)=num_conti
3649       enddo   ! i
3650 C Loop over all neighbouring boxes
3651 C      do xshift=-1,1
3652 C      do yshift=-1,1
3653 C      do zshift=-1,1
3654 c
3655 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3656 c
3657 CTU KURWA
3658       do i=iatel_s,iatel_e
3659 C        do i=75,75
3660 c        if (i.le.1) cycle
3661         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3662 C changes suggested by Ana to avoid out of bounds
3663 c     & .or.((i+2).gt.nres)
3664 c     & .or.((i-1).le.0)
3665 C end of changes by Ana
3666 c     &  .or. itype(i+2).eq.ntyp1
3667 c     &  .or. itype(i-1).eq.ntyp1
3668      &                ) cycle
3669         dxi=dc(1,i)
3670         dyi=dc(2,i)
3671         dzi=dc(3,i)
3672         dx_normi=dc_norm(1,i)
3673         dy_normi=dc_norm(2,i)
3674         dz_normi=dc_norm(3,i)
3675         xmedi=c(1,i)+0.5d0*dxi
3676         ymedi=c(2,i)+0.5d0*dyi
3677         zmedi=c(3,i)+0.5d0*dzi
3678           xmedi=mod(xmedi,boxxsize)
3679           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3680           ymedi=mod(ymedi,boxysize)
3681           if (ymedi.lt.0) ymedi=ymedi+boxysize
3682           zmedi=mod(zmedi,boxzsize)
3683           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3684 C          xmedi=xmedi+xshift*boxxsize
3685 C          ymedi=ymedi+yshift*boxysize
3686 C          zmedi=zmedi+zshift*boxzsize
3687
3688 C Return tom into box, boxxsize is size of box in x dimension
3689 c  164   continue
3690 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3691 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3692 C Condition for being inside the proper box
3693 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3694 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3695 c        go to 164
3696 c        endif
3697 c  165   continue
3698 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3699 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3700 C Condition for being inside the proper box
3701 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3702 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3703 c        go to 165
3704 c        endif
3705 c  166   continue
3706 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3707 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3708 cC Condition for being inside the proper box
3709 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3710 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3711 c        go to 166
3712 c        endif
3713
3714 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3715         num_conti=num_cont_hb(i)
3716 C I TU KURWA
3717         do j=ielstart(i),ielend(i)
3718 C          do j=16,17
3719 C          write (iout,*) i,j
3720 C         if (j.le.1) cycle
3721           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3722 C changes suggested by Ana to avoid out of bounds
3723 c     & .or.((j+2).gt.nres)
3724 c     & .or.((j-1).le.0)
3725 C end of changes by Ana
3726 c     & .or.itype(j+2).eq.ntyp1
3727 c     & .or.itype(j-1).eq.ntyp1
3728      &) cycle
3729           call eelecij(i,j,ees,evdw1,eel_loc)
3730         enddo ! j
3731         num_cont_hb(i)=num_conti
3732       enddo   ! i
3733 C     enddo   ! zshift
3734 C      enddo   ! yshift
3735 C      enddo   ! xshift
3736
3737 c      write (iout,*) "Number of loop steps in EELEC:",ind
3738 cd      do i=1,nres
3739 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3740 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3741 cd      enddo
3742 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3743 ccc      eel_loc=eel_loc+eello_turn3
3744 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3745       return
3746       end
3747 C-------------------------------------------------------------------------------
3748       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3749       implicit real*8 (a-h,o-z)
3750       include 'DIMENSIONS'
3751 #ifdef MPI
3752       include "mpif.h"
3753 #endif
3754       include 'COMMON.CONTROL'
3755       include 'COMMON.IOUNITS'
3756       include 'COMMON.GEO'
3757       include 'COMMON.VAR'
3758       include 'COMMON.LOCAL'
3759       include 'COMMON.CHAIN'
3760       include 'COMMON.DERIV'
3761       include 'COMMON.INTERACT'
3762       include 'COMMON.CONTACTS'
3763       include 'COMMON.TORSION'
3764       include 'COMMON.VECTORS'
3765       include 'COMMON.FFIELD'
3766       include 'COMMON.TIME1'
3767       include 'COMMON.SPLITELE'
3768       include 'COMMON.SHIELD'
3769       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3770      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3771       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3772      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3773      &    gmuij2(4),gmuji2(4)
3774       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3775      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3776      &    num_conti,j1,j2
3777 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3778 #ifdef MOMENT
3779       double precision scal_el /1.0d0/
3780 #else
3781       double precision scal_el /0.5d0/
3782 #endif
3783 C 12/13/98
3784 C 13-go grudnia roku pamietnego...
3785       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3786      &                   0.0d0,1.0d0,0.0d0,
3787      &                   0.0d0,0.0d0,1.0d0/
3788        integer xshift,yshift,zshift
3789 c          time00=MPI_Wtime()
3790 cd      write (iout,*) "eelecij",i,j
3791 c          ind=ind+1
3792           iteli=itel(i)
3793           itelj=itel(j)
3794           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3795           aaa=app(iteli,itelj)
3796           bbb=bpp(iteli,itelj)
3797           ael6i=ael6(iteli,itelj)
3798           ael3i=ael3(iteli,itelj)
3799           dxj=dc(1,j)
3800           dyj=dc(2,j)
3801           dzj=dc(3,j)
3802           dx_normj=dc_norm(1,j)
3803           dy_normj=dc_norm(2,j)
3804           dz_normj=dc_norm(3,j)
3805 C          xj=c(1,j)+0.5D0*dxj-xmedi
3806 C          yj=c(2,j)+0.5D0*dyj-ymedi
3807 C          zj=c(3,j)+0.5D0*dzj-zmedi
3808           xj=c(1,j)+0.5D0*dxj
3809           yj=c(2,j)+0.5D0*dyj
3810           zj=c(3,j)+0.5D0*dzj
3811           xj=mod(xj,boxxsize)
3812           if (xj.lt.0) xj=xj+boxxsize
3813           yj=mod(yj,boxysize)
3814           if (yj.lt.0) yj=yj+boxysize
3815           zj=mod(zj,boxzsize)
3816           if (zj.lt.0) zj=zj+boxzsize
3817           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3818       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3819       xj_safe=xj
3820       yj_safe=yj
3821       zj_safe=zj
3822       isubchap=0
3823       do xshift=-1,1
3824       do yshift=-1,1
3825       do zshift=-1,1
3826           xj=xj_safe+xshift*boxxsize
3827           yj=yj_safe+yshift*boxysize
3828           zj=zj_safe+zshift*boxzsize
3829           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3830           if(dist_temp.lt.dist_init) then
3831             dist_init=dist_temp
3832             xj_temp=xj
3833             yj_temp=yj
3834             zj_temp=zj
3835             isubchap=1
3836           endif
3837        enddo
3838        enddo
3839        enddo
3840        if (isubchap.eq.1) then
3841           xj=xj_temp-xmedi
3842           yj=yj_temp-ymedi
3843           zj=zj_temp-zmedi
3844        else
3845           xj=xj_safe-xmedi
3846           yj=yj_safe-ymedi
3847           zj=zj_safe-zmedi
3848        endif
3849 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3850 c  174   continue
3851 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3852 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3853 C Condition for being inside the proper box
3854 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3855 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3856 c        go to 174
3857 c        endif
3858 c  175   continue
3859 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3860 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3861 C Condition for being inside the proper box
3862 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3863 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3864 c        go to 175
3865 c        endif
3866 c  176   continue
3867 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3868 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3869 C Condition for being inside the proper box
3870 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3871 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3872 c        go to 176
3873 c        endif
3874 C        endif !endPBC condintion
3875 C        xj=xj-xmedi
3876 C        yj=yj-ymedi
3877 C        zj=zj-zmedi
3878           rij=xj*xj+yj*yj+zj*zj
3879
3880             sss=sscale(sqrt(rij))
3881             sssgrad=sscagrad(sqrt(rij))
3882 c            if (sss.gt.0.0d0) then
3883           rrmij=1.0D0/rij
3884           rij=dsqrt(rij)
3885           rmij=1.0D0/rij
3886           r3ij=rrmij*rmij
3887           r6ij=r3ij*r3ij
3888           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3889           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3890           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3891           fac=cosa-3.0D0*cosb*cosg
3892           ev1=aaa*r6ij*r6ij
3893 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3894           if (j.eq.i+2) ev1=scal_el*ev1
3895           ev2=bbb*r6ij
3896           fac3=ael6i*r6ij
3897           fac4=ael3i*r3ij
3898           evdwij=(ev1+ev2)
3899           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3900           el2=fac4*fac
3901 C MARYSIA
3902 C          eesij=(el1+el2)
3903 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3904           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3905           if (shield_mode.gt.0) then
3906 C          fac_shield(i)=0.4
3907 C          fac_shield(j)=0.6
3908           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3909           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3910           eesij=(el1+el2)
3911           ees=ees+eesij
3912           else
3913           fac_shield(i)=1.0
3914           fac_shield(j)=1.0
3915           eesij=(el1+el2)
3916           ees=ees+eesij
3917           endif
3918           evdw1=evdw1+evdwij*sss
3919 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3920 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3921 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3922 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3923
3924           if (energy_dec) then
3925               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3926      &'evdw1',i,j,evdwij
3927      &,iteli,itelj,aaa,evdw1,sss
3928               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3929      &fac_shield(i),fac_shield(j)
3930           endif
3931
3932 C
3933 C Calculate contributions to the Cartesian gradient.
3934 C
3935 #ifdef SPLITELE
3936           facvdw=-6*rrmij*(ev1+evdwij)*sss
3937           facel=-3*rrmij*(el1+eesij)
3938           fac1=fac
3939           erij(1)=xj*rmij
3940           erij(2)=yj*rmij
3941           erij(3)=zj*rmij
3942
3943 *
3944 * Radial derivatives. First process both termini of the fragment (i,j)
3945 *
3946           ggg(1)=facel*xj
3947           ggg(2)=facel*yj
3948           ggg(3)=facel*zj
3949           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3950      &  (shield_mode.gt.0)) then
3951 C          print *,i,j
3952           do ilist=1,ishield_list(i)
3953            iresshield=shield_list(ilist,i)
3954            do k=1,3
3955            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3956      &      *2.0
3957            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3958      &              rlocshield
3959      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3960             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3961 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3962 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3963 C             if (iresshield.gt.i) then
3964 C               do ishi=i+1,iresshield-1
3965 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3966 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3967 C
3968 C              enddo
3969 C             else
3970 C               do ishi=iresshield,i
3971 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3972 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3973 C
3974 C               enddo
3975 C              endif
3976            enddo
3977           enddo
3978           do ilist=1,ishield_list(j)
3979            iresshield=shield_list(ilist,j)
3980            do k=1,3
3981            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3982      &     *2.0
3983            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3984      &              rlocshield
3985      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3986            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3987
3988 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3989 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3990 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3991 C             if (iresshield.gt.j) then
3992 C               do ishi=j+1,iresshield-1
3993 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3994 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3995 C
3996 C               enddo
3997 C            else
3998 C               do ishi=iresshield,j
3999 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4000 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4001 C               enddo
4002 C              endif
4003            enddo
4004           enddo
4005
4006           do k=1,3
4007             gshieldc(k,i)=gshieldc(k,i)+
4008      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4009             gshieldc(k,j)=gshieldc(k,j)+
4010      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4011             gshieldc(k,i-1)=gshieldc(k,i-1)+
4012      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4013             gshieldc(k,j-1)=gshieldc(k,j-1)+
4014      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4015
4016            enddo
4017            endif
4018 c          do k=1,3
4019 c            ghalf=0.5D0*ggg(k)
4020 c            gelc(k,i)=gelc(k,i)+ghalf
4021 c            gelc(k,j)=gelc(k,j)+ghalf
4022 c          enddo
4023 c 9/28/08 AL Gradient compotents will be summed only at the end
4024 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4025           do k=1,3
4026             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4027 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4028             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4029 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4030 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4031 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4032 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4033 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4034           enddo
4035 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4036
4037 *
4038 * Loop over residues i+1 thru j-1.
4039 *
4040 cgrad          do k=i+1,j-1
4041 cgrad            do l=1,3
4042 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4043 cgrad            enddo
4044 cgrad          enddo
4045           if (sss.gt.0.0) then
4046           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4047           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4048           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4049           else
4050           ggg(1)=0.0
4051           ggg(2)=0.0
4052           ggg(3)=0.0
4053           endif
4054 c          do k=1,3
4055 c            ghalf=0.5D0*ggg(k)
4056 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4057 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4058 c          enddo
4059 c 9/28/08 AL Gradient compotents will be summed only at the end
4060           do k=1,3
4061             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4062             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4063           enddo
4064 *
4065 * Loop over residues i+1 thru j-1.
4066 *
4067 cgrad          do k=i+1,j-1
4068 cgrad            do l=1,3
4069 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4070 cgrad            enddo
4071 cgrad          enddo
4072 #else
4073 C MARYSIA
4074           facvdw=(ev1+evdwij)*sss
4075           facel=(el1+eesij)
4076           fac1=fac
4077           fac=-3*rrmij*(facvdw+facvdw+facel)
4078           erij(1)=xj*rmij
4079           erij(2)=yj*rmij
4080           erij(3)=zj*rmij
4081 *
4082 * Radial derivatives. First process both termini of the fragment (i,j)
4083 *
4084           ggg(1)=fac*xj
4085 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4086           ggg(2)=fac*yj
4087 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4088           ggg(3)=fac*zj
4089 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4090 c          do k=1,3
4091 c            ghalf=0.5D0*ggg(k)
4092 c            gelc(k,i)=gelc(k,i)+ghalf
4093 c            gelc(k,j)=gelc(k,j)+ghalf
4094 c          enddo
4095 c 9/28/08 AL Gradient compotents will be summed only at the end
4096           do k=1,3
4097             gelc_long(k,j)=gelc(k,j)+ggg(k)
4098             gelc_long(k,i)=gelc(k,i)-ggg(k)
4099           enddo
4100 *
4101 * Loop over residues i+1 thru j-1.
4102 *
4103 cgrad          do k=i+1,j-1
4104 cgrad            do l=1,3
4105 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4106 cgrad            enddo
4107 cgrad          enddo
4108 c 9/28/08 AL Gradient compotents will be summed only at the end
4109           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4110           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4111           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4112           do k=1,3
4113             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4114             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4115           enddo
4116 #endif
4117 *
4118 * Angular part
4119 *
4120           ecosa=2.0D0*fac3*fac1+fac4
4121           fac4=-3.0D0*fac4
4122           fac3=-6.0D0*fac3
4123           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4124           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4125           do k=1,3
4126             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4127             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4128           enddo
4129 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4130 cd   &          (dcosg(k),k=1,3)
4131           do k=1,3
4132             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4133      &      fac_shield(i)**2*fac_shield(j)**2
4134           enddo
4135 c          do k=1,3
4136 c            ghalf=0.5D0*ggg(k)
4137 c            gelc(k,i)=gelc(k,i)+ghalf
4138 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4139 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4140 c            gelc(k,j)=gelc(k,j)+ghalf
4141 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4142 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4143 c          enddo
4144 cgrad          do k=i+1,j-1
4145 cgrad            do l=1,3
4146 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4147 cgrad            enddo
4148 cgrad          enddo
4149 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4150           do k=1,3
4151             gelc(k,i)=gelc(k,i)
4152      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4153      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4154      &           *fac_shield(i)**2*fac_shield(j)**2
4155             gelc(k,j)=gelc(k,j)
4156      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4157      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4158      &           *fac_shield(i)**2*fac_shield(j)**2
4159             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4160             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4161           enddo
4162 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4163
4164 C MARYSIA
4165 c          endif !sscale
4166           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4167      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4168      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4169 C
4170 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4171 C   energy of a peptide unit is assumed in the form of a second-order
4172 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4173 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4174 C   are computed for EVERY pair of non-contiguous peptide groups.
4175 C
4176
4177           if (j.lt.nres-1) then
4178             j1=j+1
4179             j2=j-1
4180           else
4181             j1=j-1
4182             j2=j-2
4183           endif
4184           kkk=0
4185           lll=0
4186           do k=1,2
4187             do l=1,2
4188               kkk=kkk+1
4189               muij(kkk)=mu(k,i)*mu(l,j)
4190 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4191 #ifdef NEWCORR
4192              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4193 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4194              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4195              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4196 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4197              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4198 #endif
4199             enddo
4200           enddo
4201 #ifdef DEBUG
4202           write (iout,*) 'EELEC: i',i,' j',j
4203           write (iout,*) 'j',j,' j1',j1,' j2',j2
4204           write(iout,*) 'muij',muij
4205 #endif
4206           ury=scalar(uy(1,i),erij)
4207           urz=scalar(uz(1,i),erij)
4208           vry=scalar(uy(1,j),erij)
4209           vrz=scalar(uz(1,j),erij)
4210           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4211           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4212           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4213           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4214           fac=dsqrt(-ael6i)*r3ij
4215 #ifdef DEBUG
4216           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4217           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4218      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4219      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4220      &      "uzvz",scalar(uz(1,i),uz(1,j))
4221           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4222           write (iout,*) "fac",fac
4223 #endif
4224           a22=a22*fac
4225           a23=a23*fac
4226           a32=a32*fac
4227           a33=a33*fac
4228 #ifdef DEBUG
4229           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4230 #endif
4231 #undef DEBUG
4232 cd          write (iout,'(4i5,4f10.5)')
4233 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4234 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4235 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4236 cd     &      uy(:,j),uz(:,j)
4237 cd          write (iout,'(4f10.5)')
4238 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4239 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4240 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4241 cd           write (iout,'(9f10.5/)')
4242 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4243 C Derivatives of the elements of A in virtual-bond vectors
4244           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4245           do k=1,3
4246             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4247             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4248             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4249             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4250             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4251             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4252             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4253             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4254             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4255             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4256             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4257             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4258           enddo
4259 C Compute radial contributions to the gradient
4260           facr=-3.0d0*rrmij
4261           a22der=a22*facr
4262           a23der=a23*facr
4263           a32der=a32*facr
4264           a33der=a33*facr
4265           agg(1,1)=a22der*xj
4266           agg(2,1)=a22der*yj
4267           agg(3,1)=a22der*zj
4268           agg(1,2)=a23der*xj
4269           agg(2,2)=a23der*yj
4270           agg(3,2)=a23der*zj
4271           agg(1,3)=a32der*xj
4272           agg(2,3)=a32der*yj
4273           agg(3,3)=a32der*zj
4274           agg(1,4)=a33der*xj
4275           agg(2,4)=a33der*yj
4276           agg(3,4)=a33der*zj
4277 C Add the contributions coming from er
4278           fac3=-3.0d0*fac
4279           do k=1,3
4280             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4281             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4282             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4283             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4284           enddo
4285           do k=1,3
4286 C Derivatives in DC(i)
4287 cgrad            ghalf1=0.5d0*agg(k,1)
4288 cgrad            ghalf2=0.5d0*agg(k,2)
4289 cgrad            ghalf3=0.5d0*agg(k,3)
4290 cgrad            ghalf4=0.5d0*agg(k,4)
4291             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4292      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4293             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4294      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4295             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4296      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4297             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4298      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4299 C Derivatives in DC(i+1)
4300             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4301      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4302             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4303      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4304             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4305      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4306             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4307      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4308 C Derivatives in DC(j)
4309             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4310      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4311             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4312      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4313             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4314      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4315             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4316      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4317 C Derivatives in DC(j+1) or DC(nres-1)
4318             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4319      &      -3.0d0*vryg(k,3)*ury)
4320             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4321      &      -3.0d0*vrzg(k,3)*ury)
4322             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4323      &      -3.0d0*vryg(k,3)*urz)
4324             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4325      &      -3.0d0*vrzg(k,3)*urz)
4326 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4327 cgrad              do l=1,4
4328 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4329 cgrad              enddo
4330 cgrad            endif
4331           enddo
4332           acipa(1,1)=a22
4333           acipa(1,2)=a23
4334           acipa(2,1)=a32
4335           acipa(2,2)=a33
4336           a22=-a22
4337           a23=-a23
4338           do l=1,2
4339             do k=1,3
4340               agg(k,l)=-agg(k,l)
4341               aggi(k,l)=-aggi(k,l)
4342               aggi1(k,l)=-aggi1(k,l)
4343               aggj(k,l)=-aggj(k,l)
4344               aggj1(k,l)=-aggj1(k,l)
4345             enddo
4346           enddo
4347           if (j.lt.nres-1) then
4348             a22=-a22
4349             a32=-a32
4350             do l=1,3,2
4351               do k=1,3
4352                 agg(k,l)=-agg(k,l)
4353                 aggi(k,l)=-aggi(k,l)
4354                 aggi1(k,l)=-aggi1(k,l)
4355                 aggj(k,l)=-aggj(k,l)
4356                 aggj1(k,l)=-aggj1(k,l)
4357               enddo
4358             enddo
4359           else
4360             a22=-a22
4361             a23=-a23
4362             a32=-a32
4363             a33=-a33
4364             do l=1,4
4365               do k=1,3
4366                 agg(k,l)=-agg(k,l)
4367                 aggi(k,l)=-aggi(k,l)
4368                 aggi1(k,l)=-aggi1(k,l)
4369                 aggj(k,l)=-aggj(k,l)
4370                 aggj1(k,l)=-aggj1(k,l)
4371               enddo
4372             enddo
4373           endif
4374           ENDIF ! WCORR
4375           IF (wel_loc.gt.0.0d0) THEN
4376 C Contribution to the local-electrostatic energy coming from the i-j pair
4377           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4378      &     +a33*muij(4)
4379 #ifdef DEBUG
4380           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4381      &     " a33",a33
4382           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4383      &     " wel_loc",wel_loc
4384 #endif
4385           if (shield_mode.eq.0) then
4386            fac_shield(i)=1.0
4387            fac_shield(j)=1.0
4388 C          else
4389 C           fac_shield(i)=0.4
4390 C           fac_shield(j)=0.6
4391           endif
4392           eel_loc_ij=eel_loc_ij
4393      &    *fac_shield(i)*fac_shield(j)
4394 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4395 c     &            'eelloc',i,j,eel_loc_ij
4396 C Now derivative over eel_loc
4397           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4398      &  (shield_mode.gt.0)) then
4399 C          print *,i,j
4400
4401           do ilist=1,ishield_list(i)
4402            iresshield=shield_list(ilist,i)
4403            do k=1,3
4404            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4405      &                                          /fac_shield(i)
4406 C     &      *2.0
4407            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4408      &              rlocshield
4409      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4410             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4411      &      +rlocshield
4412            enddo
4413           enddo
4414           do ilist=1,ishield_list(j)
4415            iresshield=shield_list(ilist,j)
4416            do k=1,3
4417            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4418      &                                       /fac_shield(j)
4419 C     &     *2.0
4420            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4421      &              rlocshield
4422      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4423            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4424      &             +rlocshield
4425
4426            enddo
4427           enddo
4428
4429           do k=1,3
4430             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4431      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4432             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4433      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4434             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4435      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4436             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4437      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4438            enddo
4439            endif
4440
4441
4442 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4443 c     &                     ' eel_loc_ij',eel_loc_ij
4444 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4445 C Calculate patrial derivative for theta angle
4446 #ifdef NEWCORR
4447          geel_loc_ij=(a22*gmuij1(1)
4448      &     +a23*gmuij1(2)
4449      &     +a32*gmuij1(3)
4450      &     +a33*gmuij1(4))
4451      &    *fac_shield(i)*fac_shield(j)
4452 c         write(iout,*) "derivative over thatai"
4453 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4454 c     &   a33*gmuij1(4)
4455          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4456      &      geel_loc_ij*wel_loc
4457 c         write(iout,*) "derivative over thatai-1"
4458 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4459 c     &   a33*gmuij2(4)
4460          geel_loc_ij=
4461      &     a22*gmuij2(1)
4462      &     +a23*gmuij2(2)
4463      &     +a32*gmuij2(3)
4464      &     +a33*gmuij2(4)
4465          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4466      &      geel_loc_ij*wel_loc
4467      &    *fac_shield(i)*fac_shield(j)
4468
4469 c  Derivative over j residue
4470          geel_loc_ji=a22*gmuji1(1)
4471      &     +a23*gmuji1(2)
4472      &     +a32*gmuji1(3)
4473      &     +a33*gmuji1(4)
4474 c         write(iout,*) "derivative over thataj"
4475 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4476 c     &   a33*gmuji1(4)
4477
4478         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4479      &      geel_loc_ji*wel_loc
4480      &    *fac_shield(i)*fac_shield(j)
4481
4482          geel_loc_ji=
4483      &     +a22*gmuji2(1)
4484      &     +a23*gmuji2(2)
4485      &     +a32*gmuji2(3)
4486      &     +a33*gmuji2(4)
4487 c         write(iout,*) "derivative over thataj-1"
4488 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4489 c     &   a33*gmuji2(4)
4490          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4491      &      geel_loc_ji*wel_loc
4492      &    *fac_shield(i)*fac_shield(j)
4493 #endif
4494 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4495
4496           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4497      &            'eelloc',i,j,eel_loc_ij
4498 c           if (eel_loc_ij.ne.0)
4499 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4500 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4501
4502           eel_loc=eel_loc+eel_loc_ij
4503 C Partial derivatives in virtual-bond dihedral angles gamma
4504           if (i.gt.1)
4505      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4506      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4507      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4508      &    *fac_shield(i)*fac_shield(j)
4509
4510           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4511      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4512      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4513      &    *fac_shield(i)*fac_shield(j)
4514 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4515           do l=1,3
4516             ggg(l)=(agg(l,1)*muij(1)+
4517      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4518      &    *fac_shield(i)*fac_shield(j)
4519             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4520             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4521 cgrad            ghalf=0.5d0*ggg(l)
4522 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4523 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4524           enddo
4525 cgrad          do k=i+1,j2
4526 cgrad            do l=1,3
4527 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4528 cgrad            enddo
4529 cgrad          enddo
4530 C Remaining derivatives of eello
4531           do l=1,3
4532             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4533      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4534      &    *fac_shield(i)*fac_shield(j)
4535
4536             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4537      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4538      &    *fac_shield(i)*fac_shield(j)
4539
4540             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4541      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4542      &    *fac_shield(i)*fac_shield(j)
4543
4544             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4545      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4546      &    *fac_shield(i)*fac_shield(j)
4547
4548           enddo
4549           ENDIF
4550 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4551 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4552           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4553      &       .and. num_conti.le.maxconts) then
4554 c            write (iout,*) i,j," entered corr"
4555 C
4556 C Calculate the contact function. The ith column of the array JCONT will
4557 C contain the numbers of atoms that make contacts with the atom I (of numbers
4558 C greater than I). The arrays FACONT and GACONT will contain the values of
4559 C the contact function and its derivative.
4560 c           r0ij=1.02D0*rpp(iteli,itelj)
4561 c           r0ij=1.11D0*rpp(iteli,itelj)
4562             r0ij=2.20D0*rpp(iteli,itelj)
4563 c           r0ij=1.55D0*rpp(iteli,itelj)
4564             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4565             if (fcont.gt.0.0D0) then
4566               num_conti=num_conti+1
4567               if (num_conti.gt.maxconts) then
4568                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4569      &                         ' will skip next contacts for this conf.'
4570               else
4571                 jcont_hb(num_conti,i)=j
4572 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4573 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4574                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4575      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4576 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4577 C  terms.
4578                 d_cont(num_conti,i)=rij
4579 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4580 C     --- Electrostatic-interaction matrix ---
4581                 a_chuj(1,1,num_conti,i)=a22
4582                 a_chuj(1,2,num_conti,i)=a23
4583                 a_chuj(2,1,num_conti,i)=a32
4584                 a_chuj(2,2,num_conti,i)=a33
4585 C     --- Gradient of rij
4586                 do kkk=1,3
4587                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4588                 enddo
4589                 kkll=0
4590                 do k=1,2
4591                   do l=1,2
4592                     kkll=kkll+1
4593                     do m=1,3
4594                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4595                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4596                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4597                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4598                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4599                     enddo
4600                   enddo
4601                 enddo
4602                 ENDIF
4603                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4604 C Calculate contact energies
4605                 cosa4=4.0D0*cosa
4606                 wij=cosa-3.0D0*cosb*cosg
4607                 cosbg1=cosb+cosg
4608                 cosbg2=cosb-cosg
4609 c               fac3=dsqrt(-ael6i)/r0ij**3
4610                 fac3=dsqrt(-ael6i)*r3ij
4611 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4612                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4613                 if (ees0tmp.gt.0) then
4614                   ees0pij=dsqrt(ees0tmp)
4615                 else
4616                   ees0pij=0
4617                 endif
4618 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4619                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4620                 if (ees0tmp.gt.0) then
4621                   ees0mij=dsqrt(ees0tmp)
4622                 else
4623                   ees0mij=0
4624                 endif
4625 c               ees0mij=0.0D0
4626                 if (shield_mode.eq.0) then
4627                 fac_shield(i)=1.0d0
4628                 fac_shield(j)=1.0d0
4629                 else
4630                 ees0plist(num_conti,i)=j
4631 C                fac_shield(i)=0.4d0
4632 C                fac_shield(j)=0.6d0
4633                 endif
4634                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4635      &          *fac_shield(i)*fac_shield(j)
4636                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4637      &          *fac_shield(i)*fac_shield(j)
4638 C Diagnostics. Comment out or remove after debugging!
4639 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4640 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4641 c               ees0m(num_conti,i)=0.0D0
4642 C End diagnostics.
4643 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4644 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4645 C Angular derivatives of the contact function
4646                 ees0pij1=fac3/ees0pij
4647                 ees0mij1=fac3/ees0mij
4648                 fac3p=-3.0D0*fac3*rrmij
4649                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4650                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4651 c               ees0mij1=0.0D0
4652                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4653                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4654                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4655                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4656                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4657                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4658                 ecosap=ecosa1+ecosa2
4659                 ecosbp=ecosb1+ecosb2
4660                 ecosgp=ecosg1+ecosg2
4661                 ecosam=ecosa1-ecosa2
4662                 ecosbm=ecosb1-ecosb2
4663                 ecosgm=ecosg1-ecosg2
4664 C Diagnostics
4665 c               ecosap=ecosa1
4666 c               ecosbp=ecosb1
4667 c               ecosgp=ecosg1
4668 c               ecosam=0.0D0
4669 c               ecosbm=0.0D0
4670 c               ecosgm=0.0D0
4671 C End diagnostics
4672                 facont_hb(num_conti,i)=fcont
4673                 fprimcont=fprimcont/rij
4674 cd              facont_hb(num_conti,i)=1.0D0
4675 C Following line is for diagnostics.
4676 cd              fprimcont=0.0D0
4677                 do k=1,3
4678                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4679                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4680                 enddo
4681                 do k=1,3
4682                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4683                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4684                 enddo
4685                 gggp(1)=gggp(1)+ees0pijp*xj
4686                 gggp(2)=gggp(2)+ees0pijp*yj
4687                 gggp(3)=gggp(3)+ees0pijp*zj
4688                 gggm(1)=gggm(1)+ees0mijp*xj
4689                 gggm(2)=gggm(2)+ees0mijp*yj
4690                 gggm(3)=gggm(3)+ees0mijp*zj
4691 C Derivatives due to the contact function
4692                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4693                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4694                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4695                 do k=1,3
4696 c
4697 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4698 c          following the change of gradient-summation algorithm.
4699 c
4700 cgrad                  ghalfp=0.5D0*gggp(k)
4701 cgrad                  ghalfm=0.5D0*gggm(k)
4702                   gacontp_hb1(k,num_conti,i)=!ghalfp
4703      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4704      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4705      &          *fac_shield(i)*fac_shield(j)
4706
4707                   gacontp_hb2(k,num_conti,i)=!ghalfp
4708      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4709      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4710      &          *fac_shield(i)*fac_shield(j)
4711
4712                   gacontp_hb3(k,num_conti,i)=gggp(k)
4713      &          *fac_shield(i)*fac_shield(j)
4714
4715                   gacontm_hb1(k,num_conti,i)=!ghalfm
4716      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4717      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4718      &          *fac_shield(i)*fac_shield(j)
4719
4720                   gacontm_hb2(k,num_conti,i)=!ghalfm
4721      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4722      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4723      &          *fac_shield(i)*fac_shield(j)
4724
4725                   gacontm_hb3(k,num_conti,i)=gggm(k)
4726      &          *fac_shield(i)*fac_shield(j)
4727
4728                 enddo
4729 C Diagnostics. Comment out or remove after debugging!
4730 cdiag           do k=1,3
4731 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4732 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4733 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4734 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4735 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4736 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4737 cdiag           enddo
4738               ENDIF ! wcorr
4739               endif  ! num_conti.le.maxconts
4740             endif  ! fcont.gt.0
4741           endif    ! j.gt.i+1
4742           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4743             do k=1,4
4744               do l=1,3
4745                 ghalf=0.5d0*agg(l,k)
4746                 aggi(l,k)=aggi(l,k)+ghalf
4747                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4748                 aggj(l,k)=aggj(l,k)+ghalf
4749               enddo
4750             enddo
4751             if (j.eq.nres-1 .and. i.lt.j-2) then
4752               do k=1,4
4753                 do l=1,3
4754                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4755                 enddo
4756               enddo
4757             endif
4758           endif
4759 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4760       return
4761       end
4762 C-----------------------------------------------------------------------------
4763       subroutine eturn3(i,eello_turn3)
4764 C Third- and fourth-order contributions from turns
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.IOUNITS'
4768       include 'COMMON.GEO'
4769       include 'COMMON.VAR'
4770       include 'COMMON.LOCAL'
4771       include 'COMMON.CHAIN'
4772       include 'COMMON.DERIV'
4773       include 'COMMON.INTERACT'
4774       include 'COMMON.CONTACTS'
4775       include 'COMMON.TORSION'
4776       include 'COMMON.VECTORS'
4777       include 'COMMON.FFIELD'
4778       include 'COMMON.CONTROL'
4779       include 'COMMON.SHIELD'
4780       dimension ggg(3)
4781       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4782      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4783      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4784      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4785      &  auxgmat2(2,2),auxgmatt2(2,2)
4786       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4787      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4788       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4789      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4790      &    num_conti,j1,j2
4791       j=i+2
4792 c      write (iout,*) "eturn3",i,j,j1,j2
4793       a_temp(1,1)=a22
4794       a_temp(1,2)=a23
4795       a_temp(2,1)=a32
4796       a_temp(2,2)=a33
4797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4798 C
4799 C               Third-order contributions
4800 C
4801 C                 (i+2)o----(i+3)
4802 C                      | |
4803 C                      | |
4804 C                 (i+1)o----i
4805 C
4806 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4807 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4808         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4809 c auxalary matices for theta gradient
4810 c auxalary matrix for i+1 and constant i+2
4811         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4812 c auxalary matrix for i+2 and constant i+1
4813         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4814         call transpose2(auxmat(1,1),auxmat1(1,1))
4815         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4816         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4817         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4818         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4819         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4820         if (shield_mode.eq.0) then
4821         fac_shield(i)=1.0
4822         fac_shield(j)=1.0
4823 C        else
4824 C        fac_shield(i)=0.4
4825 C        fac_shield(j)=0.6
4826         endif
4827         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4828      &  *fac_shield(i)*fac_shield(j)
4829         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4830      &  *fac_shield(i)*fac_shield(j)
4831         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4832      &    eello_t3
4833 C#ifdef NEWCORR
4834 C Derivatives in theta
4835         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4836      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4837      &   *fac_shield(i)*fac_shield(j)
4838         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4839      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4840      &   *fac_shield(i)*fac_shield(j)
4841 C#endif
4842
4843 C Derivatives in shield mode
4844           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4845      &  (shield_mode.gt.0)) then
4846 C          print *,i,j
4847
4848           do ilist=1,ishield_list(i)
4849            iresshield=shield_list(ilist,i)
4850            do k=1,3
4851            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4852 C     &      *2.0
4853            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4854      &              rlocshield
4855      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4856             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4857      &      +rlocshield
4858            enddo
4859           enddo
4860           do ilist=1,ishield_list(j)
4861            iresshield=shield_list(ilist,j)
4862            do k=1,3
4863            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4864 C     &     *2.0
4865            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4866      &              rlocshield
4867      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4868            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4869      &             +rlocshield
4870
4871            enddo
4872           enddo
4873
4874           do k=1,3
4875             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4876      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4877             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4878      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4879             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4880      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4881             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4882      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4883            enddo
4884            endif
4885
4886 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4887 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4888 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4889 cd     &    ' eello_turn3_num',4*eello_turn3_num
4890 C Derivatives in gamma(i)
4891         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4892         call transpose2(auxmat2(1,1),auxmat3(1,1))
4893         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4894         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4895      &   *fac_shield(i)*fac_shield(j)
4896 C Derivatives in gamma(i+1)
4897         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4898         call transpose2(auxmat2(1,1),auxmat3(1,1))
4899         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4900         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4901      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4902      &   *fac_shield(i)*fac_shield(j)
4903 C Cartesian derivatives
4904         do l=1,3
4905 c            ghalf1=0.5d0*agg(l,1)
4906 c            ghalf2=0.5d0*agg(l,2)
4907 c            ghalf3=0.5d0*agg(l,3)
4908 c            ghalf4=0.5d0*agg(l,4)
4909           a_temp(1,1)=aggi(l,1)!+ghalf1
4910           a_temp(1,2)=aggi(l,2)!+ghalf2
4911           a_temp(2,1)=aggi(l,3)!+ghalf3
4912           a_temp(2,2)=aggi(l,4)!+ghalf4
4913           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4914           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4915      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4916      &   *fac_shield(i)*fac_shield(j)
4917
4918           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4919           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4920           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4921           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4922           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4923           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4924      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4925      &   *fac_shield(i)*fac_shield(j)
4926           a_temp(1,1)=aggj(l,1)!+ghalf1
4927           a_temp(1,2)=aggj(l,2)!+ghalf2
4928           a_temp(2,1)=aggj(l,3)!+ghalf3
4929           a_temp(2,2)=aggj(l,4)!+ghalf4
4930           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4931           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4932      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4933      &   *fac_shield(i)*fac_shield(j)
4934           a_temp(1,1)=aggj1(l,1)
4935           a_temp(1,2)=aggj1(l,2)
4936           a_temp(2,1)=aggj1(l,3)
4937           a_temp(2,2)=aggj1(l,4)
4938           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4939           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4940      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4941      &   *fac_shield(i)*fac_shield(j)
4942         enddo
4943       return
4944       end
4945 C-------------------------------------------------------------------------------
4946       subroutine eturn4(i,eello_turn4)
4947 C Third- and fourth-order contributions from turns
4948       implicit real*8 (a-h,o-z)
4949       include 'DIMENSIONS'
4950       include 'COMMON.IOUNITS'
4951       include 'COMMON.GEO'
4952       include 'COMMON.VAR'
4953       include 'COMMON.LOCAL'
4954       include 'COMMON.CHAIN'
4955       include 'COMMON.DERIV'
4956       include 'COMMON.INTERACT'
4957       include 'COMMON.CONTACTS'
4958       include 'COMMON.TORSION'
4959       include 'COMMON.VECTORS'
4960       include 'COMMON.FFIELD'
4961       include 'COMMON.CONTROL'
4962       include 'COMMON.SHIELD'
4963       dimension ggg(3)
4964       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4965      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4966      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4967      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4968      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4969      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4970      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4971       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4972      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4973       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4974      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4975      &    num_conti,j1,j2
4976       j=i+3
4977 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4978 C
4979 C               Fourth-order contributions
4980 C
4981 C                 (i+3)o----(i+4)
4982 C                     /  |
4983 C               (i+2)o   |
4984 C                     \  |
4985 C                 (i+1)o----i
4986 C
4987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4988 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4989 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4990 c        write(iout,*)"WCHODZE W PROGRAM"
4991         a_temp(1,1)=a22
4992         a_temp(1,2)=a23
4993         a_temp(2,1)=a32
4994         a_temp(2,2)=a33
4995         iti1=itype2loc(itype(i+1))
4996         iti2=itype2loc(itype(i+2))
4997         iti3=itype2loc(itype(i+3))
4998 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4999         call transpose2(EUg(1,1,i+1),e1t(1,1))
5000         call transpose2(Eug(1,1,i+2),e2t(1,1))
5001         call transpose2(Eug(1,1,i+3),e3t(1,1))
5002 C Ematrix derivative in theta
5003         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5004         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5005         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5006         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5007 c       eta1 in derivative theta
5008         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5009         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5010 c       auxgvec is derivative of Ub2 so i+3 theta
5011         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5012 c       auxalary matrix of E i+1
5013         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5014 c        s1=0.0
5015 c        gs1=0.0
5016         s1=scalar2(b1(1,i+2),auxvec(1))
5017 c derivative of theta i+2 with constant i+3
5018         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5019 c derivative of theta i+2 with constant i+2
5020         gs32=scalar2(b1(1,i+2),auxgvec(1))
5021 c derivative of E matix in theta of i+1
5022         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5023
5024         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5025 c       ea31 in derivative theta
5026         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5027         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5028 c auxilary matrix auxgvec of Ub2 with constant E matirx
5029         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5030 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5031         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5032
5033 c        s2=0.0
5034 c        gs2=0.0
5035         s2=scalar2(b1(1,i+1),auxvec(1))
5036 c derivative of theta i+1 with constant i+3
5037         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5038 c derivative of theta i+2 with constant i+1
5039         gs21=scalar2(b1(1,i+1),auxgvec(1))
5040 c derivative of theta i+3 with constant i+1
5041         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5042 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5043 c     &  gtb1(1,i+1)
5044         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5045 c two derivatives over diffetent matrices
5046 c gtae3e2 is derivative over i+3
5047         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5048 c ae3gte2 is derivative over i+2
5049         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5050         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5051 c three possible derivative over theta E matices
5052 c i+1
5053         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5054 c i+2
5055         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5056 c i+3
5057         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5058         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5059
5060         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5061         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5062         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5063         if (shield_mode.eq.0) then
5064         fac_shield(i)=1.0
5065         fac_shield(j)=1.0
5066 C        else
5067 C        fac_shield(i)=0.6
5068 C        fac_shield(j)=0.4
5069         endif
5070         eello_turn4=eello_turn4-(s1+s2+s3)
5071      &  *fac_shield(i)*fac_shield(j)
5072         eello_t4=-(s1+s2+s3)
5073      &  *fac_shield(i)*fac_shield(j)
5074 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5075         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5076      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5077 C Now derivative over shield:
5078           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5079      &  (shield_mode.gt.0)) then
5080 C          print *,i,j
5081
5082           do ilist=1,ishield_list(i)
5083            iresshield=shield_list(ilist,i)
5084            do k=1,3
5085            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5086 C     &      *2.0
5087            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5088      &              rlocshield
5089      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5090             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5091      &      +rlocshield
5092            enddo
5093           enddo
5094           do ilist=1,ishield_list(j)
5095            iresshield=shield_list(ilist,j)
5096            do k=1,3
5097            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5098 C     &     *2.0
5099            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5100      &              rlocshield
5101      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5102            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5103      &             +rlocshield
5104
5105            enddo
5106           enddo
5107
5108           do k=1,3
5109             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5110      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5111             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5112      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5113             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5114      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5115             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5116      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5117            enddo
5118            endif
5119
5120
5121
5122
5123
5124
5125 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5126 cd     &    ' eello_turn4_num',8*eello_turn4_num
5127 #ifdef NEWCORR
5128         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5129      &                  -(gs13+gsE13+gsEE1)*wturn4
5130      &  *fac_shield(i)*fac_shield(j)
5131         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5132      &                    -(gs23+gs21+gsEE2)*wturn4
5133      &  *fac_shield(i)*fac_shield(j)
5134
5135         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5136      &                    -(gs32+gsE31+gsEE3)*wturn4
5137      &  *fac_shield(i)*fac_shield(j)
5138
5139 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5140 c     &   gs2
5141 #endif
5142         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5143      &      'eturn4',i,j,-(s1+s2+s3)
5144 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5145 c     &    ' eello_turn4_num',8*eello_turn4_num
5146 C Derivatives in gamma(i)
5147         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5148         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5149         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5150         s1=scalar2(b1(1,i+2),auxvec(1))
5151         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5152         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5153         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5154      &  *fac_shield(i)*fac_shield(j)
5155 C Derivatives in gamma(i+1)
5156         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5157         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5158         s2=scalar2(b1(1,i+1),auxvec(1))
5159         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5160         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5161         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5162         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5163      &  *fac_shield(i)*fac_shield(j)
5164 C Derivatives in gamma(i+2)
5165         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5166         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5167         s1=scalar2(b1(1,i+2),auxvec(1))
5168         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5169         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5170         s2=scalar2(b1(1,i+1),auxvec(1))
5171         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5172         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5173         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5174         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5175      &  *fac_shield(i)*fac_shield(j)
5176 C Cartesian derivatives
5177 C Derivatives of this turn contributions in DC(i+2)
5178         if (j.lt.nres-1) then
5179           do l=1,3
5180             a_temp(1,1)=agg(l,1)
5181             a_temp(1,2)=agg(l,2)
5182             a_temp(2,1)=agg(l,3)
5183             a_temp(2,2)=agg(l,4)
5184             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5185             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5186             s1=scalar2(b1(1,i+2),auxvec(1))
5187             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5188             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5189             s2=scalar2(b1(1,i+1),auxvec(1))
5190             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5191             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5192             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5193             ggg(l)=-(s1+s2+s3)
5194             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5195      &  *fac_shield(i)*fac_shield(j)
5196           enddo
5197         endif
5198 C Remaining derivatives of this turn contribution
5199         do l=1,3
5200           a_temp(1,1)=aggi(l,1)
5201           a_temp(1,2)=aggi(l,2)
5202           a_temp(2,1)=aggi(l,3)
5203           a_temp(2,2)=aggi(l,4)
5204           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5205           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5206           s1=scalar2(b1(1,i+2),auxvec(1))
5207           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5208           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5209           s2=scalar2(b1(1,i+1),auxvec(1))
5210           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5211           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5212           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5213           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5214      &  *fac_shield(i)*fac_shield(j)
5215           a_temp(1,1)=aggi1(l,1)
5216           a_temp(1,2)=aggi1(l,2)
5217           a_temp(2,1)=aggi1(l,3)
5218           a_temp(2,2)=aggi1(l,4)
5219           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5220           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5221           s1=scalar2(b1(1,i+2),auxvec(1))
5222           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5223           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5224           s2=scalar2(b1(1,i+1),auxvec(1))
5225           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5226           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5227           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5228           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5229      &  *fac_shield(i)*fac_shield(j)
5230           a_temp(1,1)=aggj(l,1)
5231           a_temp(1,2)=aggj(l,2)
5232           a_temp(2,1)=aggj(l,3)
5233           a_temp(2,2)=aggj(l,4)
5234           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5235           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5236           s1=scalar2(b1(1,i+2),auxvec(1))
5237           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5238           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5239           s2=scalar2(b1(1,i+1),auxvec(1))
5240           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5241           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5242           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5243           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5244      &  *fac_shield(i)*fac_shield(j)
5245           a_temp(1,1)=aggj1(l,1)
5246           a_temp(1,2)=aggj1(l,2)
5247           a_temp(2,1)=aggj1(l,3)
5248           a_temp(2,2)=aggj1(l,4)
5249           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5250           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5251           s1=scalar2(b1(1,i+2),auxvec(1))
5252           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5253           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5254           s2=scalar2(b1(1,i+1),auxvec(1))
5255           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5256           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5257           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5258 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5259           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5260      &  *fac_shield(i)*fac_shield(j)
5261         enddo
5262       return
5263       end
5264 C-----------------------------------------------------------------------------
5265       subroutine vecpr(u,v,w)
5266       implicit real*8(a-h,o-z)
5267       dimension u(3),v(3),w(3)
5268       w(1)=u(2)*v(3)-u(3)*v(2)
5269       w(2)=-u(1)*v(3)+u(3)*v(1)
5270       w(3)=u(1)*v(2)-u(2)*v(1)
5271       return
5272       end
5273 C-----------------------------------------------------------------------------
5274       subroutine unormderiv(u,ugrad,unorm,ungrad)
5275 C This subroutine computes the derivatives of a normalized vector u, given
5276 C the derivatives computed without normalization conditions, ugrad. Returns
5277 C ungrad.
5278       implicit none
5279       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5280       double precision vec(3)
5281       double precision scalar
5282       integer i,j
5283 c      write (2,*) 'ugrad',ugrad
5284 c      write (2,*) 'u',u
5285       do i=1,3
5286         vec(i)=scalar(ugrad(1,i),u(1))
5287       enddo
5288 c      write (2,*) 'vec',vec
5289       do i=1,3
5290         do j=1,3
5291           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5292         enddo
5293       enddo
5294 c      write (2,*) 'ungrad',ungrad
5295       return
5296       end
5297 C-----------------------------------------------------------------------------
5298       subroutine escp_soft_sphere(evdw2,evdw2_14)
5299 C
5300 C This subroutine calculates the excluded-volume interaction energy between
5301 C peptide-group centers and side chains and its gradient in virtual-bond and
5302 C side-chain vectors.
5303 C
5304       implicit real*8 (a-h,o-z)
5305       include 'DIMENSIONS'
5306       include 'COMMON.GEO'
5307       include 'COMMON.VAR'
5308       include 'COMMON.LOCAL'
5309       include 'COMMON.CHAIN'
5310       include 'COMMON.DERIV'
5311       include 'COMMON.INTERACT'
5312       include 'COMMON.FFIELD'
5313       include 'COMMON.IOUNITS'
5314       include 'COMMON.CONTROL'
5315       dimension ggg(3)
5316       integer xshift,yshift,zshift
5317       evdw2=0.0D0
5318       evdw2_14=0.0d0
5319       r0_scp=4.5d0
5320 cd    print '(a)','Enter ESCP'
5321 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5322 C      do xshift=-1,1
5323 C      do yshift=-1,1
5324 C      do zshift=-1,1
5325       do i=iatscp_s,iatscp_e
5326         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5327         iteli=itel(i)
5328         xi=0.5D0*(c(1,i)+c(1,i+1))
5329         yi=0.5D0*(c(2,i)+c(2,i+1))
5330         zi=0.5D0*(c(3,i)+c(3,i+1))
5331 C Return atom into box, boxxsize is size of box in x dimension
5332 c  134   continue
5333 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5334 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5335 C Condition for being inside the proper box
5336 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5337 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5338 c        go to 134
5339 c        endif
5340 c  135   continue
5341 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5342 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5343 C Condition for being inside the proper box
5344 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5345 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5346 c        go to 135
5347 c c       endif
5348 c  136   continue
5349 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5350 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5351 cC Condition for being inside the proper box
5352 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5353 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5354 c        go to 136
5355 c        endif
5356           xi=mod(xi,boxxsize)
5357           if (xi.lt.0) xi=xi+boxxsize
5358           yi=mod(yi,boxysize)
5359           if (yi.lt.0) yi=yi+boxysize
5360           zi=mod(zi,boxzsize)
5361           if (zi.lt.0) zi=zi+boxzsize
5362 C          xi=xi+xshift*boxxsize
5363 C          yi=yi+yshift*boxysize
5364 C          zi=zi+zshift*boxzsize
5365         do iint=1,nscp_gr(i)
5366
5367         do j=iscpstart(i,iint),iscpend(i,iint)
5368           if (itype(j).eq.ntyp1) cycle
5369           itypj=iabs(itype(j))
5370 C Uncomment following three lines for SC-p interactions
5371 c         xj=c(1,nres+j)-xi
5372 c         yj=c(2,nres+j)-yi
5373 c         zj=c(3,nres+j)-zi
5374 C Uncomment following three lines for Ca-p interactions
5375           xj=c(1,j)
5376           yj=c(2,j)
5377           zj=c(3,j)
5378 c  174   continue
5379 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5380 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5381 C Condition for being inside the proper box
5382 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5383 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5384 c        go to 174
5385 c        endif
5386 c  175   continue
5387 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5388 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5389 cC Condition for being inside the proper box
5390 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5391 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5392 c        go to 175
5393 c        endif
5394 c  176   continue
5395 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5396 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5397 C Condition for being inside the proper box
5398 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5399 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5400 c        go to 176
5401           xj=mod(xj,boxxsize)
5402           if (xj.lt.0) xj=xj+boxxsize
5403           yj=mod(yj,boxysize)
5404           if (yj.lt.0) yj=yj+boxysize
5405           zj=mod(zj,boxzsize)
5406           if (zj.lt.0) zj=zj+boxzsize
5407       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5408       xj_safe=xj
5409       yj_safe=yj
5410       zj_safe=zj
5411       subchap=0
5412       do xshift=-1,1
5413       do yshift=-1,1
5414       do zshift=-1,1
5415           xj=xj_safe+xshift*boxxsize
5416           yj=yj_safe+yshift*boxysize
5417           zj=zj_safe+zshift*boxzsize
5418           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5419           if(dist_temp.lt.dist_init) then
5420             dist_init=dist_temp
5421             xj_temp=xj
5422             yj_temp=yj
5423             zj_temp=zj
5424             subchap=1
5425           endif
5426        enddo
5427        enddo
5428        enddo
5429        if (subchap.eq.1) then
5430           xj=xj_temp-xi
5431           yj=yj_temp-yi
5432           zj=zj_temp-zi
5433        else
5434           xj=xj_safe-xi
5435           yj=yj_safe-yi
5436           zj=zj_safe-zi
5437        endif
5438 c c       endif
5439 C          xj=xj-xi
5440 C          yj=yj-yi
5441 C          zj=zj-zi
5442           rij=xj*xj+yj*yj+zj*zj
5443
5444           r0ij=r0_scp
5445           r0ijsq=r0ij*r0ij
5446           if (rij.lt.r0ijsq) then
5447             evdwij=0.25d0*(rij-r0ijsq)**2
5448             fac=rij-r0ijsq
5449           else
5450             evdwij=0.0d0
5451             fac=0.0d0
5452           endif
5453           evdw2=evdw2+evdwij
5454 C
5455 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5456 C
5457           ggg(1)=xj*fac
5458           ggg(2)=yj*fac
5459           ggg(3)=zj*fac
5460 cgrad          if (j.lt.i) then
5461 cd          write (iout,*) 'j<i'
5462 C Uncomment following three lines for SC-p interactions
5463 c           do k=1,3
5464 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5465 c           enddo
5466 cgrad          else
5467 cd          write (iout,*) 'j>i'
5468 cgrad            do k=1,3
5469 cgrad              ggg(k)=-ggg(k)
5470 C Uncomment following line for SC-p interactions
5471 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5472 cgrad            enddo
5473 cgrad          endif
5474 cgrad          do k=1,3
5475 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5476 cgrad          enddo
5477 cgrad          kstart=min0(i+1,j)
5478 cgrad          kend=max0(i-1,j-1)
5479 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5480 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5481 cgrad          do k=kstart,kend
5482 cgrad            do l=1,3
5483 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5484 cgrad            enddo
5485 cgrad          enddo
5486           do k=1,3
5487             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5488             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5489           enddo
5490         enddo
5491
5492         enddo ! iint
5493       enddo ! i
5494 C      enddo !zshift
5495 C      enddo !yshift
5496 C      enddo !xshift
5497       return
5498       end
5499 C-----------------------------------------------------------------------------
5500       subroutine escp(evdw2,evdw2_14)
5501 C
5502 C This subroutine calculates the excluded-volume interaction energy between
5503 C peptide-group centers and side chains and its gradient in virtual-bond and
5504 C side-chain vectors.
5505 C
5506       implicit real*8 (a-h,o-z)
5507       include 'DIMENSIONS'
5508       include 'COMMON.GEO'
5509       include 'COMMON.VAR'
5510       include 'COMMON.LOCAL'
5511       include 'COMMON.CHAIN'
5512       include 'COMMON.DERIV'
5513       include 'COMMON.INTERACT'
5514       include 'COMMON.FFIELD'
5515       include 'COMMON.IOUNITS'
5516       include 'COMMON.CONTROL'
5517       include 'COMMON.SPLITELE'
5518       integer xshift,yshift,zshift
5519       dimension ggg(3)
5520       evdw2=0.0D0
5521       evdw2_14=0.0d0
5522 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5523 cd    print '(a)','Enter ESCP'
5524 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5525 C      do xshift=-1,1
5526 C      do yshift=-1,1
5527 C      do zshift=-1,1
5528 c      write (iout,*) "INIgvdwc_scp"
5529 c      do i=1,nres
5530 c        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gvdwc_scp(j,i),j=1,3),
5531 c     &    (gvdwc_scpp(j,i),j=1,3)
5532 c      enddo
5533       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5534       do i=iatscp_s,iatscp_e
5535         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5536         iteli=itel(i)
5537         xi=0.5D0*(c(1,i)+c(1,i+1))
5538         yi=0.5D0*(c(2,i)+c(2,i+1))
5539         zi=0.5D0*(c(3,i)+c(3,i+1))
5540           xi=mod(xi,boxxsize)
5541           if (xi.lt.0) xi=xi+boxxsize
5542           yi=mod(yi,boxysize)
5543           if (yi.lt.0) yi=yi+boxysize
5544           zi=mod(zi,boxzsize)
5545           if (zi.lt.0) zi=zi+boxzsize
5546 c          xi=xi+xshift*boxxsize
5547 c          yi=yi+yshift*boxysize
5548 c          zi=zi+zshift*boxzsize
5549 c        print *,xi,yi,zi,'polozenie i'
5550 C Return atom into box, boxxsize is size of box in x dimension
5551 c  134   continue
5552 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5553 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5554 C Condition for being inside the proper box
5555 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5556 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5557 c        go to 134
5558 c        endif
5559 c  135   continue
5560 c          print *,xi,boxxsize,"pierwszy"
5561
5562 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5563 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5564 C Condition for being inside the proper box
5565 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5566 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5567 c        go to 135
5568 c        endif
5569 c  136   continue
5570 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5571 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5572 C Condition for being inside the proper box
5573 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5574 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5575 c        go to 136
5576 c        endif
5577         do iint=1,nscp_gr(i)
5578
5579         do j=iscpstart(i,iint),iscpend(i,iint)
5580           itypj=iabs(itype(j))
5581           if (itypj.eq.ntyp1) cycle
5582 C Uncomment following three lines for SC-p interactions
5583 c         xj=c(1,nres+j)-xi
5584 c         yj=c(2,nres+j)-yi
5585 c         zj=c(3,nres+j)-zi
5586 C Uncomment following three lines for Ca-p interactions
5587           xj=c(1,j)
5588           yj=c(2,j)
5589           zj=c(3,j)
5590           xj=mod(xj,boxxsize)
5591           if (xj.lt.0) xj=xj+boxxsize
5592           yj=mod(yj,boxysize)
5593           if (yj.lt.0) yj=yj+boxysize
5594           zj=mod(zj,boxzsize)
5595           if (zj.lt.0) zj=zj+boxzsize
5596 c  174   continue
5597 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5598 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5599 C Condition for being inside the proper box
5600 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5601 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5602 c        go to 174
5603 c        endif
5604 c  175   continue
5605 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5606 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5607 cC Condition for being inside the proper box
5608 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5609 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5610 c        go to 175
5611 c        endif
5612 c  176   continue
5613 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5614 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5615 C Condition for being inside the proper box
5616 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5617 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5618 c        go to 176
5619 c        endif
5620 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5621       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5622       xj_safe=xj
5623       yj_safe=yj
5624       zj_safe=zj
5625       subchap=0
5626       do xshift=-1,1
5627       do yshift=-1,1
5628       do zshift=-1,1
5629           xj=xj_safe+xshift*boxxsize
5630           yj=yj_safe+yshift*boxysize
5631           zj=zj_safe+zshift*boxzsize
5632           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5633           if(dist_temp.lt.dist_init) then
5634             dist_init=dist_temp
5635             xj_temp=xj
5636             yj_temp=yj
5637             zj_temp=zj
5638             subchap=1
5639           endif
5640        enddo
5641        enddo
5642        enddo
5643        if (subchap.eq.1) then
5644           xj=xj_temp-xi
5645           yj=yj_temp-yi
5646           zj=zj_temp-zi
5647        else
5648           xj=xj_safe-xi
5649           yj=yj_safe-yi
5650           zj=zj_safe-zi
5651        endif
5652 c          print *,xj,yj,zj,'polozenie j'
5653           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5654 c          print *,rrij
5655           sss=sscale(1.0d0/(dsqrt(rrij)))
5656 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5657 c          if (sss.eq.0) print *,'czasem jest OK'
5658           if (sss.le.0.0d0) cycle
5659           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5660           fac=rrij**expon2
5661           e1=fac*fac*aad(itypj,iteli)
5662           e2=fac*bad(itypj,iteli)
5663           if (iabs(j-i) .le. 2) then
5664             e1=scal14*e1
5665             e2=scal14*e2
5666             evdw2_14=evdw2_14+(e1+e2)*sss
5667           endif
5668           evdwij=e1+e2
5669           evdw2=evdw2+evdwij*sss
5670           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5671      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5672      &       bad(itypj,iteli)
5673 C
5674 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5675 C
5676           fac=-(evdwij+e1)*rrij*sss
5677           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5678           ggg(1)=xj*fac
5679           ggg(2)=yj*fac
5680           ggg(3)=zj*fac
5681 cgrad          if (j.lt.i) then
5682 cd          write (iout,*) 'j<i'
5683 C Uncomment following three lines for SC-p interactions
5684 c           do k=1,3
5685 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5686 c           enddo
5687 cgrad          else
5688 cd          write (iout,*) 'j>i'
5689 cgrad            do k=1,3
5690 cgrad              ggg(k)=-ggg(k)
5691 C Uncomment following line for SC-p interactions
5692 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5693 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5694 cgrad            enddo
5695 cgrad          endif
5696 cgrad          do k=1,3
5697 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5698 cgrad          enddo
5699 cgrad          kstart=min0(i+1,j)
5700 cgrad          kend=max0(i-1,j-1)
5701 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5702 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5703 cgrad          do k=kstart,kend
5704 cgrad            do l=1,3
5705 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5706 cgrad            enddo
5707 cgrad          enddo
5708           do k=1,3
5709             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5710             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5711           enddo
5712 c        endif !endif for sscale cutoff
5713         enddo ! j
5714
5715         enddo ! iint
5716       enddo ! i
5717 c      enddo !zshift
5718 c      enddo !yshift
5719 c      enddo !xshift
5720       do i=1,nct
5721         do j=1,3
5722           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5723           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5724           gradx_scp(j,i)=expon*gradx_scp(j,i)
5725         enddo
5726       enddo
5727 C******************************************************************************
5728 C
5729 C                              N O T E !!!
5730 C
5731 C To save time the factor EXPON has been extracted from ALL components
5732 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5733 C use!
5734 C
5735 C******************************************************************************
5736 c      write (iout,*) "gvdwc_scp"
5737 c      do i=1,nres
5738 c        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gvdwc_scp(j,i),j=1,3),
5739 c     &    (gvdwc_scpp(j,i),j=1,3)
5740 c      enddo
5741
5742       return
5743       end
5744 C--------------------------------------------------------------------------
5745       subroutine edis(ehpb)
5746 C
5747 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5748 C
5749       implicit real*8 (a-h,o-z)
5750       include 'DIMENSIONS'
5751       include 'COMMON.SBRIDGE'
5752       include 'COMMON.CHAIN'
5753       include 'COMMON.DERIV'
5754       include 'COMMON.VAR'
5755       include 'COMMON.INTERACT'
5756       include 'COMMON.IOUNITS'
5757       include 'COMMON.CONTROL'
5758       dimension ggg(3)
5759       ehpb=0.0D0
5760       do i=1,3
5761        ggg(i)=0.0d0
5762       enddo
5763 C      write (iout,*) ,"link_end",link_end,constr_dist
5764 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5765 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5766       if (link_end.eq.0) return
5767       do i=link_start,link_end
5768 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5769 C CA-CA distance used in regularization of structure.
5770         ii=ihpb(i)
5771         jj=jhpb(i)
5772 C iii and jjj point to the residues for which the distance is assigned.
5773         if (ii.gt.nres) then
5774           iii=ii-nres
5775           jjj=jj-nres
5776         else
5777           iii=ii
5778           jjj=jj
5779         endif
5780 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5781 c     &    dhpb(i),dhpb1(i),forcon(i)
5782 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5783 C    distance and angle dependent SS bond potential.
5784 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5785 C     & iabs(itype(jjj)).eq.1) then
5786 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5787 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5788         if (.not.dyn_ss .and. i.le.nss) then
5789 C 15/02/13 CC dynamic SSbond - additional check
5790          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5791      & iabs(itype(jjj)).eq.1) then
5792           call ssbond_ene(iii,jjj,eij)
5793           ehpb=ehpb+2*eij
5794          endif
5795 cd          write (iout,*) "eij",eij
5796 cd   &   ' waga=',waga,' fac=',fac
5797         else if (ii.gt.nres .and. jj.gt.nres) then
5798 c Restraints from contact prediction
5799           dd=dist(ii,jj)
5800           if (constr_dist.eq.11) then
5801             ehpb=ehpb+fordepth(i)!**4.0d0
5802      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5803             fac=fordepth(i)!**4.0d0
5804      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5805            if (energy_dec) write (iout,'(a6,2i5,6f10.3)') "edisl",ii,jj,
5806      &    dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),ehpb
5807            else
5808           if (dhpb1(i).gt.0.0d0) then
5809             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5810             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5811 c            write (iout,*) "beta nmr",
5812 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5813           else
5814             dd=dist(ii,jj)
5815             rdis=dd-dhpb(i)
5816 C Get the force constant corresponding to this distance.
5817             waga=forcon(i)
5818 C Calculate the contribution to energy.
5819             ehpb=ehpb+waga*rdis*rdis
5820 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5821 C
5822 C Evaluate gradient.
5823 C
5824             fac=waga*rdis/dd
5825           endif
5826           endif
5827           do j=1,3
5828             ggg(j)=fac*(c(j,jj)-c(j,ii))
5829           enddo
5830           do j=1,3
5831             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5832             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5833           enddo
5834           do k=1,3
5835             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5836             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5837           enddo
5838         else
5839 C Calculate the distance between the two points and its difference from the
5840 C target distance.
5841           dd=dist(ii,jj)
5842           if (constr_dist.eq.11) then
5843             ehpb=ehpb+fordepth(i)!**4.0d0
5844      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5845             fac=fordepth(i)!**4.0d0
5846      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5847            if (energy_dec) write (iout,'(a6,2i5,6f10.3)') "edisl",ii,jj,
5848      &    dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),ehpb
5849            else
5850           if (dhpb1(i).gt.0.0d0) then
5851             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5852             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5853 c            write (iout,*) "alph nmr",
5854 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5855           else
5856             rdis=dd-dhpb(i)
5857 C Get the force constant corresponding to this distance.
5858             waga=forcon(i)
5859 C Calculate the contribution to energy.
5860             ehpb=ehpb+waga*rdis*rdis
5861 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5862 C
5863 C Evaluate gradient.
5864 C
5865             fac=waga*rdis/dd
5866           endif
5867           endif
5868             do j=1,3
5869               ggg(j)=fac*(c(j,jj)-c(j,ii))
5870             enddo
5871 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5872 C If this is a SC-SC distance, we need to calculate the contributions to the
5873 C Cartesian gradient in the SC vectors (ghpbx).
5874           if (iii.lt.ii) then
5875           do j=1,3
5876             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5877             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5878           enddo
5879           endif
5880 cgrad        do j=iii,jjj-1
5881 cgrad          do k=1,3
5882 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5883 cgrad          enddo
5884 cgrad        enddo
5885           do k=1,3
5886             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5887             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5888           enddo
5889         endif
5890       enddo
5891       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5892       return
5893       end
5894 C--------------------------------------------------------------------------
5895       subroutine ssbond_ene(i,j,eij)
5896 C
5897 C Calculate the distance and angle dependent SS-bond potential energy
5898 C using a free-energy function derived based on RHF/6-31G** ab initio
5899 C calculations of diethyl disulfide.
5900 C
5901 C A. Liwo and U. Kozlowska, 11/24/03
5902 C
5903       implicit real*8 (a-h,o-z)
5904       include 'DIMENSIONS'
5905       include 'COMMON.SBRIDGE'
5906       include 'COMMON.CHAIN'
5907       include 'COMMON.DERIV'
5908       include 'COMMON.LOCAL'
5909       include 'COMMON.INTERACT'
5910       include 'COMMON.VAR'
5911       include 'COMMON.IOUNITS'
5912       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5913       itypi=iabs(itype(i))
5914       xi=c(1,nres+i)
5915       yi=c(2,nres+i)
5916       zi=c(3,nres+i)
5917       dxi=dc_norm(1,nres+i)
5918       dyi=dc_norm(2,nres+i)
5919       dzi=dc_norm(3,nres+i)
5920 c      dsci_inv=dsc_inv(itypi)
5921       dsci_inv=vbld_inv(nres+i)
5922       itypj=iabs(itype(j))
5923 c      dscj_inv=dsc_inv(itypj)
5924       dscj_inv=vbld_inv(nres+j)
5925       xj=c(1,nres+j)-xi
5926       yj=c(2,nres+j)-yi
5927       zj=c(3,nres+j)-zi
5928       dxj=dc_norm(1,nres+j)
5929       dyj=dc_norm(2,nres+j)
5930       dzj=dc_norm(3,nres+j)
5931       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5932       rij=dsqrt(rrij)
5933       erij(1)=xj*rij
5934       erij(2)=yj*rij
5935       erij(3)=zj*rij
5936       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5937       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5938       om12=dxi*dxj+dyi*dyj+dzi*dzj
5939       do k=1,3
5940         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5941         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5942       enddo
5943       rij=1.0d0/rij
5944       deltad=rij-d0cm
5945       deltat1=1.0d0-om1
5946       deltat2=1.0d0+om2
5947       deltat12=om2-om1+2.0d0
5948       cosphi=om12-om1*om2
5949       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5950      &  +akct*deltad*deltat12
5951      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5952 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5953 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5954 c     &  " deltat12",deltat12," eij",eij
5955       ed=2*akcm*deltad+akct*deltat12
5956       pom1=akct*deltad
5957       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5958       eom1=-2*akth*deltat1-pom1-om2*pom2
5959       eom2= 2*akth*deltat2+pom1-om1*pom2
5960       eom12=pom2
5961       do k=1,3
5962         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5963         ghpbx(k,i)=ghpbx(k,i)-ggk
5964      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5965      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5966         ghpbx(k,j)=ghpbx(k,j)+ggk
5967      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5968      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5969         ghpbc(k,i)=ghpbc(k,i)-ggk
5970         ghpbc(k,j)=ghpbc(k,j)+ggk
5971       enddo
5972 C
5973 C Calculate the components of the gradient in DC and X
5974 C
5975 cgrad      do k=i,j-1
5976 cgrad        do l=1,3
5977 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5978 cgrad        enddo
5979 cgrad      enddo
5980       return
5981       end
5982 C--------------------------------------------------------------------------
5983       subroutine ebond(estr)
5984 c
5985 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5986 c
5987       implicit real*8 (a-h,o-z)
5988       include 'DIMENSIONS'
5989       include 'COMMON.LOCAL'
5990       include 'COMMON.GEO'
5991       include 'COMMON.INTERACT'
5992       include 'COMMON.DERIV'
5993       include 'COMMON.VAR'
5994       include 'COMMON.CHAIN'
5995       include 'COMMON.IOUNITS'
5996       include 'COMMON.NAMES'
5997       include 'COMMON.FFIELD'
5998       include 'COMMON.CONTROL'
5999       include 'COMMON.SETUP'
6000       double precision u(3),ud(3)
6001       estr=0.0d0
6002       estr1=0.0d0
6003       do i=ibondp_start,ibondp_end
6004         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6005 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6006 c          do j=1,3
6007 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6008 c     &      *dc(j,i-1)/vbld(i)
6009 c          enddo
6010 c          if (energy_dec) write(iout,*)
6011 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6012 c        else
6013 C       Checking if it involves dummy (NH3+ or COO-) group
6014          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6015 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6016         diff = vbld(i)-vbldpDUM
6017         if (energy_dec) write(iout,*) "dum_bond",i,diff
6018          else
6019 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6020         diff = vbld(i)-vbldp0
6021          endif
6022         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6023      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6024         estr=estr+diff*diff
6025         do j=1,3
6026           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6027         enddo
6028 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6029 c        endif
6030       enddo
6031
6032       estr=0.5d0*AKP*estr+estr1
6033 c
6034 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6035 c
6036       do i=ibond_start,ibond_end
6037         iti=iabs(itype(i))
6038         if (iti.ne.10 .and. iti.ne.ntyp1) then
6039           nbi=nbondterm(iti)
6040           if (nbi.eq.1) then
6041             diff=vbld(i+nres)-vbldsc0(1,iti)
6042             if (energy_dec)  write (iout,*)
6043      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6044      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6045             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6046             do j=1,3
6047               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6048             enddo
6049           else
6050             do j=1,nbi
6051               diff=vbld(i+nres)-vbldsc0(j,iti)
6052               ud(j)=aksc(j,iti)*diff
6053               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6054             enddo
6055             uprod=u(1)
6056             do j=2,nbi
6057               uprod=uprod*u(j)
6058             enddo
6059             usum=0.0d0
6060             usumsqder=0.0d0
6061             do j=1,nbi
6062               uprod1=1.0d0
6063               uprod2=1.0d0
6064               do k=1,nbi
6065                 if (k.ne.j) then
6066                   uprod1=uprod1*u(k)
6067                   uprod2=uprod2*u(k)*u(k)
6068                 endif
6069               enddo
6070               usum=usum+uprod1
6071               usumsqder=usumsqder+ud(j)*uprod2
6072             enddo
6073             estr=estr+uprod/usum
6074             do j=1,3
6075              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6076             enddo
6077           endif
6078         endif
6079       enddo
6080       return
6081       end
6082 #ifdef CRYST_THETA
6083 C--------------------------------------------------------------------------
6084       subroutine ebend(etheta)
6085 C
6086 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6087 C angles gamma and its derivatives in consecutive thetas and gammas.
6088 C
6089       implicit real*8 (a-h,o-z)
6090       include 'DIMENSIONS'
6091       include 'COMMON.LOCAL'
6092       include 'COMMON.GEO'
6093       include 'COMMON.INTERACT'
6094       include 'COMMON.DERIV'
6095       include 'COMMON.VAR'
6096       include 'COMMON.CHAIN'
6097       include 'COMMON.IOUNITS'
6098       include 'COMMON.NAMES'
6099       include 'COMMON.FFIELD'
6100       include 'COMMON.CONTROL'
6101       include 'COMMON.TORCNSTR'
6102       common /calcthet/ term1,term2,termm,diffak,ratak,
6103      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6104      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6105       double precision y(2),z(2)
6106       delta=0.02d0*pi
6107 c      time11=dexp(-2*time)
6108 c      time12=1.0d0
6109       etheta=0.0D0
6110 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6111       do i=ithet_start,ithet_end
6112         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6113      &  .or.itype(i).eq.ntyp1) cycle
6114 C Zero the energy function and its derivative at 0 or pi.
6115         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6116         it=itype(i-1)
6117         ichir1=isign(1,itype(i-2))
6118         ichir2=isign(1,itype(i))
6119          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6120          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6121          if (itype(i-1).eq.10) then
6122           itype1=isign(10,itype(i-2))
6123           ichir11=isign(1,itype(i-2))
6124           ichir12=isign(1,itype(i-2))
6125           itype2=isign(10,itype(i))
6126           ichir21=isign(1,itype(i))
6127           ichir22=isign(1,itype(i))
6128          endif
6129
6130         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6131 #ifdef OSF
6132           phii=phi(i)
6133           if (phii.ne.phii) phii=150.0
6134 #else
6135           phii=phi(i)
6136 #endif
6137           y(1)=dcos(phii)
6138           y(2)=dsin(phii)
6139         else
6140           y(1)=0.0D0
6141           y(2)=0.0D0
6142         endif
6143         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6144 #ifdef OSF
6145           phii1=phi(i+1)
6146           if (phii1.ne.phii1) phii1=150.0
6147           phii1=pinorm(phii1)
6148           z(1)=cos(phii1)
6149 #else
6150           phii1=phi(i+1)
6151 #endif
6152           z(1)=dcos(phii1)
6153           z(2)=dsin(phii1)
6154         else
6155           z(1)=0.0D0
6156           z(2)=0.0D0
6157         endif
6158 C Calculate the "mean" value of theta from the part of the distribution
6159 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6160 C In following comments this theta will be referred to as t_c.
6161         thet_pred_mean=0.0d0
6162         do k=1,2
6163             athetk=athet(k,it,ichir1,ichir2)
6164             bthetk=bthet(k,it,ichir1,ichir2)
6165           if (it.eq.10) then
6166              athetk=athet(k,itype1,ichir11,ichir12)
6167              bthetk=bthet(k,itype2,ichir21,ichir22)
6168           endif
6169          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6170 c         write(iout,*) 'chuj tu', y(k),z(k)
6171         enddo
6172         dthett=thet_pred_mean*ssd
6173         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6174 C Derivatives of the "mean" values in gamma1 and gamma2.
6175         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6176      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6177          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6178      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6179          if (it.eq.10) then
6180       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6181      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6182         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6183      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6184          endif
6185         if (theta(i).gt.pi-delta) then
6186           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6187      &         E_tc0)
6188           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6189           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6190           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6191      &        E_theta)
6192           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6193      &        E_tc)
6194         else if (theta(i).lt.delta) then
6195           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6196           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6197           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6198      &        E_theta)
6199           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6200           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6201      &        E_tc)
6202         else
6203           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6204      &        E_theta,E_tc)
6205         endif
6206         etheta=etheta+ethetai
6207         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6208      &      'ebend',i,ethetai,theta(i),itype(i)
6209         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6210         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6211         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6212       enddo
6213
6214 C Ufff.... We've done all this!!!
6215       return
6216       end
6217 C---------------------------------------------------------------------------
6218       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6219      &     E_tc)
6220       implicit real*8 (a-h,o-z)
6221       include 'DIMENSIONS'
6222       include 'COMMON.LOCAL'
6223       include 'COMMON.IOUNITS'
6224       common /calcthet/ term1,term2,termm,diffak,ratak,
6225      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6226      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6227 C Calculate the contributions to both Gaussian lobes.
6228 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6229 C The "polynomial part" of the "standard deviation" of this part of
6230 C the distributioni.
6231 ccc        write (iout,*) thetai,thet_pred_mean
6232         sig=polthet(3,it)
6233         do j=2,0,-1
6234           sig=sig*thet_pred_mean+polthet(j,it)
6235         enddo
6236 C Derivative of the "interior part" of the "standard deviation of the"
6237 C gamma-dependent Gaussian lobe in t_c.
6238         sigtc=3*polthet(3,it)
6239         do j=2,1,-1
6240           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6241         enddo
6242         sigtc=sig*sigtc
6243 C Set the parameters of both Gaussian lobes of the distribution.
6244 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6245         fac=sig*sig+sigc0(it)
6246         sigcsq=fac+fac
6247         sigc=1.0D0/sigcsq
6248 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6249         sigsqtc=-4.0D0*sigcsq*sigtc
6250 c       print *,i,sig,sigtc,sigsqtc
6251 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6252         sigtc=-sigtc/(fac*fac)
6253 C Following variable is sigma(t_c)**(-2)
6254         sigcsq=sigcsq*sigcsq
6255         sig0i=sig0(it)
6256         sig0inv=1.0D0/sig0i**2
6257         delthec=thetai-thet_pred_mean
6258         delthe0=thetai-theta0i
6259         term1=-0.5D0*sigcsq*delthec*delthec
6260         term2=-0.5D0*sig0inv*delthe0*delthe0
6261 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6262 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6263 C NaNs in taking the logarithm. We extract the largest exponent which is added
6264 C to the energy (this being the log of the distribution) at the end of energy
6265 C term evaluation for this virtual-bond angle.
6266         if (term1.gt.term2) then
6267           termm=term1
6268           term2=dexp(term2-termm)
6269           term1=1.0d0
6270         else
6271           termm=term2
6272           term1=dexp(term1-termm)
6273           term2=1.0d0
6274         endif
6275 C The ratio between the gamma-independent and gamma-dependent lobes of
6276 C the distribution is a Gaussian function of thet_pred_mean too.
6277         diffak=gthet(2,it)-thet_pred_mean
6278         ratak=diffak/gthet(3,it)**2
6279         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6280 C Let's differentiate it in thet_pred_mean NOW.
6281         aktc=ak*ratak
6282 C Now put together the distribution terms to make complete distribution.
6283         termexp=term1+ak*term2
6284         termpre=sigc+ak*sig0i
6285 C Contribution of the bending energy from this theta is just the -log of
6286 C the sum of the contributions from the two lobes and the pre-exponential
6287 C factor. Simple enough, isn't it?
6288         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6289 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6290 C NOW the derivatives!!!
6291 C 6/6/97 Take into account the deformation.
6292         E_theta=(delthec*sigcsq*term1
6293      &       +ak*delthe0*sig0inv*term2)/termexp
6294         E_tc=((sigtc+aktc*sig0i)/termpre
6295      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6296      &       aktc*term2)/termexp)
6297       return
6298       end
6299 c-----------------------------------------------------------------------------
6300       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6301       implicit real*8 (a-h,o-z)
6302       include 'DIMENSIONS'
6303       include 'COMMON.LOCAL'
6304       include 'COMMON.IOUNITS'
6305       common /calcthet/ term1,term2,termm,diffak,ratak,
6306      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6307      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6308       delthec=thetai-thet_pred_mean
6309       delthe0=thetai-theta0i
6310 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6311       t3 = thetai-thet_pred_mean
6312       t6 = t3**2
6313       t9 = term1
6314       t12 = t3*sigcsq
6315       t14 = t12+t6*sigsqtc
6316       t16 = 1.0d0
6317       t21 = thetai-theta0i
6318       t23 = t21**2
6319       t26 = term2
6320       t27 = t21*t26
6321       t32 = termexp
6322       t40 = t32**2
6323       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6324      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6325      & *(-t12*t9-ak*sig0inv*t27)
6326       return
6327       end
6328 #else
6329 C--------------------------------------------------------------------------
6330       subroutine ebend(etheta)
6331 C
6332 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6333 C angles gamma and its derivatives in consecutive thetas and gammas.
6334 C ab initio-derived potentials from
6335 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6336 C
6337       implicit real*8 (a-h,o-z)
6338       include 'DIMENSIONS'
6339       include 'COMMON.LOCAL'
6340       include 'COMMON.GEO'
6341       include 'COMMON.INTERACT'
6342       include 'COMMON.DERIV'
6343       include 'COMMON.VAR'
6344       include 'COMMON.CHAIN'
6345       include 'COMMON.IOUNITS'
6346       include 'COMMON.NAMES'
6347       include 'COMMON.FFIELD'
6348       include 'COMMON.CONTROL'
6349       include 'COMMON.TORCNSTR'
6350       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6351      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6352      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6353      & sinph1ph2(maxdouble,maxdouble)
6354       logical lprn /.false./, lprn1 /.false./
6355       etheta=0.0D0
6356       do i=ithet_start,ithet_end
6357 c        print *,i,itype(i-1),itype(i),itype(i-2)
6358         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6359      &  .or.itype(i).eq.ntyp1) cycle
6360 C        print *,i,theta(i)
6361         if (iabs(itype(i+1)).eq.20) iblock=2
6362         if (iabs(itype(i+1)).ne.20) iblock=1
6363         dethetai=0.0d0
6364         dephii=0.0d0
6365         dephii1=0.0d0
6366         theti2=0.5d0*theta(i)
6367         ityp2=ithetyp((itype(i-1)))
6368         do k=1,nntheterm
6369           coskt(k)=dcos(k*theti2)
6370           sinkt(k)=dsin(k*theti2)
6371         enddo
6372 C        print *,ethetai
6373         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6374 #ifdef OSF
6375           phii=phi(i)
6376           if (phii.ne.phii) phii=150.0
6377 #else
6378           phii=phi(i)
6379 #endif
6380           ityp1=ithetyp((itype(i-2)))
6381 C propagation of chirality for glycine type
6382           do k=1,nsingle
6383             cosph1(k)=dcos(k*phii)
6384             sinph1(k)=dsin(k*phii)
6385           enddo
6386         else
6387           phii=0.0d0
6388           do k=1,nsingle
6389           ityp1=ithetyp((itype(i-2)))
6390             cosph1(k)=0.0d0
6391             sinph1(k)=0.0d0
6392           enddo
6393         endif
6394         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6395 #ifdef OSF
6396           phii1=phi(i+1)
6397           if (phii1.ne.phii1) phii1=150.0
6398           phii1=pinorm(phii1)
6399 #else
6400           phii1=phi(i+1)
6401 #endif
6402           ityp3=ithetyp((itype(i)))
6403           do k=1,nsingle
6404             cosph2(k)=dcos(k*phii1)
6405             sinph2(k)=dsin(k*phii1)
6406           enddo
6407         else
6408           phii1=0.0d0
6409           ityp3=ithetyp((itype(i)))
6410           do k=1,nsingle
6411             cosph2(k)=0.0d0
6412             sinph2(k)=0.0d0
6413           enddo
6414         endif
6415         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6416         do k=1,ndouble
6417           do l=1,k-1
6418             ccl=cosph1(l)*cosph2(k-l)
6419             ssl=sinph1(l)*sinph2(k-l)
6420             scl=sinph1(l)*cosph2(k-l)
6421             csl=cosph1(l)*sinph2(k-l)
6422             cosph1ph2(l,k)=ccl-ssl
6423             cosph1ph2(k,l)=ccl+ssl
6424             sinph1ph2(l,k)=scl+csl
6425             sinph1ph2(k,l)=scl-csl
6426           enddo
6427         enddo
6428         if (lprn) then
6429         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6430      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6431         write (iout,*) "coskt and sinkt"
6432         do k=1,nntheterm
6433           write (iout,*) k,coskt(k),sinkt(k)
6434         enddo
6435         endif
6436         do k=1,ntheterm
6437           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6438           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6439      &      *coskt(k)
6440           if (lprn)
6441      &    write (iout,*) "k",k,"
6442      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6443      &     " ethetai",ethetai
6444         enddo
6445         if (lprn) then
6446         write (iout,*) "cosph and sinph"
6447         do k=1,nsingle
6448           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6449         enddo
6450         write (iout,*) "cosph1ph2 and sinph2ph2"
6451         do k=2,ndouble
6452           do l=1,k-1
6453             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6454      &         sinph1ph2(l,k),sinph1ph2(k,l)
6455           enddo
6456         enddo
6457         write(iout,*) "ethetai",ethetai
6458         endif
6459 C       print *,ethetai
6460         do m=1,ntheterm2
6461           do k=1,nsingle
6462             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6463      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6464      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6465      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6466             ethetai=ethetai+sinkt(m)*aux
6467             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6468             dephii=dephii+k*sinkt(m)*(
6469      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6470      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6471             dephii1=dephii1+k*sinkt(m)*(
6472      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6473      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6474             if (lprn)
6475      &      write (iout,*) "m",m," k",k," bbthet",
6476      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6477      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6478      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6479      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6480 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6481           enddo
6482         enddo
6483 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6484 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6485 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6486 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6487         if (lprn)
6488      &  write(iout,*) "ethetai",ethetai
6489 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6490         do m=1,ntheterm3
6491           do k=2,ndouble
6492             do l=1,k-1
6493               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6494      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6495      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6496      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6497               ethetai=ethetai+sinkt(m)*aux
6498               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6499               dephii=dephii+l*sinkt(m)*(
6500      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6501      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6502      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6503      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6504               dephii1=dephii1+(k-l)*sinkt(m)*(
6505      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6506      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6507      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6508      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6509               if (lprn) then
6510               write (iout,*) "m",m," k",k," l",l," ffthet",
6511      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6512      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6513      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6514      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6515      &            " ethetai",ethetai
6516               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6517      &            cosph1ph2(k,l)*sinkt(m),
6518      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6519               endif
6520             enddo
6521           enddo
6522         enddo
6523 10      continue
6524 c        lprn1=.true.
6525 C        print *,ethetai
6526         if (lprn1)
6527      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6528      &   i,theta(i)*rad2deg,phii*rad2deg,
6529      &   phii1*rad2deg,ethetai
6530 c        lprn1=.false.
6531         etheta=etheta+ethetai
6532         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6533         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6534         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6535       enddo
6536
6537       return
6538       end
6539 #endif
6540 #ifdef CRYST_SC
6541 c-----------------------------------------------------------------------------
6542       subroutine esc(escloc)
6543 C Calculate the local energy of a side chain and its derivatives in the
6544 C corresponding virtual-bond valence angles THETA and the spherical angles
6545 C ALPHA and OMEGA.
6546       implicit real*8 (a-h,o-z)
6547       include 'DIMENSIONS'
6548       include 'COMMON.GEO'
6549       include 'COMMON.LOCAL'
6550       include 'COMMON.VAR'
6551       include 'COMMON.INTERACT'
6552       include 'COMMON.DERIV'
6553       include 'COMMON.CHAIN'
6554       include 'COMMON.IOUNITS'
6555       include 'COMMON.NAMES'
6556       include 'COMMON.FFIELD'
6557       include 'COMMON.CONTROL'
6558       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6559      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6560       common /sccalc/ time11,time12,time112,theti,it,nlobit
6561       delta=0.02d0*pi
6562       escloc=0.0D0
6563 c     write (iout,'(a)') 'ESC'
6564       do i=loc_start,loc_end
6565         it=itype(i)
6566         if (it.eq.ntyp1) cycle
6567         if (it.eq.10) goto 1
6568         nlobit=nlob(iabs(it))
6569 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6570 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6571         theti=theta(i+1)-pipol
6572         x(1)=dtan(theti)
6573         x(2)=alph(i)
6574         x(3)=omeg(i)
6575
6576         if (x(2).gt.pi-delta) then
6577           xtemp(1)=x(1)
6578           xtemp(2)=pi-delta
6579           xtemp(3)=x(3)
6580           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6581           xtemp(2)=pi
6582           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6583           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6584      &        escloci,dersc(2))
6585           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6586      &        ddersc0(1),dersc(1))
6587           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6588      &        ddersc0(3),dersc(3))
6589           xtemp(2)=pi-delta
6590           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6591           xtemp(2)=pi
6592           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6593           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6594      &            dersc0(2),esclocbi,dersc02)
6595           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6596      &            dersc12,dersc01)
6597           call splinthet(x(2),0.5d0*delta,ss,ssd)
6598           dersc0(1)=dersc01
6599           dersc0(2)=dersc02
6600           dersc0(3)=0.0d0
6601           do k=1,3
6602             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6603           enddo
6604           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6605 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6606 c    &             esclocbi,ss,ssd
6607           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6608 c         escloci=esclocbi
6609 c         write (iout,*) escloci
6610         else if (x(2).lt.delta) then
6611           xtemp(1)=x(1)
6612           xtemp(2)=delta
6613           xtemp(3)=x(3)
6614           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6615           xtemp(2)=0.0d0
6616           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6617           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6618      &        escloci,dersc(2))
6619           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6620      &        ddersc0(1),dersc(1))
6621           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6622      &        ddersc0(3),dersc(3))
6623           xtemp(2)=delta
6624           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6625           xtemp(2)=0.0d0
6626           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6627           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6628      &            dersc0(2),esclocbi,dersc02)
6629           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6630      &            dersc12,dersc01)
6631           dersc0(1)=dersc01
6632           dersc0(2)=dersc02
6633           dersc0(3)=0.0d0
6634           call splinthet(x(2),0.5d0*delta,ss,ssd)
6635           do k=1,3
6636             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6637           enddo
6638           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6639 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6640 c    &             esclocbi,ss,ssd
6641           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6642 c         write (iout,*) escloci
6643         else
6644           call enesc(x,escloci,dersc,ddummy,.false.)
6645         endif
6646
6647         escloc=escloc+escloci
6648         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6649      &     'escloc',i,escloci
6650 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6651
6652         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6653      &   wscloc*dersc(1)
6654         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6655         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6656     1   continue
6657       enddo
6658       return
6659       end
6660 C---------------------------------------------------------------------------
6661       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6662       implicit real*8 (a-h,o-z)
6663       include 'DIMENSIONS'
6664       include 'COMMON.GEO'
6665       include 'COMMON.LOCAL'
6666       include 'COMMON.IOUNITS'
6667       common /sccalc/ time11,time12,time112,theti,it,nlobit
6668       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6669       double precision contr(maxlob,-1:1)
6670       logical mixed
6671 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6672         escloc_i=0.0D0
6673         do j=1,3
6674           dersc(j)=0.0D0
6675           if (mixed) ddersc(j)=0.0d0
6676         enddo
6677         x3=x(3)
6678
6679 C Because of periodicity of the dependence of the SC energy in omega we have
6680 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6681 C To avoid underflows, first compute & store the exponents.
6682
6683         do iii=-1,1
6684
6685           x(3)=x3+iii*dwapi
6686
6687           do j=1,nlobit
6688             do k=1,3
6689               z(k)=x(k)-censc(k,j,it)
6690             enddo
6691             do k=1,3
6692               Axk=0.0D0
6693               do l=1,3
6694                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6695               enddo
6696               Ax(k,j,iii)=Axk
6697             enddo
6698             expfac=0.0D0
6699             do k=1,3
6700               expfac=expfac+Ax(k,j,iii)*z(k)
6701             enddo
6702             contr(j,iii)=expfac
6703           enddo ! j
6704
6705         enddo ! iii
6706
6707         x(3)=x3
6708 C As in the case of ebend, we want to avoid underflows in exponentiation and
6709 C subsequent NaNs and INFs in energy calculation.
6710 C Find the largest exponent
6711         emin=contr(1,-1)
6712         do iii=-1,1
6713           do j=1,nlobit
6714             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6715           enddo
6716         enddo
6717         emin=0.5D0*emin
6718 cd      print *,'it=',it,' emin=',emin
6719
6720 C Compute the contribution to SC energy and derivatives
6721         do iii=-1,1
6722
6723           do j=1,nlobit
6724 #ifdef OSF
6725             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6726             if(adexp.ne.adexp) adexp=1.0
6727             expfac=dexp(adexp)
6728 #else
6729             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6730 #endif
6731 cd          print *,'j=',j,' expfac=',expfac
6732             escloc_i=escloc_i+expfac
6733             do k=1,3
6734               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6735             enddo
6736             if (mixed) then
6737               do k=1,3,2
6738                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6739      &            +gaussc(k,2,j,it))*expfac
6740               enddo
6741             endif
6742           enddo
6743
6744         enddo ! iii
6745
6746         dersc(1)=dersc(1)/cos(theti)**2
6747         ddersc(1)=ddersc(1)/cos(theti)**2
6748         ddersc(3)=ddersc(3)
6749
6750         escloci=-(dlog(escloc_i)-emin)
6751         do j=1,3
6752           dersc(j)=dersc(j)/escloc_i
6753         enddo
6754         if (mixed) then
6755           do j=1,3,2
6756             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6757           enddo
6758         endif
6759       return
6760       end
6761 C------------------------------------------------------------------------------
6762       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6763       implicit real*8 (a-h,o-z)
6764       include 'DIMENSIONS'
6765       include 'COMMON.GEO'
6766       include 'COMMON.LOCAL'
6767       include 'COMMON.IOUNITS'
6768       common /sccalc/ time11,time12,time112,theti,it,nlobit
6769       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6770       double precision contr(maxlob)
6771       logical mixed
6772
6773       escloc_i=0.0D0
6774
6775       do j=1,3
6776         dersc(j)=0.0D0
6777       enddo
6778
6779       do j=1,nlobit
6780         do k=1,2
6781           z(k)=x(k)-censc(k,j,it)
6782         enddo
6783         z(3)=dwapi
6784         do k=1,3
6785           Axk=0.0D0
6786           do l=1,3
6787             Axk=Axk+gaussc(l,k,j,it)*z(l)
6788           enddo
6789           Ax(k,j)=Axk
6790         enddo
6791         expfac=0.0D0
6792         do k=1,3
6793           expfac=expfac+Ax(k,j)*z(k)
6794         enddo
6795         contr(j)=expfac
6796       enddo ! j
6797
6798 C As in the case of ebend, we want to avoid underflows in exponentiation and
6799 C subsequent NaNs and INFs in energy calculation.
6800 C Find the largest exponent
6801       emin=contr(1)
6802       do j=1,nlobit
6803         if (emin.gt.contr(j)) emin=contr(j)
6804       enddo
6805       emin=0.5D0*emin
6806
6807 C Compute the contribution to SC energy and derivatives
6808
6809       dersc12=0.0d0
6810       do j=1,nlobit
6811         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6812         escloc_i=escloc_i+expfac
6813         do k=1,2
6814           dersc(k)=dersc(k)+Ax(k,j)*expfac
6815         enddo
6816         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6817      &            +gaussc(1,2,j,it))*expfac
6818         dersc(3)=0.0d0
6819       enddo
6820
6821       dersc(1)=dersc(1)/cos(theti)**2
6822       dersc12=dersc12/cos(theti)**2
6823       escloci=-(dlog(escloc_i)-emin)
6824       do j=1,2
6825         dersc(j)=dersc(j)/escloc_i
6826       enddo
6827       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6828       return
6829       end
6830 #else
6831 c----------------------------------------------------------------------------------
6832       subroutine esc(escloc)
6833 C Calculate the local energy of a side chain and its derivatives in the
6834 C corresponding virtual-bond valence angles THETA and the spherical angles
6835 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6836 C added by Urszula Kozlowska. 07/11/2007
6837 C
6838       implicit real*8 (a-h,o-z)
6839       include 'DIMENSIONS'
6840       include 'COMMON.GEO'
6841       include 'COMMON.LOCAL'
6842       include 'COMMON.VAR'
6843       include 'COMMON.SCROT'
6844       include 'COMMON.INTERACT'
6845       include 'COMMON.DERIV'
6846       include 'COMMON.CHAIN'
6847       include 'COMMON.IOUNITS'
6848       include 'COMMON.NAMES'
6849       include 'COMMON.FFIELD'
6850       include 'COMMON.CONTROL'
6851       include 'COMMON.VECTORS'
6852       double precision x_prime(3),y_prime(3),z_prime(3)
6853      &    , sumene,dsc_i,dp2_i,x(65),
6854      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6855      &    de_dxx,de_dyy,de_dzz,de_dt
6856       double precision s1_t,s1_6_t,s2_t,s2_6_t
6857       double precision
6858      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6859      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6860      & dt_dCi(3),dt_dCi1(3)
6861       common /sccalc/ time11,time12,time112,theti,it,nlobit
6862       delta=0.02d0*pi
6863       escloc=0.0D0
6864       do i=loc_start,loc_end
6865         if (itype(i).eq.ntyp1) cycle
6866         costtab(i+1) =dcos(theta(i+1))
6867         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6868         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6869         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6870         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6871         cosfac=dsqrt(cosfac2)
6872         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6873         sinfac=dsqrt(sinfac2)
6874         it=iabs(itype(i))
6875         if (it.eq.10) goto 1
6876 c
6877 C  Compute the axes of tghe local cartesian coordinates system; store in
6878 c   x_prime, y_prime and z_prime
6879 c
6880         do j=1,3
6881           x_prime(j) = 0.00
6882           y_prime(j) = 0.00
6883           z_prime(j) = 0.00
6884         enddo
6885 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6886 C     &   dc_norm(3,i+nres)
6887         do j = 1,3
6888           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6889           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6890         enddo
6891         do j = 1,3
6892           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6893         enddo
6894 c       write (2,*) "i",i
6895 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6896 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6897 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6898 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6899 c      & " xy",scalar(x_prime(1),y_prime(1)),
6900 c      & " xz",scalar(x_prime(1),z_prime(1)),
6901 c      & " yy",scalar(y_prime(1),y_prime(1)),
6902 c      & " yz",scalar(y_prime(1),z_prime(1)),
6903 c      & " zz",scalar(z_prime(1),z_prime(1))
6904 c
6905 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6906 C to local coordinate system. Store in xx, yy, zz.
6907 c
6908         xx=0.0d0
6909         yy=0.0d0
6910         zz=0.0d0
6911         do j = 1,3
6912           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6913           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6914           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6915         enddo
6916
6917         xxtab(i)=xx
6918         yytab(i)=yy
6919         zztab(i)=zz
6920 C
6921 C Compute the energy of the ith side cbain
6922 C
6923 c        write (2,*) "xx",xx," yy",yy," zz",zz
6924         it=iabs(itype(i))
6925         do j = 1,65
6926           x(j) = sc_parmin(j,it)
6927         enddo
6928 #ifdef CHECK_COORD
6929 Cc diagnostics - remove later
6930         xx1 = dcos(alph(2))
6931         yy1 = dsin(alph(2))*dcos(omeg(2))
6932         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6933         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6934      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6935      &    xx1,yy1,zz1
6936 C,"  --- ", xx_w,yy_w,zz_w
6937 c end diagnostics
6938 #endif
6939         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6940      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6941      &   + x(10)*yy*zz
6942         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6943      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6944      & + x(20)*yy*zz
6945         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6946      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6947      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6948      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6949      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6950      &  +x(40)*xx*yy*zz
6951         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6952      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6953      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6954      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6955      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6956      &  +x(60)*xx*yy*zz
6957         dsc_i   = 0.743d0+x(61)
6958         dp2_i   = 1.9d0+x(62)
6959         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6960      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6961         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6962      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6963         s1=(1+x(63))/(0.1d0 + dscp1)
6964         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6965         s2=(1+x(65))/(0.1d0 + dscp2)
6966         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6967         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6968      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6969 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6970 c     &   sumene4,
6971 c     &   dscp1,dscp2,sumene
6972 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6973         escloc = escloc + sumene
6974 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6975 c     & ,zz,xx,yy
6976 c#define DEBUG
6977 #ifdef DEBUG
6978 C
6979 C This section to check the numerical derivatives of the energy of ith side
6980 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6981 C #define DEBUG in the code to turn it on.
6982 C
6983         write (2,*) "sumene               =",sumene
6984         aincr=1.0d-7
6985         xxsave=xx
6986         xx=xx+aincr
6987         write (2,*) xx,yy,zz
6988         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6989         de_dxx_num=(sumenep-sumene)/aincr
6990         xx=xxsave
6991         write (2,*) "xx+ sumene from enesc=",sumenep
6992         yysave=yy
6993         yy=yy+aincr
6994         write (2,*) xx,yy,zz
6995         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6996         de_dyy_num=(sumenep-sumene)/aincr
6997         yy=yysave
6998         write (2,*) "yy+ sumene from enesc=",sumenep
6999         zzsave=zz
7000         zz=zz+aincr
7001         write (2,*) xx,yy,zz
7002         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7003         de_dzz_num=(sumenep-sumene)/aincr
7004         zz=zzsave
7005         write (2,*) "zz+ sumene from enesc=",sumenep
7006         costsave=cost2tab(i+1)
7007         sintsave=sint2tab(i+1)
7008         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7009         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7010         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7011         de_dt_num=(sumenep-sumene)/aincr
7012         write (2,*) " t+ sumene from enesc=",sumenep
7013         cost2tab(i+1)=costsave
7014         sint2tab(i+1)=sintsave
7015 C End of diagnostics section.
7016 #endif
7017 C
7018 C Compute the gradient of esc
7019 C
7020 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7021         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7022         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7023         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7024         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7025         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7026         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7027         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7028         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7029         pom1=(sumene3*sint2tab(i+1)+sumene1)
7030      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7031         pom2=(sumene4*cost2tab(i+1)+sumene2)
7032      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7033         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7034         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7035      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7036      &  +x(40)*yy*zz
7037         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7038         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7039      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7040      &  +x(60)*yy*zz
7041         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7042      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7043      &        +(pom1+pom2)*pom_dx
7044 #ifdef DEBUG
7045         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7046 #endif
7047 C
7048         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7049         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7050      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7051      &  +x(40)*xx*zz
7052         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7053         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7054      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7055      &  +x(59)*zz**2 +x(60)*xx*zz
7056         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7057      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7058      &        +(pom1-pom2)*pom_dy
7059 #ifdef DEBUG
7060         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7061 #endif
7062 C
7063         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7064      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7065      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7066      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7067      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7068      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7069      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7070      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7071 #ifdef DEBUG
7072         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7073 #endif
7074 C
7075         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7076      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7077      &  +pom1*pom_dt1+pom2*pom_dt2
7078 #ifdef DEBUG
7079         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7080 #endif
7081 c#undef DEBUG
7082 c
7083 C
7084        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7085        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7086        cosfac2xx=cosfac2*xx
7087        sinfac2yy=sinfac2*yy
7088        do k = 1,3
7089          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7090      &      vbld_inv(i+1)
7091          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7092      &      vbld_inv(i)
7093          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7094          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7095 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7096 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7097 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7098 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7099          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7100          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7101          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7102          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7103          dZZ_Ci1(k)=0.0d0
7104          dZZ_Ci(k)=0.0d0
7105          do j=1,3
7106            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7107      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7108            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7109      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7110          enddo
7111
7112          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7113          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7114          dZZ_XYZ(k)=vbld_inv(i+nres)*
7115      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7116 c
7117          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7118          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7119        enddo
7120
7121        do k=1,3
7122          dXX_Ctab(k,i)=dXX_Ci(k)
7123          dXX_C1tab(k,i)=dXX_Ci1(k)
7124          dYY_Ctab(k,i)=dYY_Ci(k)
7125          dYY_C1tab(k,i)=dYY_Ci1(k)
7126          dZZ_Ctab(k,i)=dZZ_Ci(k)
7127          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7128          dXX_XYZtab(k,i)=dXX_XYZ(k)
7129          dYY_XYZtab(k,i)=dYY_XYZ(k)
7130          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7131        enddo
7132
7133        do k = 1,3
7134 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7135 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7136 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7137 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7138 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7139 c     &    dt_dci(k)
7140 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7141 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7142          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7143      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7144          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7145      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7146          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7147      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7148        enddo
7149 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7150 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7151
7152 C to check gradient call subroutine check_grad
7153
7154     1 continue
7155       enddo
7156       return
7157       end
7158 c------------------------------------------------------------------------------
7159       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7160       implicit none
7161       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7162      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7163       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7164      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7165      &   + x(10)*yy*zz
7166       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7167      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7168      & + x(20)*yy*zz
7169       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7170      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7171      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7172      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7173      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7174      &  +x(40)*xx*yy*zz
7175       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7176      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7177      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7178      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7179      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7180      &  +x(60)*xx*yy*zz
7181       dsc_i   = 0.743d0+x(61)
7182       dp2_i   = 1.9d0+x(62)
7183       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7184      &          *(xx*cost2+yy*sint2))
7185       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7186      &          *(xx*cost2-yy*sint2))
7187       s1=(1+x(63))/(0.1d0 + dscp1)
7188       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7189       s2=(1+x(65))/(0.1d0 + dscp2)
7190       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7191       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7192      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7193       enesc=sumene
7194       return
7195       end
7196 #endif
7197 c------------------------------------------------------------------------------
7198       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7199 C
7200 C This procedure calculates two-body contact function g(rij) and its derivative:
7201 C
7202 C           eps0ij                                     !       x < -1
7203 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7204 C            0                                         !       x > 1
7205 C
7206 C where x=(rij-r0ij)/delta
7207 C
7208 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7209 C
7210       implicit none
7211       double precision rij,r0ij,eps0ij,fcont,fprimcont
7212       double precision x,x2,x4,delta
7213 c     delta=0.02D0*r0ij
7214 c      delta=0.2D0*r0ij
7215       x=(rij-r0ij)/delta
7216       if (x.lt.-1.0D0) then
7217         fcont=eps0ij
7218         fprimcont=0.0D0
7219       else if (x.le.1.0D0) then
7220         x2=x*x
7221         x4=x2*x2
7222         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7223         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7224       else
7225         fcont=0.0D0
7226         fprimcont=0.0D0
7227       endif
7228       return
7229       end
7230 c------------------------------------------------------------------------------
7231       subroutine splinthet(theti,delta,ss,ssder)
7232       implicit real*8 (a-h,o-z)
7233       include 'DIMENSIONS'
7234       include 'COMMON.VAR'
7235       include 'COMMON.GEO'
7236       thetup=pi-delta
7237       thetlow=delta
7238       if (theti.gt.pipol) then
7239         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7240       else
7241         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7242         ssder=-ssder
7243       endif
7244       return
7245       end
7246 c------------------------------------------------------------------------------
7247       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7248       implicit none
7249       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7250       double precision ksi,ksi2,ksi3,a1,a2,a3
7251       a1=fprim0*delta/(f1-f0)
7252       a2=3.0d0-2.0d0*a1
7253       a3=a1-2.0d0
7254       ksi=(x-x0)/delta
7255       ksi2=ksi*ksi
7256       ksi3=ksi2*ksi
7257       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7258       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7259       return
7260       end
7261 c------------------------------------------------------------------------------
7262       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7263       implicit none
7264       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7265       double precision ksi,ksi2,ksi3,a1,a2,a3
7266       ksi=(x-x0)/delta
7267       ksi2=ksi*ksi
7268       ksi3=ksi2*ksi
7269       a1=fprim0x*delta
7270       a2=3*(f1x-f0x)-2*fprim0x*delta
7271       a3=fprim0x*delta-2*(f1x-f0x)
7272       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7273       return
7274       end
7275 C-----------------------------------------------------------------------------
7276 #ifdef CRYST_TOR
7277 C-----------------------------------------------------------------------------
7278       subroutine etor(etors)
7279       implicit real*8 (a-h,o-z)
7280       include 'DIMENSIONS'
7281       include 'COMMON.VAR'
7282       include 'COMMON.GEO'
7283       include 'COMMON.LOCAL'
7284       include 'COMMON.TORSION'
7285       include 'COMMON.INTERACT'
7286       include 'COMMON.DERIV'
7287       include 'COMMON.CHAIN'
7288       include 'COMMON.NAMES'
7289       include 'COMMON.IOUNITS'
7290       include 'COMMON.FFIELD'
7291       include 'COMMON.TORCNSTR'
7292       include 'COMMON.CONTROL'
7293       logical lprn
7294 C Set lprn=.true. for debugging
7295       lprn=.false.
7296 c      lprn=.true.
7297       etors=0.0D0
7298       do i=iphi_start,iphi_end
7299       etors_ii=0.0D0
7300         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7301      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7302         itori=itortyp(itype(i-2))
7303         itori1=itortyp(itype(i-1))
7304         phii=phi(i)
7305         gloci=0.0D0
7306 C Proline-Proline pair is a special case...
7307         if (itori.eq.3 .and. itori1.eq.3) then
7308           if (phii.gt.-dwapi3) then
7309             cosphi=dcos(3*phii)
7310             fac=1.0D0/(1.0D0-cosphi)
7311             etorsi=v1(1,3,3)*fac
7312             etorsi=etorsi+etorsi
7313             etors=etors+etorsi-v1(1,3,3)
7314             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7315             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7316           endif
7317           do j=1,3
7318             v1ij=v1(j+1,itori,itori1)
7319             v2ij=v2(j+1,itori,itori1)
7320             cosphi=dcos(j*phii)
7321             sinphi=dsin(j*phii)
7322             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7323             if (energy_dec) etors_ii=etors_ii+
7324      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7325             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7326           enddo
7327         else
7328           do j=1,nterm_old
7329             v1ij=v1(j,itori,itori1)
7330             v2ij=v2(j,itori,itori1)
7331             cosphi=dcos(j*phii)
7332             sinphi=dsin(j*phii)
7333             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7334             if (energy_dec) etors_ii=etors_ii+
7335      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7336             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7337           enddo
7338         endif
7339         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7340              'etor',i,etors_ii
7341         if (lprn)
7342      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7343      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7344      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7345         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7346 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7347       enddo
7348       return
7349       end
7350 c------------------------------------------------------------------------------
7351       subroutine etor_d(etors_d)
7352       etors_d=0.0d0
7353       return
7354       end
7355 c----------------------------------------------------------------------------
7356 #else
7357       subroutine etor(etors)
7358       implicit real*8 (a-h,o-z)
7359       include 'DIMENSIONS'
7360       include 'COMMON.VAR'
7361       include 'COMMON.GEO'
7362       include 'COMMON.LOCAL'
7363       include 'COMMON.TORSION'
7364       include 'COMMON.INTERACT'
7365       include 'COMMON.DERIV'
7366       include 'COMMON.CHAIN'
7367       include 'COMMON.NAMES'
7368       include 'COMMON.IOUNITS'
7369       include 'COMMON.FFIELD'
7370       include 'COMMON.TORCNSTR'
7371       include 'COMMON.CONTROL'
7372       logical lprn
7373 C Set lprn=.true. for debugging
7374       lprn=.false.
7375 c     lprn=.true.
7376       etors=0.0D0
7377       do i=iphi_start,iphi_end
7378 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7379 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7380 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7381 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7382         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7383      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7384 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7385 C For introducing the NH3+ and COO- group please check the etor_d for reference
7386 C and guidance
7387         etors_ii=0.0D0
7388          if (iabs(itype(i)).eq.20) then
7389          iblock=2
7390          else
7391          iblock=1
7392          endif
7393         itori=itortyp(itype(i-2))
7394         itori1=itortyp(itype(i-1))
7395         phii=phi(i)
7396         gloci=0.0D0
7397 C Regular cosine and sine terms
7398         do j=1,nterm(itori,itori1,iblock)
7399           v1ij=v1(j,itori,itori1,iblock)
7400           v2ij=v2(j,itori,itori1,iblock)
7401           cosphi=dcos(j*phii)
7402           sinphi=dsin(j*phii)
7403           etors=etors+v1ij*cosphi+v2ij*sinphi
7404           if (energy_dec) etors_ii=etors_ii+
7405      &                v1ij*cosphi+v2ij*sinphi
7406           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7407         enddo
7408 C Lorentz terms
7409 C                         v1
7410 C  E = SUM ----------------------------------- - v1
7411 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7412 C
7413         cosphi=dcos(0.5d0*phii)
7414         sinphi=dsin(0.5d0*phii)
7415         do j=1,nlor(itori,itori1,iblock)
7416           vl1ij=vlor1(j,itori,itori1)
7417           vl2ij=vlor2(j,itori,itori1)
7418           vl3ij=vlor3(j,itori,itori1)
7419           pom=vl2ij*cosphi+vl3ij*sinphi
7420           pom1=1.0d0/(pom*pom+1.0d0)
7421           etors=etors+vl1ij*pom1
7422           if (energy_dec) etors_ii=etors_ii+
7423      &                vl1ij*pom1
7424           pom=-pom*pom1*pom1
7425           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7426         enddo
7427 C Subtract the constant term
7428         etors=etors-v0(itori,itori1,iblock)
7429           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7430      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7431         if (lprn)
7432      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7433      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7434      &  (v1(j,itori,itori1,iblock),j=1,6),
7435      &  (v2(j,itori,itori1,iblock),j=1,6)
7436         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7437 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7438       enddo
7439       return
7440       end
7441 c----------------------------------------------------------------------------
7442       subroutine etor_d(etors_d)
7443 C 6/23/01 Compute double torsional energy
7444       implicit real*8 (a-h,o-z)
7445       include 'DIMENSIONS'
7446       include 'COMMON.VAR'
7447       include 'COMMON.GEO'
7448       include 'COMMON.LOCAL'
7449       include 'COMMON.TORSION'
7450       include 'COMMON.INTERACT'
7451       include 'COMMON.DERIV'
7452       include 'COMMON.CHAIN'
7453       include 'COMMON.NAMES'
7454       include 'COMMON.IOUNITS'
7455       include 'COMMON.FFIELD'
7456       include 'COMMON.TORCNSTR'
7457       logical lprn
7458 C Set lprn=.true. for debugging
7459       lprn=.false.
7460 c     lprn=.true.
7461       etors_d=0.0D0
7462 c      write(iout,*) "a tu??"
7463       do i=iphid_start,iphid_end
7464 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7465 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7466 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7467 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7468 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7469          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7470      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7471      &  (itype(i+1).eq.ntyp1)) cycle
7472 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7473         itori=itortyp(itype(i-2))
7474         itori1=itortyp(itype(i-1))
7475         itori2=itortyp(itype(i))
7476         phii=phi(i)
7477         phii1=phi(i+1)
7478         gloci1=0.0D0
7479         gloci2=0.0D0
7480         iblock=1
7481         if (iabs(itype(i+1)).eq.20) iblock=2
7482 C Iblock=2 Proline type
7483 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7484 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7485 C        if (itype(i+1).eq.ntyp1) iblock=3
7486 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7487 C IS or IS NOT need for this
7488 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7489 C        is (itype(i-3).eq.ntyp1) ntblock=2
7490 C        ntblock is N-terminal blocking group
7491
7492 C Regular cosine and sine terms
7493         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7494 C Example of changes for NH3+ blocking group
7495 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7496 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7497           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7498           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7499           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7500           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7501           cosphi1=dcos(j*phii)
7502           sinphi1=dsin(j*phii)
7503           cosphi2=dcos(j*phii1)
7504           sinphi2=dsin(j*phii1)
7505           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7506      &     v2cij*cosphi2+v2sij*sinphi2
7507           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7508           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7509         enddo
7510         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7511           do l=1,k-1
7512             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7513             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7514             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7515             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7516             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7517             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7518             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7519             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7520             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7521      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7522             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7523      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7524             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7525      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7526           enddo
7527         enddo
7528         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7529         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7530       enddo
7531       return
7532       end
7533 #endif
7534 C----------------------------------------------------------------------------------
7535 C The rigorous attempt to derive energy function
7536       subroutine etor_kcc(etors)
7537       implicit real*8 (a-h,o-z)
7538       include 'DIMENSIONS'
7539       include 'COMMON.VAR'
7540       include 'COMMON.GEO'
7541       include 'COMMON.LOCAL'
7542       include 'COMMON.TORSION'
7543       include 'COMMON.INTERACT'
7544       include 'COMMON.DERIV'
7545       include 'COMMON.CHAIN'
7546       include 'COMMON.NAMES'
7547       include 'COMMON.IOUNITS'
7548       include 'COMMON.FFIELD'
7549       include 'COMMON.TORCNSTR'
7550       include 'COMMON.CONTROL'
7551       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7552       logical lprn
7553 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7554 C Set lprn=.true. for debugging
7555       lprn=energy_dec
7556 c     lprn=.true.
7557 C      print *,"wchodze kcc"
7558       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7559       etors=0.0D0
7560       do i=iphi_start,iphi_end
7561 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7562 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7563 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7564 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7565         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7566      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7567         itori=itortyp(itype(i-2))
7568         itori1=itortyp(itype(i-1))
7569         phii=phi(i)
7570         glocig=0.0D0
7571         glocit1=0.0d0
7572         glocit2=0.0d0
7573 C to avoid multiple devision by 2
7574 c        theti22=0.5d0*theta(i)
7575 C theta 12 is the theta_1 /2
7576 C theta 22 is theta_2 /2
7577 c        theti12=0.5d0*theta(i-1)
7578 C and appropriate sinus function
7579         sinthet1=dsin(theta(i-1))
7580         sinthet2=dsin(theta(i))
7581         costhet1=dcos(theta(i-1))
7582         costhet2=dcos(theta(i))
7583 C to speed up lets store its mutliplication
7584         sint1t2=sinthet2*sinthet1
7585         sint1t2n=1.0d0
7586 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7587 C +d_n*sin(n*gamma)) *
7588 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7589 C we have two sum 1) Non-Chebyshev which is with n and gamma
7590         nval=nterm_kcc_Tb(itori,itori1)
7591         c1(0)=0.0d0
7592         c2(0)=0.0d0
7593         c1(1)=1.0d0
7594         c2(1)=1.0d0
7595         do j=2,nval
7596           c1(j)=c1(j-1)*costhet1
7597           c2(j)=c2(j-1)*costhet2
7598         enddo
7599         etori=0.0d0
7600         do j=1,nterm_kcc(itori,itori1)
7601           cosphi=dcos(j*phii)
7602           sinphi=dsin(j*phii)
7603           sint1t2n1=sint1t2n
7604           sint1t2n=sint1t2n*sint1t2
7605           sumvalc=0.0d0
7606           gradvalct1=0.0d0
7607           gradvalct2=0.0d0
7608           do k=1,nval
7609             do l=1,nval
7610               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7611               gradvalct1=gradvalct1+
7612      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7613               gradvalct2=gradvalct2+
7614      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7615             enddo
7616           enddo
7617           gradvalct1=-gradvalct1*sinthet1
7618           gradvalct2=-gradvalct2*sinthet2
7619           sumvals=0.0d0
7620           gradvalst1=0.0d0
7621           gradvalst2=0.0d0
7622           do k=1,nval
7623             do l=1,nval
7624               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7625               gradvalst1=gradvalst1+
7626      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7627               gradvalst2=gradvalst2+
7628      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7629             enddo
7630           enddo
7631           gradvalst1=-gradvalst1*sinthet1
7632           gradvalst2=-gradvalst2*sinthet2
7633           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7634           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7635 C glocig is the gradient local i site in gamma
7636           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7637 C now gradient over theta_1
7638           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7639      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7640           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7641      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7642         enddo ! j
7643         etors=etors+etori
7644 C derivative over gamma
7645         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7646 C derivative over theta1
7647         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7648 C now derivative over theta2
7649         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7650         if (lprn) then
7651           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7652      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7653           write (iout,*) "c1",(c1(k),k=0,nval),
7654      &    " c2",(c2(k),k=0,nval)
7655         endif
7656       enddo
7657       return
7658       end
7659 c---------------------------------------------------------------------------------------------
7660       subroutine etor_constr(edihcnstr)
7661       implicit real*8 (a-h,o-z)
7662       include 'DIMENSIONS'
7663       include 'COMMON.VAR'
7664       include 'COMMON.GEO'
7665       include 'COMMON.LOCAL'
7666       include 'COMMON.TORSION'
7667       include 'COMMON.INTERACT'
7668       include 'COMMON.DERIV'
7669       include 'COMMON.CHAIN'
7670       include 'COMMON.NAMES'
7671       include 'COMMON.IOUNITS'
7672       include 'COMMON.FFIELD'
7673       include 'COMMON.TORCNSTR'
7674       include 'COMMON.BOUNDS'
7675       include 'COMMON.CONTROL'
7676 ! 6/20/98 - dihedral angle constraints
7677       edihcnstr=0.0d0
7678 c      do i=1,ndih_constr
7679       if (raw_psipred) then
7680         do i=idihconstr_start,idihconstr_end
7681           itori=idih_constr(i)
7682           phii=phi(itori)
7683           gaudih_i=vpsipred(1,i)
7684           gauder_i=0.0d0
7685           do j=1,2
7686             s = sdihed(j,i)
7687             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7688             dexpcos_i=dexp(-cos_i*cos_i)
7689             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7690             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7691      &            *cos_i*dexpcos_i/s**2
7692           enddo
7693           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7694           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7695           if (energy_dec)
7696      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7697      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7698      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7699      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7700      &     -wdihc*dlog(gaudih_i)
7701         enddo
7702       else
7703
7704       do i=idihconstr_start,idihconstr_end
7705         itori=idih_constr(i)
7706         phii=phi(itori)
7707         difi=pinorm(phii-phi0(i))
7708         if (difi.gt.drange(i)) then
7709           difi=difi-drange(i)
7710           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7711           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7712         else if (difi.lt.-drange(i)) then
7713           difi=difi+drange(i)
7714           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7715           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7716         else
7717           difi=0.0
7718         endif
7719       enddo
7720
7721       endif
7722
7723       return
7724       end
7725 c----------------------------------------------------------------------------
7726 C The rigorous attempt to derive energy function
7727       subroutine ebend_kcc(etheta)
7728
7729       implicit real*8 (a-h,o-z)
7730       include 'DIMENSIONS'
7731       include 'COMMON.VAR'
7732       include 'COMMON.GEO'
7733       include 'COMMON.LOCAL'
7734       include 'COMMON.TORSION'
7735       include 'COMMON.INTERACT'
7736       include 'COMMON.DERIV'
7737       include 'COMMON.CHAIN'
7738       include 'COMMON.NAMES'
7739       include 'COMMON.IOUNITS'
7740       include 'COMMON.FFIELD'
7741       include 'COMMON.TORCNSTR'
7742       include 'COMMON.CONTROL'
7743       logical lprn
7744       double precision thybt1(maxang_kcc)
7745 C Set lprn=.true. for debugging
7746       lprn=energy_dec
7747 c     lprn=.true.
7748 C      print *,"wchodze kcc"
7749       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7750       etheta=0.0D0
7751       do i=ithet_start,ithet_end
7752 c        print *,i,itype(i-1),itype(i),itype(i-2)
7753         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7754      &  .or.itype(i).eq.ntyp1) cycle
7755         iti=iabs(itortyp(itype(i-1)))
7756         sinthet=dsin(theta(i))
7757         costhet=dcos(theta(i))
7758         do j=1,nbend_kcc_Tb(iti)
7759           thybt1(j)=v1bend_chyb(j,iti)
7760         enddo
7761         sumth1thyb=v1bend_chyb(0,iti)+
7762      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7763         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7764      &    sumth1thyb
7765         ihelp=nbend_kcc_Tb(iti)-1
7766         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7767         etheta=etheta+sumth1thyb
7768 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7769         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7770       enddo
7771       return
7772       end
7773 c-------------------------------------------------------------------------------------
7774       subroutine etheta_constr(ethetacnstr)
7775
7776       implicit real*8 (a-h,o-z)
7777       include 'DIMENSIONS'
7778       include 'COMMON.VAR'
7779       include 'COMMON.GEO'
7780       include 'COMMON.LOCAL'
7781       include 'COMMON.TORSION'
7782       include 'COMMON.INTERACT'
7783       include 'COMMON.DERIV'
7784       include 'COMMON.CHAIN'
7785       include 'COMMON.NAMES'
7786       include 'COMMON.IOUNITS'
7787       include 'COMMON.FFIELD'
7788       include 'COMMON.TORCNSTR'
7789       include 'COMMON.CONTROL'
7790       ethetacnstr=0.0d0
7791 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7792       do i=ithetaconstr_start,ithetaconstr_end
7793         itheta=itheta_constr(i)
7794         thetiii=theta(itheta)
7795         difi=pinorm(thetiii-theta_constr0(i))
7796         if (difi.gt.theta_drange(i)) then
7797           difi=difi-theta_drange(i)
7798           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7799           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7800      &    +for_thet_constr(i)*difi**3
7801         else if (difi.lt.-drange(i)) then
7802           difi=difi+drange(i)
7803           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7804           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7805      &    +for_thet_constr(i)*difi**3
7806         else
7807           difi=0.0
7808         endif
7809        if (energy_dec) then
7810         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7811      &    i,itheta,rad2deg*thetiii,
7812      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7813      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7814      &    gloc(itheta+nphi-2,icg)
7815         endif
7816       enddo
7817       return
7818       end
7819 c------------------------------------------------------------------------------
7820       subroutine eback_sc_corr(esccor)
7821 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7822 c        conformational states; temporarily implemented as differences
7823 c        between UNRES torsional potentials (dependent on three types of
7824 c        residues) and the torsional potentials dependent on all 20 types
7825 c        of residues computed from AM1  energy surfaces of terminally-blocked
7826 c        amino-acid residues.
7827       implicit real*8 (a-h,o-z)
7828       include 'DIMENSIONS'
7829       include 'COMMON.VAR'
7830       include 'COMMON.GEO'
7831       include 'COMMON.LOCAL'
7832       include 'COMMON.TORSION'
7833       include 'COMMON.SCCOR'
7834       include 'COMMON.INTERACT'
7835       include 'COMMON.DERIV'
7836       include 'COMMON.CHAIN'
7837       include 'COMMON.NAMES'
7838       include 'COMMON.IOUNITS'
7839       include 'COMMON.FFIELD'
7840       include 'COMMON.CONTROL'
7841       logical lprn
7842 C Set lprn=.true. for debugging
7843       lprn=.false.
7844 c      lprn=.true.
7845 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7846       esccor=0.0D0
7847       do i=itau_start,itau_end
7848         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7849         esccor_ii=0.0D0
7850         isccori=isccortyp(itype(i-2))
7851         isccori1=isccortyp(itype(i-1))
7852 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7853         phii=phi(i)
7854         do intertyp=1,3 !intertyp
7855 cc Added 09 May 2012 (Adasko)
7856 cc  Intertyp means interaction type of backbone mainchain correlation:
7857 c   1 = SC...Ca...Ca...Ca
7858 c   2 = Ca...Ca...Ca...SC
7859 c   3 = SC...Ca...Ca...SCi
7860         gloci=0.0D0
7861         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7862      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7863      &      (itype(i-1).eq.ntyp1)))
7864      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7865      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7866      &     .or.(itype(i).eq.ntyp1)))
7867      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7868      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7869      &      (itype(i-3).eq.ntyp1)))) cycle
7870         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7871         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7872      & cycle
7873        do j=1,nterm_sccor(isccori,isccori1)
7874           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7875           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7876           cosphi=dcos(j*tauangle(intertyp,i))
7877           sinphi=dsin(j*tauangle(intertyp,i))
7878           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7879           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7880         enddo
7881 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7882         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7883         if (lprn)
7884      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7885      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7886      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7887      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7888         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7889        enddo !intertyp
7890       enddo
7891
7892       return
7893       end
7894 c----------------------------------------------------------------------------
7895       subroutine multibody(ecorr)
7896 C This subroutine calculates multi-body contributions to energy following
7897 C the idea of Skolnick et al. If side chains I and J make a contact and
7898 C at the same time side chains I+1 and J+1 make a contact, an extra
7899 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7900       implicit real*8 (a-h,o-z)
7901       include 'DIMENSIONS'
7902       include 'COMMON.IOUNITS'
7903       include 'COMMON.DERIV'
7904       include 'COMMON.INTERACT'
7905       include 'COMMON.CONTACTS'
7906       double precision gx(3),gx1(3)
7907       logical lprn
7908
7909 C Set lprn=.true. for debugging
7910       lprn=.false.
7911
7912       if (lprn) then
7913         write (iout,'(a)') 'Contact function values:'
7914         do i=nnt,nct-2
7915           write (iout,'(i2,20(1x,i2,f10.5))')
7916      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7917         enddo
7918       endif
7919       ecorr=0.0D0
7920       do i=nnt,nct
7921         do j=1,3
7922           gradcorr(j,i)=0.0D0
7923           gradxorr(j,i)=0.0D0
7924         enddo
7925       enddo
7926       do i=nnt,nct-2
7927
7928         DO ISHIFT = 3,4
7929
7930         i1=i+ishift
7931         num_conti=num_cont(i)
7932         num_conti1=num_cont(i1)
7933         do jj=1,num_conti
7934           j=jcont(jj,i)
7935           do kk=1,num_conti1
7936             j1=jcont(kk,i1)
7937             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7938 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7939 cd   &                   ' ishift=',ishift
7940 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7941 C The system gains extra energy.
7942               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7943             endif   ! j1==j+-ishift
7944           enddo     ! kk
7945         enddo       ! jj
7946
7947         ENDDO ! ISHIFT
7948
7949       enddo         ! i
7950       return
7951       end
7952 c------------------------------------------------------------------------------
7953       double precision function esccorr(i,j,k,l,jj,kk)
7954       implicit real*8 (a-h,o-z)
7955       include 'DIMENSIONS'
7956       include 'COMMON.IOUNITS'
7957       include 'COMMON.DERIV'
7958       include 'COMMON.INTERACT'
7959       include 'COMMON.CONTACTS'
7960       include 'COMMON.SHIELD'
7961       double precision gx(3),gx1(3)
7962       logical lprn
7963       lprn=.false.
7964       eij=facont(jj,i)
7965       ekl=facont(kk,k)
7966 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7967 C Calculate the multi-body contribution to energy.
7968 C Calculate multi-body contributions to the gradient.
7969 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7970 cd   & k,l,(gacont(m,kk,k),m=1,3)
7971       do m=1,3
7972         gx(m) =ekl*gacont(m,jj,i)
7973         gx1(m)=eij*gacont(m,kk,k)
7974         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7975         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7976         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7977         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7978       enddo
7979       do m=i,j-1
7980         do ll=1,3
7981           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7982         enddo
7983       enddo
7984       do m=k,l-1
7985         do ll=1,3
7986           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7987         enddo
7988       enddo
7989       esccorr=-eij*ekl
7990       return
7991       end
7992 c------------------------------------------------------------------------------
7993       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7994 C This subroutine calculates multi-body contributions to hydrogen-bonding
7995       implicit real*8 (a-h,o-z)
7996       include 'DIMENSIONS'
7997       include 'COMMON.IOUNITS'
7998 #ifdef MPI
7999       include "mpif.h"
8000       parameter (max_cont=maxconts)
8001       parameter (max_dim=26)
8002       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8003       double precision zapas(max_dim,maxconts,max_fg_procs),
8004      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8005       common /przechowalnia/ zapas
8006       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8007      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8008 #endif
8009       include 'COMMON.SETUP'
8010       include 'COMMON.FFIELD'
8011       include 'COMMON.DERIV'
8012       include 'COMMON.INTERACT'
8013       include 'COMMON.CONTACTS'
8014       include 'COMMON.CONTROL'
8015       include 'COMMON.LOCAL'
8016       double precision gx(3),gx1(3),time00
8017       logical lprn,ldone
8018
8019 C Set lprn=.true. for debugging
8020       lprn=.false.
8021 #ifdef MPI
8022       n_corr=0
8023       n_corr1=0
8024       if (nfgtasks.le.1) goto 30
8025       if (lprn) then
8026         write (iout,'(a)') 'Contact function values before RECEIVE:'
8027         do i=nnt,nct-2
8028           write (iout,'(2i3,50(1x,i2,f5.2))')
8029      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8030      &    j=1,num_cont_hb(i))
8031         enddo
8032         call flush(iout)
8033       endif
8034       do i=1,ntask_cont_from
8035         ncont_recv(i)=0
8036       enddo
8037       do i=1,ntask_cont_to
8038         ncont_sent(i)=0
8039       enddo
8040 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8041 c     & ntask_cont_to
8042 C Make the list of contacts to send to send to other procesors
8043 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8044 c      call flush(iout)
8045       do i=iturn3_start,iturn3_end
8046 c        write (iout,*) "make contact list turn3",i," num_cont",
8047 c     &    num_cont_hb(i)
8048         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8049       enddo
8050       do i=iturn4_start,iturn4_end
8051 c        write (iout,*) "make contact list turn4",i," num_cont",
8052 c     &   num_cont_hb(i)
8053         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8054       enddo
8055       do ii=1,nat_sent
8056         i=iat_sent(ii)
8057 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8058 c     &    num_cont_hb(i)
8059         do j=1,num_cont_hb(i)
8060         do k=1,4
8061           jjc=jcont_hb(j,i)
8062           iproc=iint_sent_local(k,jjc,ii)
8063 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8064           if (iproc.gt.0) then
8065             ncont_sent(iproc)=ncont_sent(iproc)+1
8066             nn=ncont_sent(iproc)
8067             zapas(1,nn,iproc)=i
8068             zapas(2,nn,iproc)=jjc
8069             zapas(3,nn,iproc)=facont_hb(j,i)
8070             zapas(4,nn,iproc)=ees0p(j,i)
8071             zapas(5,nn,iproc)=ees0m(j,i)
8072             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8073             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8074             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8075             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8076             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8077             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8078             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8079             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8080             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8081             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8082             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8083             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8084             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8085             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8086             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8087             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8088             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8089             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8090             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8091             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8092             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8093           endif
8094         enddo
8095         enddo
8096       enddo
8097       if (lprn) then
8098       write (iout,*)
8099      &  "Numbers of contacts to be sent to other processors",
8100      &  (ncont_sent(i),i=1,ntask_cont_to)
8101       write (iout,*) "Contacts sent"
8102       do ii=1,ntask_cont_to
8103         nn=ncont_sent(ii)
8104         iproc=itask_cont_to(ii)
8105         write (iout,*) nn," contacts to processor",iproc,
8106      &   " of CONT_TO_COMM group"
8107         do i=1,nn
8108           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8109         enddo
8110       enddo
8111       call flush(iout)
8112       endif
8113       CorrelType=477
8114       CorrelID=fg_rank+1
8115       CorrelType1=478
8116       CorrelID1=nfgtasks+fg_rank+1
8117       ireq=0
8118 C Receive the numbers of needed contacts from other processors
8119       do ii=1,ntask_cont_from
8120         iproc=itask_cont_from(ii)
8121         ireq=ireq+1
8122         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8123      &    FG_COMM,req(ireq),IERR)
8124       enddo
8125 c      write (iout,*) "IRECV ended"
8126 c      call flush(iout)
8127 C Send the number of contacts needed by other processors
8128       do ii=1,ntask_cont_to
8129         iproc=itask_cont_to(ii)
8130         ireq=ireq+1
8131         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8132      &    FG_COMM,req(ireq),IERR)
8133       enddo
8134 c      write (iout,*) "ISEND ended"
8135 c      write (iout,*) "number of requests (nn)",ireq
8136 c      call flush(iout)
8137       if (ireq.gt.0)
8138      &  call MPI_Waitall(ireq,req,status_array,ierr)
8139 c      write (iout,*)
8140 c     &  "Numbers of contacts to be received from other processors",
8141 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8142 c      call flush(iout)
8143 C Receive contacts
8144       ireq=0
8145       do ii=1,ntask_cont_from
8146         iproc=itask_cont_from(ii)
8147         nn=ncont_recv(ii)
8148 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8149 c     &   " of CONT_TO_COMM group"
8150 c        call flush(iout)
8151         if (nn.gt.0) then
8152           ireq=ireq+1
8153           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8154      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8155 c          write (iout,*) "ireq,req",ireq,req(ireq)
8156         endif
8157       enddo
8158 C Send the contacts to processors that need them
8159       do ii=1,ntask_cont_to
8160         iproc=itask_cont_to(ii)
8161         nn=ncont_sent(ii)
8162 c        write (iout,*) nn," contacts to processor",iproc,
8163 c     &   " of CONT_TO_COMM group"
8164         if (nn.gt.0) then
8165           ireq=ireq+1
8166           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8167      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8168 c          write (iout,*) "ireq,req",ireq,req(ireq)
8169 c          do i=1,nn
8170 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8171 c          enddo
8172         endif
8173       enddo
8174 c      write (iout,*) "number of requests (contacts)",ireq
8175 c      write (iout,*) "req",(req(i),i=1,4)
8176 c      call flush(iout)
8177       if (ireq.gt.0)
8178      & call MPI_Waitall(ireq,req,status_array,ierr)
8179       do iii=1,ntask_cont_from
8180         iproc=itask_cont_from(iii)
8181         nn=ncont_recv(iii)
8182         if (lprn) then
8183         write (iout,*) "Received",nn," contacts from processor",iproc,
8184      &   " of CONT_FROM_COMM group"
8185         call flush(iout)
8186         do i=1,nn
8187           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8188         enddo
8189         call flush(iout)
8190         endif
8191         do i=1,nn
8192           ii=zapas_recv(1,i,iii)
8193 c Flag the received contacts to prevent double-counting
8194           jj=-zapas_recv(2,i,iii)
8195 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8196 c          call flush(iout)
8197           nnn=num_cont_hb(ii)+1
8198           num_cont_hb(ii)=nnn
8199           jcont_hb(nnn,ii)=jj
8200           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8201           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8202           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8203           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8204           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8205           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8206           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8207           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8208           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8209           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8210           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8211           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8212           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8213           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8214           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8215           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8216           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8217           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8218           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8219           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8220           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8221           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8222           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8223           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8224         enddo
8225       enddo
8226       if (lprn) then
8227         write (iout,'(a)') 'Contact function values after receive:'
8228         do i=nnt,nct-2
8229           write (iout,'(2i3,50(1x,i3,f5.2))')
8230      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8231      &    j=1,num_cont_hb(i))
8232         enddo
8233         call flush(iout)
8234       endif
8235    30 continue
8236 #endif
8237       if (lprn) then
8238         write (iout,'(a)') 'Contact function values:'
8239         do i=nnt,nct-2
8240           write (iout,'(2i3,50(1x,i3,f5.2))')
8241      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8242      &    j=1,num_cont_hb(i))
8243         enddo
8244         call flush(iout)
8245       endif
8246       ecorr=0.0D0
8247 C Remove the loop below after debugging !!!
8248       do i=nnt,nct
8249         do j=1,3
8250           gradcorr(j,i)=0.0D0
8251           gradxorr(j,i)=0.0D0
8252         enddo
8253       enddo
8254 C Calculate the local-electrostatic correlation terms
8255       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8256         i1=i+1
8257         num_conti=num_cont_hb(i)
8258         num_conti1=num_cont_hb(i+1)
8259         do jj=1,num_conti
8260           j=jcont_hb(jj,i)
8261           jp=iabs(j)
8262           do kk=1,num_conti1
8263             j1=jcont_hb(kk,i1)
8264             jp1=iabs(j1)
8265 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8266 c     &         ' jj=',jj,' kk=',kk
8267 c            call flush(iout)
8268             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8269      &          .or. j.lt.0 .and. j1.gt.0) .and.
8270      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8271 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8272 C The system gains extra energy.
8273               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8274               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8275      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8276               n_corr=n_corr+1
8277             else if (j1.eq.j) then
8278 C Contacts I-J and I-(J+1) occur simultaneously.
8279 C The system loses extra energy.
8280 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8281             endif
8282           enddo ! kk
8283           do kk=1,num_conti
8284             j1=jcont_hb(kk,i)
8285 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8286 c    &         ' jj=',jj,' kk=',kk
8287             if (j1.eq.j+1) then
8288 C Contacts I-J and (I+1)-J occur simultaneously.
8289 C The system loses extra energy.
8290 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8291             endif ! j1==j+1
8292           enddo ! kk
8293         enddo ! jj
8294       enddo ! i
8295       return
8296       end
8297 c------------------------------------------------------------------------------
8298       subroutine add_hb_contact(ii,jj,itask)
8299       implicit real*8 (a-h,o-z)
8300       include "DIMENSIONS"
8301       include "COMMON.IOUNITS"
8302       integer max_cont
8303       integer max_dim
8304       parameter (max_cont=maxconts)
8305       parameter (max_dim=26)
8306       include "COMMON.CONTACTS"
8307       double precision zapas(max_dim,maxconts,max_fg_procs),
8308      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8309       common /przechowalnia/ zapas
8310       integer i,j,ii,jj,iproc,itask(4),nn
8311 c      write (iout,*) "itask",itask
8312       do i=1,2
8313         iproc=itask(i)
8314         if (iproc.gt.0) then
8315           do j=1,num_cont_hb(ii)
8316             jjc=jcont_hb(j,ii)
8317 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8318             if (jjc.eq.jj) then
8319               ncont_sent(iproc)=ncont_sent(iproc)+1
8320               nn=ncont_sent(iproc)
8321               zapas(1,nn,iproc)=ii
8322               zapas(2,nn,iproc)=jjc
8323               zapas(3,nn,iproc)=facont_hb(j,ii)
8324               zapas(4,nn,iproc)=ees0p(j,ii)
8325               zapas(5,nn,iproc)=ees0m(j,ii)
8326               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8327               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8328               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8329               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8330               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8331               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8332               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8333               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8334               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8335               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8336               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8337               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8338               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8339               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8340               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8341               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8342               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8343               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8344               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8345               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8346               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8347               exit
8348             endif
8349           enddo
8350         endif
8351       enddo
8352       return
8353       end
8354 c------------------------------------------------------------------------------
8355       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8356      &  n_corr1)
8357 C This subroutine calculates multi-body contributions to hydrogen-bonding
8358       implicit real*8 (a-h,o-z)
8359       include 'DIMENSIONS'
8360       include 'COMMON.IOUNITS'
8361 #ifdef MPI
8362       include "mpif.h"
8363       parameter (max_cont=maxconts)
8364       parameter (max_dim=70)
8365       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8366       double precision zapas(max_dim,maxconts,max_fg_procs),
8367      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8368       common /przechowalnia/ zapas
8369       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8370      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8371 #endif
8372       include 'COMMON.SETUP'
8373       include 'COMMON.FFIELD'
8374       include 'COMMON.DERIV'
8375       include 'COMMON.LOCAL'
8376       include 'COMMON.INTERACT'
8377       include 'COMMON.CONTACTS'
8378       include 'COMMON.CHAIN'
8379       include 'COMMON.CONTROL'
8380       include 'COMMON.SHIELD'
8381       double precision gx(3),gx1(3)
8382       integer num_cont_hb_old(maxres)
8383       logical lprn,ldone
8384       double precision eello4,eello5,eelo6,eello_turn6
8385       external eello4,eello5,eello6,eello_turn6
8386 C Set lprn=.true. for debugging
8387       lprn=.false.
8388       eturn6=0.0d0
8389 #ifdef MPI
8390       do i=1,nres
8391         num_cont_hb_old(i)=num_cont_hb(i)
8392       enddo
8393       n_corr=0
8394       n_corr1=0
8395       if (nfgtasks.le.1) goto 30
8396       if (lprn) then
8397         write (iout,'(a)') 'Contact function values before RECEIVE:'
8398         do i=nnt,nct-2
8399           write (iout,'(2i3,50(1x,i2,f5.2))')
8400      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8401      &    j=1,num_cont_hb(i))
8402         enddo
8403       endif
8404       do i=1,ntask_cont_from
8405         ncont_recv(i)=0
8406       enddo
8407       do i=1,ntask_cont_to
8408         ncont_sent(i)=0
8409       enddo
8410 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8411 c     & ntask_cont_to
8412 C Make the list of contacts to send to send to other procesors
8413       do i=iturn3_start,iturn3_end
8414 c        write (iout,*) "make contact list turn3",i," num_cont",
8415 c     &    num_cont_hb(i)
8416         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8417       enddo
8418       do i=iturn4_start,iturn4_end
8419 c        write (iout,*) "make contact list turn4",i," num_cont",
8420 c     &   num_cont_hb(i)
8421         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8422       enddo
8423       do ii=1,nat_sent
8424         i=iat_sent(ii)
8425 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8426 c     &    num_cont_hb(i)
8427         do j=1,num_cont_hb(i)
8428         do k=1,4
8429           jjc=jcont_hb(j,i)
8430           iproc=iint_sent_local(k,jjc,ii)
8431 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8432           if (iproc.ne.0) then
8433             ncont_sent(iproc)=ncont_sent(iproc)+1
8434             nn=ncont_sent(iproc)
8435             zapas(1,nn,iproc)=i
8436             zapas(2,nn,iproc)=jjc
8437             zapas(3,nn,iproc)=d_cont(j,i)
8438             ind=3
8439             do kk=1,3
8440               ind=ind+1
8441               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8442             enddo
8443             do kk=1,2
8444               do ll=1,2
8445                 ind=ind+1
8446                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8447               enddo
8448             enddo
8449             do jj=1,5
8450               do kk=1,3
8451                 do ll=1,2
8452                   do mm=1,2
8453                     ind=ind+1
8454                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8455                   enddo
8456                 enddo
8457               enddo
8458             enddo
8459           endif
8460         enddo
8461         enddo
8462       enddo
8463       if (lprn) then
8464       write (iout,*)
8465      &  "Numbers of contacts to be sent to other processors",
8466      &  (ncont_sent(i),i=1,ntask_cont_to)
8467       write (iout,*) "Contacts sent"
8468       do ii=1,ntask_cont_to
8469         nn=ncont_sent(ii)
8470         iproc=itask_cont_to(ii)
8471         write (iout,*) nn," contacts to processor",iproc,
8472      &   " of CONT_TO_COMM group"
8473         do i=1,nn
8474           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8475         enddo
8476       enddo
8477       call flush(iout)
8478       endif
8479       CorrelType=477
8480       CorrelID=fg_rank+1
8481       CorrelType1=478
8482       CorrelID1=nfgtasks+fg_rank+1
8483       ireq=0
8484 C Receive the numbers of needed contacts from other processors
8485       do ii=1,ntask_cont_from
8486         iproc=itask_cont_from(ii)
8487         ireq=ireq+1
8488         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8489      &    FG_COMM,req(ireq),IERR)
8490       enddo
8491 c      write (iout,*) "IRECV ended"
8492 c      call flush(iout)
8493 C Send the number of contacts needed by other processors
8494       do ii=1,ntask_cont_to
8495         iproc=itask_cont_to(ii)
8496         ireq=ireq+1
8497         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8498      &    FG_COMM,req(ireq),IERR)
8499       enddo
8500 c      write (iout,*) "ISEND ended"
8501 c      write (iout,*) "number of requests (nn)",ireq
8502 c      call flush(iout)
8503       if (ireq.gt.0)
8504      &  call MPI_Waitall(ireq,req,status_array,ierr)
8505 c      write (iout,*)
8506 c     &  "Numbers of contacts to be received from other processors",
8507 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8508 c      call flush(iout)
8509 C Receive contacts
8510       ireq=0
8511       do ii=1,ntask_cont_from
8512         iproc=itask_cont_from(ii)
8513         nn=ncont_recv(ii)
8514 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8515 c     &   " of CONT_TO_COMM group"
8516 c        call flush(iout)
8517         if (nn.gt.0) then
8518           ireq=ireq+1
8519           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8520      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8521 c          write (iout,*) "ireq,req",ireq,req(ireq)
8522         endif
8523       enddo
8524 C Send the contacts to processors that need them
8525       do ii=1,ntask_cont_to
8526         iproc=itask_cont_to(ii)
8527         nn=ncont_sent(ii)
8528 c        write (iout,*) nn," contacts to processor",iproc,
8529 c     &   " of CONT_TO_COMM group"
8530         if (nn.gt.0) then
8531           ireq=ireq+1
8532           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8533      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8534 c          write (iout,*) "ireq,req",ireq,req(ireq)
8535 c          do i=1,nn
8536 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8537 c          enddo
8538         endif
8539       enddo
8540 c      write (iout,*) "number of requests (contacts)",ireq
8541 c      write (iout,*) "req",(req(i),i=1,4)
8542 c      call flush(iout)
8543       if (ireq.gt.0)
8544      & call MPI_Waitall(ireq,req,status_array,ierr)
8545       do iii=1,ntask_cont_from
8546         iproc=itask_cont_from(iii)
8547         nn=ncont_recv(iii)
8548         if (lprn) then
8549         write (iout,*) "Received",nn," contacts from processor",iproc,
8550      &   " of CONT_FROM_COMM group"
8551         call flush(iout)
8552         do i=1,nn
8553           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8554         enddo
8555         call flush(iout)
8556         endif
8557         do i=1,nn
8558           ii=zapas_recv(1,i,iii)
8559 c Flag the received contacts to prevent double-counting
8560           jj=-zapas_recv(2,i,iii)
8561 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8562 c          call flush(iout)
8563           nnn=num_cont_hb(ii)+1
8564           num_cont_hb(ii)=nnn
8565           jcont_hb(nnn,ii)=jj
8566           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8567           ind=3
8568           do kk=1,3
8569             ind=ind+1
8570             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8571           enddo
8572           do kk=1,2
8573             do ll=1,2
8574               ind=ind+1
8575               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8576             enddo
8577           enddo
8578           do jj=1,5
8579             do kk=1,3
8580               do ll=1,2
8581                 do mm=1,2
8582                   ind=ind+1
8583                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8584                 enddo
8585               enddo
8586             enddo
8587           enddo
8588         enddo
8589       enddo
8590       if (lprn) then
8591         write (iout,'(a)') 'Contact function values after receive:'
8592         do i=nnt,nct-2
8593           write (iout,'(2i3,50(1x,i3,5f6.3))')
8594      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8595      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8596         enddo
8597         call flush(iout)
8598       endif
8599    30 continue
8600 #endif
8601       if (lprn) then
8602         write (iout,'(a)') 'Contact function values:'
8603         do i=nnt,nct-2
8604           write (iout,'(2i3,50(1x,i2,5f6.3))')
8605      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8606      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8607         enddo
8608       endif
8609       ecorr=0.0D0
8610       ecorr5=0.0d0
8611       ecorr6=0.0d0
8612 C Remove the loop below after debugging !!!
8613       do i=nnt,nct
8614         do j=1,3
8615           gradcorr(j,i)=0.0D0
8616           gradxorr(j,i)=0.0D0
8617         enddo
8618       enddo
8619 C Calculate the dipole-dipole interaction energies
8620       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8621       do i=iatel_s,iatel_e+1
8622         num_conti=num_cont_hb(i)
8623         do jj=1,num_conti
8624           j=jcont_hb(jj,i)
8625 #ifdef MOMENT
8626           call dipole(i,j,jj)
8627 #endif
8628         enddo
8629       enddo
8630       endif
8631 C Calculate the local-electrostatic correlation terms
8632 c                write (iout,*) "gradcorr5 in eello5 before loop"
8633 c                do iii=1,nres
8634 c                  write (iout,'(i5,3f10.5)')
8635 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8636 c                enddo
8637       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8638 c        write (iout,*) "corr loop i",i
8639         i1=i+1
8640         num_conti=num_cont_hb(i)
8641         num_conti1=num_cont_hb(i+1)
8642         do jj=1,num_conti
8643           j=jcont_hb(jj,i)
8644           jp=iabs(j)
8645           do kk=1,num_conti1
8646             j1=jcont_hb(kk,i1)
8647             jp1=iabs(j1)
8648 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8649 c     &         ' jj=',jj,' kk=',kk
8650 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8651             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8652      &          .or. j.lt.0 .and. j1.gt.0) .and.
8653      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8654 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8655 C The system gains extra energy.
8656               n_corr=n_corr+1
8657               sqd1=dsqrt(d_cont(jj,i))
8658               sqd2=dsqrt(d_cont(kk,i1))
8659               sred_geom = sqd1*sqd2
8660               IF (sred_geom.lt.cutoff_corr) THEN
8661                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8662      &            ekont,fprimcont)
8663 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8664 cd     &         ' jj=',jj,' kk=',kk
8665                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8666                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8667                 do l=1,3
8668                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8669                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8670                 enddo
8671                 n_corr1=n_corr1+1
8672 cd               write (iout,*) 'sred_geom=',sred_geom,
8673 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8674 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8675 cd               write (iout,*) "g_contij",g_contij
8676 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8677 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8678                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8679                 if (wcorr4.gt.0.0d0)
8680      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8681 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8682                   if (energy_dec.and.wcorr4.gt.0.0d0)
8683      1                 write (iout,'(a6,4i5,0pf7.3)')
8684      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8685 c                write (iout,*) "gradcorr5 before eello5"
8686 c                do iii=1,nres
8687 c                  write (iout,'(i5,3f10.5)')
8688 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8689 c                enddo
8690                 if (wcorr5.gt.0.0d0)
8691      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8692 c                write (iout,*) "gradcorr5 after eello5"
8693 c                do iii=1,nres
8694 c                  write (iout,'(i5,3f10.5)')
8695 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8696 c                enddo
8697                   if (energy_dec.and.wcorr5.gt.0.0d0)
8698      1                 write (iout,'(a6,4i5,0pf7.3)')
8699      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8700 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8701 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8702                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8703      &               .or. wturn6.eq.0.0d0))then
8704 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8705                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8706                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8707      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8708 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8709 cd     &            'ecorr6=',ecorr6
8710 cd                write (iout,'(4e15.5)') sred_geom,
8711 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8712 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8713 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8714                 else if (wturn6.gt.0.0d0
8715      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8716 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8717                   eturn6=eturn6+eello_turn6(i,jj,kk)
8718                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8719      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8720 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8721                 endif
8722               ENDIF
8723 1111          continue
8724             endif
8725           enddo ! kk
8726         enddo ! jj
8727       enddo ! i
8728       do i=1,nres
8729         num_cont_hb(i)=num_cont_hb_old(i)
8730       enddo
8731 c                write (iout,*) "gradcorr5 in eello5"
8732 c                do iii=1,nres
8733 c                  write (iout,'(i5,3f10.5)')
8734 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8735 c                enddo
8736       return
8737       end
8738 c------------------------------------------------------------------------------
8739       subroutine add_hb_contact_eello(ii,jj,itask)
8740       implicit real*8 (a-h,o-z)
8741       include "DIMENSIONS"
8742       include "COMMON.IOUNITS"
8743       integer max_cont
8744       integer max_dim
8745       parameter (max_cont=maxconts)
8746       parameter (max_dim=70)
8747       include "COMMON.CONTACTS"
8748       double precision zapas(max_dim,maxconts,max_fg_procs),
8749      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8750       common /przechowalnia/ zapas
8751       integer i,j,ii,jj,iproc,itask(4),nn
8752 c      write (iout,*) "itask",itask
8753       do i=1,2
8754         iproc=itask(i)
8755         if (iproc.gt.0) then
8756           do j=1,num_cont_hb(ii)
8757             jjc=jcont_hb(j,ii)
8758 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8759             if (jjc.eq.jj) then
8760               ncont_sent(iproc)=ncont_sent(iproc)+1
8761               nn=ncont_sent(iproc)
8762               zapas(1,nn,iproc)=ii
8763               zapas(2,nn,iproc)=jjc
8764               zapas(3,nn,iproc)=d_cont(j,ii)
8765               ind=3
8766               do kk=1,3
8767                 ind=ind+1
8768                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8769               enddo
8770               do kk=1,2
8771                 do ll=1,2
8772                   ind=ind+1
8773                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8774                 enddo
8775               enddo
8776               do jj=1,5
8777                 do kk=1,3
8778                   do ll=1,2
8779                     do mm=1,2
8780                       ind=ind+1
8781                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8782                     enddo
8783                   enddo
8784                 enddo
8785               enddo
8786               exit
8787             endif
8788           enddo
8789         endif
8790       enddo
8791       return
8792       end
8793 c------------------------------------------------------------------------------
8794       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8795       implicit real*8 (a-h,o-z)
8796       include 'DIMENSIONS'
8797       include 'COMMON.IOUNITS'
8798       include 'COMMON.DERIV'
8799       include 'COMMON.INTERACT'
8800       include 'COMMON.CONTACTS'
8801       include 'COMMON.SHIELD'
8802       include 'COMMON.CONTROL'
8803       double precision gx(3),gx1(3)
8804       logical lprn
8805       lprn=.false.
8806 C      print *,"wchodze",fac_shield(i),shield_mode
8807       eij=facont_hb(jj,i)
8808       ekl=facont_hb(kk,k)
8809       ees0pij=ees0p(jj,i)
8810       ees0pkl=ees0p(kk,k)
8811       ees0mij=ees0m(jj,i)
8812       ees0mkl=ees0m(kk,k)
8813       ekont=eij*ekl
8814       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8815 C*
8816 C     & fac_shield(i)**2*fac_shield(j)**2
8817 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8818 C Following 4 lines for diagnostics.
8819 cd    ees0pkl=0.0D0
8820 cd    ees0pij=1.0D0
8821 cd    ees0mkl=0.0D0
8822 cd    ees0mij=1.0D0
8823 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8824 c     & 'Contacts ',i,j,
8825 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8826 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8827 c     & 'gradcorr_long'
8828 C Calculate the multi-body contribution to energy.
8829 C      ecorr=ecorr+ekont*ees
8830 C Calculate multi-body contributions to the gradient.
8831       coeffpees0pij=coeffp*ees0pij
8832       coeffmees0mij=coeffm*ees0mij
8833       coeffpees0pkl=coeffp*ees0pkl
8834       coeffmees0mkl=coeffm*ees0mkl
8835       do ll=1,3
8836 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8837         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8838      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8839      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8840         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8841      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8842      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8843 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8844         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8845      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8846      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8847         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8848      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8849      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8850         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8851      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8852      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8853         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8854         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8855         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8856      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8857      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8858         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8859         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8860 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8861       enddo
8862 c      write (iout,*)
8863 cgrad      do m=i+1,j-1
8864 cgrad        do ll=1,3
8865 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8866 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8867 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8868 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8869 cgrad        enddo
8870 cgrad      enddo
8871 cgrad      do m=k+1,l-1
8872 cgrad        do ll=1,3
8873 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8874 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8875 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8876 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8877 cgrad        enddo
8878 cgrad      enddo
8879 c      write (iout,*) "ehbcorr",ekont*ees
8880 C      print *,ekont,ees,i,k
8881       ehbcorr=ekont*ees
8882 C now gradient over shielding
8883 C      return
8884       if (shield_mode.gt.0) then
8885        j=ees0plist(jj,i)
8886        l=ees0plist(kk,k)
8887 C        print *,i,j,fac_shield(i),fac_shield(j),
8888 C     &fac_shield(k),fac_shield(l)
8889         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8890      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8891           do ilist=1,ishield_list(i)
8892            iresshield=shield_list(ilist,i)
8893            do m=1,3
8894            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8895 C     &      *2.0
8896            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8897      &              rlocshield
8898      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8899             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8900      &+rlocshield
8901            enddo
8902           enddo
8903           do ilist=1,ishield_list(j)
8904            iresshield=shield_list(ilist,j)
8905            do m=1,3
8906            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8907 C     &     *2.0
8908            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8909      &              rlocshield
8910      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8911            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8912      &     +rlocshield
8913            enddo
8914           enddo
8915
8916           do ilist=1,ishield_list(k)
8917            iresshield=shield_list(ilist,k)
8918            do m=1,3
8919            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8920 C     &     *2.0
8921            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8922      &              rlocshield
8923      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8924            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8925      &     +rlocshield
8926            enddo
8927           enddo
8928           do ilist=1,ishield_list(l)
8929            iresshield=shield_list(ilist,l)
8930            do m=1,3
8931            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8932 C     &     *2.0
8933            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8934      &              rlocshield
8935      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8936            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8937      &     +rlocshield
8938            enddo
8939           enddo
8940 C          print *,gshieldx(m,iresshield)
8941           do m=1,3
8942             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8943      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8944             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8945      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8946             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8947      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8948             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8949      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8950
8951             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8952      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8953             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8954      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8955             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8956      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8957             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8958      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8959
8960            enddo
8961       endif
8962       endif
8963       return
8964       end
8965 #ifdef MOMENT
8966 C---------------------------------------------------------------------------
8967       subroutine dipole(i,j,jj)
8968       implicit real*8 (a-h,o-z)
8969       include 'DIMENSIONS'
8970       include 'COMMON.IOUNITS'
8971       include 'COMMON.CHAIN'
8972       include 'COMMON.FFIELD'
8973       include 'COMMON.DERIV'
8974       include 'COMMON.INTERACT'
8975       include 'COMMON.CONTACTS'
8976       include 'COMMON.TORSION'
8977       include 'COMMON.VAR'
8978       include 'COMMON.GEO'
8979       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8980      &  auxmat(2,2)
8981       iti1 = itortyp(itype(i+1))
8982       if (j.lt.nres-1) then
8983         itj1 = itype2loc(itype(j+1))
8984       else
8985         itj1=nloctyp
8986       endif
8987       do iii=1,2
8988         dipi(iii,1)=Ub2(iii,i)
8989         dipderi(iii)=Ub2der(iii,i)
8990         dipi(iii,2)=b1(iii,i+1)
8991         dipj(iii,1)=Ub2(iii,j)
8992         dipderj(iii)=Ub2der(iii,j)
8993         dipj(iii,2)=b1(iii,j+1)
8994       enddo
8995       kkk=0
8996       do iii=1,2
8997         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8998         do jjj=1,2
8999           kkk=kkk+1
9000           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9001         enddo
9002       enddo
9003       do kkk=1,5
9004         do lll=1,3
9005           mmm=0
9006           do iii=1,2
9007             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9008      &        auxvec(1))
9009             do jjj=1,2
9010               mmm=mmm+1
9011               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9012             enddo
9013           enddo
9014         enddo
9015       enddo
9016       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9017       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9018       do iii=1,2
9019         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9020       enddo
9021       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9022       do iii=1,2
9023         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9024       enddo
9025       return
9026       end
9027 #endif
9028 C---------------------------------------------------------------------------
9029       subroutine calc_eello(i,j,k,l,jj,kk)
9030 C
9031 C This subroutine computes matrices and vectors needed to calculate
9032 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9033 C
9034       implicit real*8 (a-h,o-z)
9035       include 'DIMENSIONS'
9036       include 'COMMON.IOUNITS'
9037       include 'COMMON.CHAIN'
9038       include 'COMMON.DERIV'
9039       include 'COMMON.INTERACT'
9040       include 'COMMON.CONTACTS'
9041       include 'COMMON.TORSION'
9042       include 'COMMON.VAR'
9043       include 'COMMON.GEO'
9044       include 'COMMON.FFIELD'
9045       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9046      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9047       logical lprn
9048       common /kutas/ lprn
9049 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9050 cd     & ' jj=',jj,' kk=',kk
9051 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9052 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9053 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9054       do iii=1,2
9055         do jjj=1,2
9056           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9057           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9058         enddo
9059       enddo
9060       call transpose2(aa1(1,1),aa1t(1,1))
9061       call transpose2(aa2(1,1),aa2t(1,1))
9062       do kkk=1,5
9063         do lll=1,3
9064           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9065      &      aa1tder(1,1,lll,kkk))
9066           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9067      &      aa2tder(1,1,lll,kkk))
9068         enddo
9069       enddo
9070       if (l.eq.j+1) then
9071 C parallel orientation of the two CA-CA-CA frames.
9072         if (i.gt.1) then
9073           iti=itype2loc(itype(i))
9074         else
9075           iti=nloctyp
9076         endif
9077         itk1=itype2loc(itype(k+1))
9078         itj=itype2loc(itype(j))
9079         if (l.lt.nres-1) then
9080           itl1=itype2loc(itype(l+1))
9081         else
9082           itl1=nloctyp
9083         endif
9084 C A1 kernel(j+1) A2T
9085 cd        do iii=1,2
9086 cd          write (iout,'(3f10.5,5x,3f10.5)')
9087 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9088 cd        enddo
9089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9090      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9091      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9092 C Following matrices are needed only for 6-th order cumulants
9093         IF (wcorr6.gt.0.0d0) THEN
9094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9095      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9096      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9097         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9098      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9099      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9100      &   ADtEAderx(1,1,1,1,1,1))
9101         lprn=.false.
9102         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9103      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9104      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9105      &   ADtEA1derx(1,1,1,1,1,1))
9106         ENDIF
9107 C End 6-th order cumulants
9108 cd        lprn=.false.
9109 cd        if (lprn) then
9110 cd        write (2,*) 'In calc_eello6'
9111 cd        do iii=1,2
9112 cd          write (2,*) 'iii=',iii
9113 cd          do kkk=1,5
9114 cd            write (2,*) 'kkk=',kkk
9115 cd            do jjj=1,2
9116 cd              write (2,'(3(2f10.5),5x)')
9117 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9118 cd            enddo
9119 cd          enddo
9120 cd        enddo
9121 cd        endif
9122         call transpose2(EUgder(1,1,k),auxmat(1,1))
9123         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9124         call transpose2(EUg(1,1,k),auxmat(1,1))
9125         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9126         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9127 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9128 c    in theta; to be sriten later.
9129 c#ifdef NEWCORR
9130 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9131 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9132 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9133 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9134 c#endif
9135         do iii=1,2
9136           do kkk=1,5
9137             do lll=1,3
9138               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9139      &          EAEAderx(1,1,lll,kkk,iii,1))
9140             enddo
9141           enddo
9142         enddo
9143 C A1T kernel(i+1) A2
9144         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9145      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9146      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9147 C Following matrices are needed only for 6-th order cumulants
9148         IF (wcorr6.gt.0.0d0) THEN
9149         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9150      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9151      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9152         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9153      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9154      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9155      &   ADtEAderx(1,1,1,1,1,2))
9156         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9157      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9158      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9159      &   ADtEA1derx(1,1,1,1,1,2))
9160         ENDIF
9161 C End 6-th order cumulants
9162         call transpose2(EUgder(1,1,l),auxmat(1,1))
9163         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9164         call transpose2(EUg(1,1,l),auxmat(1,1))
9165         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9166         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9167         do iii=1,2
9168           do kkk=1,5
9169             do lll=1,3
9170               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9171      &          EAEAderx(1,1,lll,kkk,iii,2))
9172             enddo
9173           enddo
9174         enddo
9175 C AEAb1 and AEAb2
9176 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9177 C They are needed only when the fifth- or the sixth-order cumulants are
9178 C indluded.
9179         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9180         call transpose2(AEA(1,1,1),auxmat(1,1))
9181         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9182         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9183         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9184         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9185         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9186         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9187         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9188         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9189         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9190         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9191         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9192         call transpose2(AEA(1,1,2),auxmat(1,1))
9193         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9194         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9195         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9196         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9197         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9198         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9199         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9200         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9201         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9202         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9203         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9204 C Calculate the Cartesian derivatives of the vectors.
9205         do iii=1,2
9206           do kkk=1,5
9207             do lll=1,3
9208               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9209               call matvec2(auxmat(1,1),b1(1,i),
9210      &          AEAb1derx(1,lll,kkk,iii,1,1))
9211               call matvec2(auxmat(1,1),Ub2(1,i),
9212      &          AEAb2derx(1,lll,kkk,iii,1,1))
9213               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9214      &          AEAb1derx(1,lll,kkk,iii,2,1))
9215               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9216      &          AEAb2derx(1,lll,kkk,iii,2,1))
9217               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9218               call matvec2(auxmat(1,1),b1(1,j),
9219      &          AEAb1derx(1,lll,kkk,iii,1,2))
9220               call matvec2(auxmat(1,1),Ub2(1,j),
9221      &          AEAb2derx(1,lll,kkk,iii,1,2))
9222               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9223      &          AEAb1derx(1,lll,kkk,iii,2,2))
9224               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9225      &          AEAb2derx(1,lll,kkk,iii,2,2))
9226             enddo
9227           enddo
9228         enddo
9229         ENDIF
9230 C End vectors
9231       else
9232 C Antiparallel orientation of the two CA-CA-CA frames.
9233         if (i.gt.1) then
9234           iti=itype2loc(itype(i))
9235         else
9236           iti=nloctyp
9237         endif
9238         itk1=itype2loc(itype(k+1))
9239         itl=itype2loc(itype(l))
9240         itj=itype2loc(itype(j))
9241         if (j.lt.nres-1) then
9242           itj1=itype2loc(itype(j+1))
9243         else
9244           itj1=nloctyp
9245         endif
9246 C A2 kernel(j-1)T A1T
9247         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9248      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9249      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9250 C Following matrices are needed only for 6-th order cumulants
9251         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9252      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9253         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9254      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9255      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9256         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9257      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9258      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9259      &   ADtEAderx(1,1,1,1,1,1))
9260         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9261      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9262      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9263      &   ADtEA1derx(1,1,1,1,1,1))
9264         ENDIF
9265 C End 6-th order cumulants
9266         call transpose2(EUgder(1,1,k),auxmat(1,1))
9267         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9268         call transpose2(EUg(1,1,k),auxmat(1,1))
9269         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9270         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9271         do iii=1,2
9272           do kkk=1,5
9273             do lll=1,3
9274               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9275      &          EAEAderx(1,1,lll,kkk,iii,1))
9276             enddo
9277           enddo
9278         enddo
9279 C A2T kernel(i+1)T A1
9280         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9281      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9282      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9283 C Following matrices are needed only for 6-th order cumulants
9284         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9285      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9286         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9287      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9288      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9289         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9290      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9291      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9292      &   ADtEAderx(1,1,1,1,1,2))
9293         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9294      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9295      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9296      &   ADtEA1derx(1,1,1,1,1,2))
9297         ENDIF
9298 C End 6-th order cumulants
9299         call transpose2(EUgder(1,1,j),auxmat(1,1))
9300         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9301         call transpose2(EUg(1,1,j),auxmat(1,1))
9302         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9303         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9304         do iii=1,2
9305           do kkk=1,5
9306             do lll=1,3
9307               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9308      &          EAEAderx(1,1,lll,kkk,iii,2))
9309             enddo
9310           enddo
9311         enddo
9312 C AEAb1 and AEAb2
9313 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9314 C They are needed only when the fifth- or the sixth-order cumulants are
9315 C indluded.
9316         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9317      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9318         call transpose2(AEA(1,1,1),auxmat(1,1))
9319         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9320         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9321         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9322         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9323         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9324         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9325         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9326         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9327         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9328         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9329         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9330         call transpose2(AEA(1,1,2),auxmat(1,1))
9331         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9332         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9333         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9334         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9335         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9336         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9337         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9338         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9339         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9340         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9341         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9342 C Calculate the Cartesian derivatives of the vectors.
9343         do iii=1,2
9344           do kkk=1,5
9345             do lll=1,3
9346               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9347               call matvec2(auxmat(1,1),b1(1,i),
9348      &          AEAb1derx(1,lll,kkk,iii,1,1))
9349               call matvec2(auxmat(1,1),Ub2(1,i),
9350      &          AEAb2derx(1,lll,kkk,iii,1,1))
9351               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9352      &          AEAb1derx(1,lll,kkk,iii,2,1))
9353               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9354      &          AEAb2derx(1,lll,kkk,iii,2,1))
9355               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9356               call matvec2(auxmat(1,1),b1(1,l),
9357      &          AEAb1derx(1,lll,kkk,iii,1,2))
9358               call matvec2(auxmat(1,1),Ub2(1,l),
9359      &          AEAb2derx(1,lll,kkk,iii,1,2))
9360               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9361      &          AEAb1derx(1,lll,kkk,iii,2,2))
9362               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9363      &          AEAb2derx(1,lll,kkk,iii,2,2))
9364             enddo
9365           enddo
9366         enddo
9367         ENDIF
9368 C End vectors
9369       endif
9370       return
9371       end
9372 C---------------------------------------------------------------------------
9373       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9374      &  KK,KKderg,AKA,AKAderg,AKAderx)
9375       implicit none
9376       integer nderg
9377       logical transp
9378       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9379      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9380      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9381       integer iii,kkk,lll
9382       integer jjj,mmm
9383       logical lprn
9384       common /kutas/ lprn
9385       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9386       do iii=1,nderg
9387         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9388      &    AKAderg(1,1,iii))
9389       enddo
9390 cd      if (lprn) write (2,*) 'In kernel'
9391       do kkk=1,5
9392 cd        if (lprn) write (2,*) 'kkk=',kkk
9393         do lll=1,3
9394           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9395      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9396 cd          if (lprn) then
9397 cd            write (2,*) 'lll=',lll
9398 cd            write (2,*) 'iii=1'
9399 cd            do jjj=1,2
9400 cd              write (2,'(3(2f10.5),5x)')
9401 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9402 cd            enddo
9403 cd          endif
9404           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9405      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9406 cd          if (lprn) then
9407 cd            write (2,*) 'lll=',lll
9408 cd            write (2,*) 'iii=2'
9409 cd            do jjj=1,2
9410 cd              write (2,'(3(2f10.5),5x)')
9411 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9412 cd            enddo
9413 cd          endif
9414         enddo
9415       enddo
9416       return
9417       end
9418 C---------------------------------------------------------------------------
9419       double precision function eello4(i,j,k,l,jj,kk)
9420       implicit real*8 (a-h,o-z)
9421       include 'DIMENSIONS'
9422       include 'COMMON.IOUNITS'
9423       include 'COMMON.CHAIN'
9424       include 'COMMON.DERIV'
9425       include 'COMMON.INTERACT'
9426       include 'COMMON.CONTACTS'
9427       include 'COMMON.TORSION'
9428       include 'COMMON.VAR'
9429       include 'COMMON.GEO'
9430       double precision pizda(2,2),ggg1(3),ggg2(3)
9431 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9432 cd        eello4=0.0d0
9433 cd        return
9434 cd      endif
9435 cd      print *,'eello4:',i,j,k,l,jj,kk
9436 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9437 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9438 cold      eij=facont_hb(jj,i)
9439 cold      ekl=facont_hb(kk,k)
9440 cold      ekont=eij*ekl
9441       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9442 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9443       gcorr_loc(k-1)=gcorr_loc(k-1)
9444      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9445       if (l.eq.j+1) then
9446         gcorr_loc(l-1)=gcorr_loc(l-1)
9447      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9448 C Al 4/16/16: Derivatives in theta, to be added later.
9449 c#ifdef NEWCORR
9450 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9451 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9452 c#endif
9453       else
9454         gcorr_loc(j-1)=gcorr_loc(j-1)
9455      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9456 c#ifdef NEWCORR
9457 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9458 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9459 c#endif
9460       endif
9461       do iii=1,2
9462         do kkk=1,5
9463           do lll=1,3
9464             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9465      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9466 cd            derx(lll,kkk,iii)=0.0d0
9467           enddo
9468         enddo
9469       enddo
9470 cd      gcorr_loc(l-1)=0.0d0
9471 cd      gcorr_loc(j-1)=0.0d0
9472 cd      gcorr_loc(k-1)=0.0d0
9473 cd      eel4=1.0d0
9474 cd      write (iout,*)'Contacts have occurred for peptide groups',
9475 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9476 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9477       if (j.lt.nres-1) then
9478         j1=j+1
9479         j2=j-1
9480       else
9481         j1=j-1
9482         j2=j-2
9483       endif
9484       if (l.lt.nres-1) then
9485         l1=l+1
9486         l2=l-1
9487       else
9488         l1=l-1
9489         l2=l-2
9490       endif
9491       do ll=1,3
9492 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9493 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9494         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9495         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9496 cgrad        ghalf=0.5d0*ggg1(ll)
9497         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9498         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9499         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9500         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9501         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9502         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9503 cgrad        ghalf=0.5d0*ggg2(ll)
9504         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9505         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9506         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9507         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9508         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9509         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9510       enddo
9511 cgrad      do m=i+1,j-1
9512 cgrad        do ll=1,3
9513 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9514 cgrad        enddo
9515 cgrad      enddo
9516 cgrad      do m=k+1,l-1
9517 cgrad        do ll=1,3
9518 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9519 cgrad        enddo
9520 cgrad      enddo
9521 cgrad      do m=i+2,j2
9522 cgrad        do ll=1,3
9523 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9524 cgrad        enddo
9525 cgrad      enddo
9526 cgrad      do m=k+2,l2
9527 cgrad        do ll=1,3
9528 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9529 cgrad        enddo
9530 cgrad      enddo
9531 cd      do iii=1,nres-3
9532 cd        write (2,*) iii,gcorr_loc(iii)
9533 cd      enddo
9534       eello4=ekont*eel4
9535 cd      write (2,*) 'ekont',ekont
9536 cd      write (iout,*) 'eello4',ekont*eel4
9537       return
9538       end
9539 C---------------------------------------------------------------------------
9540       double precision function eello5(i,j,k,l,jj,kk)
9541       implicit real*8 (a-h,o-z)
9542       include 'DIMENSIONS'
9543       include 'COMMON.IOUNITS'
9544       include 'COMMON.CHAIN'
9545       include 'COMMON.DERIV'
9546       include 'COMMON.INTERACT'
9547       include 'COMMON.CONTACTS'
9548       include 'COMMON.TORSION'
9549       include 'COMMON.VAR'
9550       include 'COMMON.GEO'
9551       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9552       double precision ggg1(3),ggg2(3)
9553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9554 C                                                                              C
9555 C                            Parallel chains                                   C
9556 C                                                                              C
9557 C          o             o                   o             o                   C
9558 C         /l\           / \             \   / \           / \   /              C
9559 C        /   \         /   \             \ /   \         /   \ /               C
9560 C       j| o |l1       | o |              o| o |         | o |o                C
9561 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9562 C      \i/   \         /   \ /             /   \         /   \                 C
9563 C       o    k1             o                                                  C
9564 C         (I)          (II)                (III)          (IV)                 C
9565 C                                                                              C
9566 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9567 C                                                                              C
9568 C                            Antiparallel chains                               C
9569 C                                                                              C
9570 C          o             o                   o             o                   C
9571 C         /j\           / \             \   / \           / \   /              C
9572 C        /   \         /   \             \ /   \         /   \ /               C
9573 C      j1| o |l        | o |              o| o |         | o |o                C
9574 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9575 C      \i/   \         /   \ /             /   \         /   \                 C
9576 C       o     k1            o                                                  C
9577 C         (I)          (II)                (III)          (IV)                 C
9578 C                                                                              C
9579 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9580 C                                                                              C
9581 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9582 C                                                                              C
9583 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9584 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9585 cd        eello5=0.0d0
9586 cd        return
9587 cd      endif
9588 cd      write (iout,*)
9589 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9590 cd     &   ' and',k,l
9591       itk=itype2loc(itype(k))
9592       itl=itype2loc(itype(l))
9593       itj=itype2loc(itype(j))
9594       eello5_1=0.0d0
9595       eello5_2=0.0d0
9596       eello5_3=0.0d0
9597       eello5_4=0.0d0
9598 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9599 cd     &   eel5_3_num,eel5_4_num)
9600       do iii=1,2
9601         do kkk=1,5
9602           do lll=1,3
9603             derx(lll,kkk,iii)=0.0d0
9604           enddo
9605         enddo
9606       enddo
9607 cd      eij=facont_hb(jj,i)
9608 cd      ekl=facont_hb(kk,k)
9609 cd      ekont=eij*ekl
9610 cd      write (iout,*)'Contacts have occurred for peptide groups',
9611 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9612 cd      goto 1111
9613 C Contribution from the graph I.
9614 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9615 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9616       call transpose2(EUg(1,1,k),auxmat(1,1))
9617       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9618       vv(1)=pizda(1,1)-pizda(2,2)
9619       vv(2)=pizda(1,2)+pizda(2,1)
9620       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9621      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9622 C Explicit gradient in virtual-dihedral angles.
9623       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9624      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9625      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9626       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9627       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9628       vv(1)=pizda(1,1)-pizda(2,2)
9629       vv(2)=pizda(1,2)+pizda(2,1)
9630       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9631      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9632      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9633       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9634       vv(1)=pizda(1,1)-pizda(2,2)
9635       vv(2)=pizda(1,2)+pizda(2,1)
9636       if (l.eq.j+1) then
9637         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9638      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9640       else
9641         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9642      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9644       endif
9645 C Cartesian gradient
9646       do iii=1,2
9647         do kkk=1,5
9648           do lll=1,3
9649             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9650      &        pizda(1,1))
9651             vv(1)=pizda(1,1)-pizda(2,2)
9652             vv(2)=pizda(1,2)+pizda(2,1)
9653             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9654      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9655      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9656           enddo
9657         enddo
9658       enddo
9659 c      goto 1112
9660 c1111  continue
9661 C Contribution from graph II
9662       call transpose2(EE(1,1,k),auxmat(1,1))
9663       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9664       vv(1)=pizda(1,1)+pizda(2,2)
9665       vv(2)=pizda(2,1)-pizda(1,2)
9666       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9667      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9668 C Explicit gradient in virtual-dihedral angles.
9669       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9670      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9671       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9672       vv(1)=pizda(1,1)+pizda(2,2)
9673       vv(2)=pizda(2,1)-pizda(1,2)
9674       if (l.eq.j+1) then
9675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9676      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9677      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9678       else
9679         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9680      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9681      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9682       endif
9683 C Cartesian gradient
9684       do iii=1,2
9685         do kkk=1,5
9686           do lll=1,3
9687             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9688      &        pizda(1,1))
9689             vv(1)=pizda(1,1)+pizda(2,2)
9690             vv(2)=pizda(2,1)-pizda(1,2)
9691             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9692      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9693      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9694           enddo
9695         enddo
9696       enddo
9697 cd      goto 1112
9698 cd1111  continue
9699       if (l.eq.j+1) then
9700 cd        goto 1110
9701 C Parallel orientation
9702 C Contribution from graph III
9703         call transpose2(EUg(1,1,l),auxmat(1,1))
9704         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9705         vv(1)=pizda(1,1)-pizda(2,2)
9706         vv(2)=pizda(1,2)+pizda(2,1)
9707         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9708      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9709 C Explicit gradient in virtual-dihedral angles.
9710         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9711      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9712      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9713         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9714         vv(1)=pizda(1,1)-pizda(2,2)
9715         vv(2)=pizda(1,2)+pizda(2,1)
9716         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9717      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9719         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9720         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9721         vv(1)=pizda(1,1)-pizda(2,2)
9722         vv(2)=pizda(1,2)+pizda(2,1)
9723         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9724      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9726 C Cartesian gradient
9727         do iii=1,2
9728           do kkk=1,5
9729             do lll=1,3
9730               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9731      &          pizda(1,1))
9732               vv(1)=pizda(1,1)-pizda(2,2)
9733               vv(2)=pizda(1,2)+pizda(2,1)
9734               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9735      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9736      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9737             enddo
9738           enddo
9739         enddo
9740 cd        goto 1112
9741 C Contribution from graph IV
9742 cd1110    continue
9743         call transpose2(EE(1,1,l),auxmat(1,1))
9744         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9745         vv(1)=pizda(1,1)+pizda(2,2)
9746         vv(2)=pizda(2,1)-pizda(1,2)
9747         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9748      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9749 C Explicit gradient in virtual-dihedral angles.
9750         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9751      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9752         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9753         vv(1)=pizda(1,1)+pizda(2,2)
9754         vv(2)=pizda(2,1)-pizda(1,2)
9755         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9756      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9757      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9758 C Cartesian gradient
9759         do iii=1,2
9760           do kkk=1,5
9761             do lll=1,3
9762               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9763      &          pizda(1,1))
9764               vv(1)=pizda(1,1)+pizda(2,2)
9765               vv(2)=pizda(2,1)-pizda(1,2)
9766               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9767      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9768      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9769             enddo
9770           enddo
9771         enddo
9772       else
9773 C Antiparallel orientation
9774 C Contribution from graph III
9775 c        goto 1110
9776         call transpose2(EUg(1,1,j),auxmat(1,1))
9777         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9778         vv(1)=pizda(1,1)-pizda(2,2)
9779         vv(2)=pizda(1,2)+pizda(2,1)
9780         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9781      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9782 C Explicit gradient in virtual-dihedral angles.
9783         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9784      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9785      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9786         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9787         vv(1)=pizda(1,1)-pizda(2,2)
9788         vv(2)=pizda(1,2)+pizda(2,1)
9789         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9790      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9791      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9792         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9793         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9794         vv(1)=pizda(1,1)-pizda(2,2)
9795         vv(2)=pizda(1,2)+pizda(2,1)
9796         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9797      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9799 C Cartesian gradient
9800         do iii=1,2
9801           do kkk=1,5
9802             do lll=1,3
9803               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9804      &          pizda(1,1))
9805               vv(1)=pizda(1,1)-pizda(2,2)
9806               vv(2)=pizda(1,2)+pizda(2,1)
9807               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9808      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9809      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9810             enddo
9811           enddo
9812         enddo
9813 cd        goto 1112
9814 C Contribution from graph IV
9815 1110    continue
9816         call transpose2(EE(1,1,j),auxmat(1,1))
9817         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9818         vv(1)=pizda(1,1)+pizda(2,2)
9819         vv(2)=pizda(2,1)-pizda(1,2)
9820         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9821      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9822 C Explicit gradient in virtual-dihedral angles.
9823         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9824      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9825         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9826         vv(1)=pizda(1,1)+pizda(2,2)
9827         vv(2)=pizda(2,1)-pizda(1,2)
9828         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9829      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9830      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9831 C Cartesian gradient
9832         do iii=1,2
9833           do kkk=1,5
9834             do lll=1,3
9835               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9836      &          pizda(1,1))
9837               vv(1)=pizda(1,1)+pizda(2,2)
9838               vv(2)=pizda(2,1)-pizda(1,2)
9839               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9840      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9841      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9842             enddo
9843           enddo
9844         enddo
9845       endif
9846 1112  continue
9847       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9848 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9849 cd        write (2,*) 'ijkl',i,j,k,l
9850 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9851 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9852 cd      endif
9853 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9854 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9855 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9856 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9857       if (j.lt.nres-1) then
9858         j1=j+1
9859         j2=j-1
9860       else
9861         j1=j-1
9862         j2=j-2
9863       endif
9864       if (l.lt.nres-1) then
9865         l1=l+1
9866         l2=l-1
9867       else
9868         l1=l-1
9869         l2=l-2
9870       endif
9871 cd      eij=1.0d0
9872 cd      ekl=1.0d0
9873 cd      ekont=1.0d0
9874 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9875 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9876 C        summed up outside the subrouine as for the other subroutines
9877 C        handling long-range interactions. The old code is commented out
9878 C        with "cgrad" to keep track of changes.
9879       do ll=1,3
9880 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9881 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9882         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9883         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9884 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9885 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9886 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9887 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9888 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9889 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9890 c     &   gradcorr5ij,
9891 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9892 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9893 cgrad        ghalf=0.5d0*ggg1(ll)
9894 cd        ghalf=0.0d0
9895         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9896         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9897         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9898         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9899         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9900         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9901 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9902 cgrad        ghalf=0.5d0*ggg2(ll)
9903 cd        ghalf=0.0d0
9904         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9905         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9906         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9907         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9908         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9909         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9910       enddo
9911 cd      goto 1112
9912 cgrad      do m=i+1,j-1
9913 cgrad        do ll=1,3
9914 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9915 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9916 cgrad        enddo
9917 cgrad      enddo
9918 cgrad      do m=k+1,l-1
9919 cgrad        do ll=1,3
9920 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9921 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9922 cgrad        enddo
9923 cgrad      enddo
9924 c1112  continue
9925 cgrad      do m=i+2,j2
9926 cgrad        do ll=1,3
9927 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9928 cgrad        enddo
9929 cgrad      enddo
9930 cgrad      do m=k+2,l2
9931 cgrad        do ll=1,3
9932 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9933 cgrad        enddo
9934 cgrad      enddo
9935 cd      do iii=1,nres-3
9936 cd        write (2,*) iii,g_corr5_loc(iii)
9937 cd      enddo
9938       eello5=ekont*eel5
9939 cd      write (2,*) 'ekont',ekont
9940 cd      write (iout,*) 'eello5',ekont*eel5
9941       return
9942       end
9943 c--------------------------------------------------------------------------
9944       double precision function eello6(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.TORSION'
9953       include 'COMMON.VAR'
9954       include 'COMMON.GEO'
9955       include 'COMMON.FFIELD'
9956       double precision ggg1(3),ggg2(3)
9957 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9958 cd        eello6=0.0d0
9959 cd        return
9960 cd      endif
9961 cd      write (iout,*)
9962 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9963 cd     &   ' and',k,l
9964       eello6_1=0.0d0
9965       eello6_2=0.0d0
9966       eello6_3=0.0d0
9967       eello6_4=0.0d0
9968       eello6_5=0.0d0
9969       eello6_6=0.0d0
9970 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9971 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9972       do iii=1,2
9973         do kkk=1,5
9974           do lll=1,3
9975             derx(lll,kkk,iii)=0.0d0
9976           enddo
9977         enddo
9978       enddo
9979 cd      eij=facont_hb(jj,i)
9980 cd      ekl=facont_hb(kk,k)
9981 cd      ekont=eij*ekl
9982 cd      eij=1.0d0
9983 cd      ekl=1.0d0
9984 cd      ekont=1.0d0
9985       if (l.eq.j+1) then
9986         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9987         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9988         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9989         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9990         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9991         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9992       else
9993         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9994         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9995         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9996         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9997         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9998           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9999         else
10000           eello6_5=0.0d0
10001         endif
10002         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10003       endif
10004 C If turn contributions are considered, they will be handled separately.
10005       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10006 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10007 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10008 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10009 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10010 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10011 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10012 cd      goto 1112
10013       if (j.lt.nres-1) then
10014         j1=j+1
10015         j2=j-1
10016       else
10017         j1=j-1
10018         j2=j-2
10019       endif
10020       if (l.lt.nres-1) then
10021         l1=l+1
10022         l2=l-1
10023       else
10024         l1=l-1
10025         l2=l-2
10026       endif
10027       do ll=1,3
10028 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10029 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10030 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10031 cgrad        ghalf=0.5d0*ggg1(ll)
10032 cd        ghalf=0.0d0
10033         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10034         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10035         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10036         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10037         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10038         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10039         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10040         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10041 cgrad        ghalf=0.5d0*ggg2(ll)
10042 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10043 cd        ghalf=0.0d0
10044         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10045         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10046         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10047         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10048         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10049         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10050       enddo
10051 cd      goto 1112
10052 cgrad      do m=i+1,j-1
10053 cgrad        do ll=1,3
10054 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10055 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10056 cgrad        enddo
10057 cgrad      enddo
10058 cgrad      do m=k+1,l-1
10059 cgrad        do ll=1,3
10060 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10061 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10062 cgrad        enddo
10063 cgrad      enddo
10064 cgrad1112  continue
10065 cgrad      do m=i+2,j2
10066 cgrad        do ll=1,3
10067 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10068 cgrad        enddo
10069 cgrad      enddo
10070 cgrad      do m=k+2,l2
10071 cgrad        do ll=1,3
10072 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10073 cgrad        enddo
10074 cgrad      enddo
10075 cd      do iii=1,nres-3
10076 cd        write (2,*) iii,g_corr6_loc(iii)
10077 cd      enddo
10078       eello6=ekont*eel6
10079 cd      write (2,*) 'ekont',ekont
10080 cd      write (iout,*) 'eello6',ekont*eel6
10081       return
10082       end
10083 c--------------------------------------------------------------------------
10084       double precision function eello6_graph1(i,j,k,l,imat,swap)
10085       implicit real*8 (a-h,o-z)
10086       include 'DIMENSIONS'
10087       include 'COMMON.IOUNITS'
10088       include 'COMMON.CHAIN'
10089       include 'COMMON.DERIV'
10090       include 'COMMON.INTERACT'
10091       include 'COMMON.CONTACTS'
10092       include 'COMMON.TORSION'
10093       include 'COMMON.VAR'
10094       include 'COMMON.GEO'
10095       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10096       logical swap
10097       logical lprn
10098       common /kutas/ lprn
10099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10100 C                                                                              C
10101 C      Parallel       Antiparallel                                             C
10102 C                                                                              C
10103 C          o             o                                                     C
10104 C         /l\           /j\                                                    C
10105 C        /   \         /   \                                                   C
10106 C       /| o |         | o |\                                                  C
10107 C     \ j|/k\|  /   \  |/k\|l /                                                C
10108 C      \ /   \ /     \ /   \ /                                                 C
10109 C       o     o       o     o                                                  C
10110 C       i             i                                                        C
10111 C                                                                              C
10112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10113       itk=itype2loc(itype(k))
10114       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10115       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10116       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10117       call transpose2(EUgC(1,1,k),auxmat(1,1))
10118       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10119       vv1(1)=pizda1(1,1)-pizda1(2,2)
10120       vv1(2)=pizda1(1,2)+pizda1(2,1)
10121       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10122       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10123       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10124       s5=scalar2(vv(1),Dtobr2(1,i))
10125 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10126       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10127       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10128      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10129      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10130      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10131      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10132      & +scalar2(vv(1),Dtobr2der(1,i)))
10133       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10134       vv1(1)=pizda1(1,1)-pizda1(2,2)
10135       vv1(2)=pizda1(1,2)+pizda1(2,1)
10136       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10137       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10138       if (l.eq.j+1) then
10139         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10140      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10141      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10142      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10143      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10144       else
10145         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10146      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10147      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10148      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10149      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10150       endif
10151       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10152       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10153       vv1(1)=pizda1(1,1)-pizda1(2,2)
10154       vv1(2)=pizda1(1,2)+pizda1(2,1)
10155       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10156      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10157      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10158      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10159       do iii=1,2
10160         if (swap) then
10161           ind=3-iii
10162         else
10163           ind=iii
10164         endif
10165         do kkk=1,5
10166           do lll=1,3
10167             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10168             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10169             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10170             call transpose2(EUgC(1,1,k),auxmat(1,1))
10171             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10172      &        pizda1(1,1))
10173             vv1(1)=pizda1(1,1)-pizda1(2,2)
10174             vv1(2)=pizda1(1,2)+pizda1(2,1)
10175             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10176             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10177      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10178             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10179      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10180             s5=scalar2(vv(1),Dtobr2(1,i))
10181             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10182           enddo
10183         enddo
10184       enddo
10185       return
10186       end
10187 c----------------------------------------------------------------------------
10188       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10189       implicit real*8 (a-h,o-z)
10190       include 'DIMENSIONS'
10191       include 'COMMON.IOUNITS'
10192       include 'COMMON.CHAIN'
10193       include 'COMMON.DERIV'
10194       include 'COMMON.INTERACT'
10195       include 'COMMON.CONTACTS'
10196       include 'COMMON.TORSION'
10197       include 'COMMON.VAR'
10198       include 'COMMON.GEO'
10199       logical swap
10200       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10201      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10202       logical lprn
10203       common /kutas/ lprn
10204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10205 C                                                                              C
10206 C      Parallel       Antiparallel                                             C
10207 C                                                                              C
10208 C          o             o                                                     C
10209 C     \   /l\           /j\   /                                                C
10210 C      \ /   \         /   \ /                                                 C
10211 C       o| o |         | o |o                                                  C
10212 C     \ j|/k\|      \  |/k\|l                                                  C
10213 C      \ /   \       \ /   \                                                   C
10214 C       o             o                                                        C
10215 C       i             i                                                        C
10216 C                                                                              C
10217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10218 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10219 C AL 7/4/01 s1 would occur in the sixth-order moment,
10220 C           but not in a cluster cumulant
10221 #ifdef MOMENT
10222       s1=dip(1,jj,i)*dip(1,kk,k)
10223 #endif
10224       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10225       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10226       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10227       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10228       call transpose2(EUg(1,1,k),auxmat(1,1))
10229       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10230       vv(1)=pizda(1,1)-pizda(2,2)
10231       vv(2)=pizda(1,2)+pizda(2,1)
10232       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10233 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10234 #ifdef MOMENT
10235       eello6_graph2=-(s1+s2+s3+s4)
10236 #else
10237       eello6_graph2=-(s2+s3+s4)
10238 #endif
10239 c      eello6_graph2=-s3
10240 C Derivatives in gamma(i-1)
10241       if (i.gt.1) then
10242 #ifdef MOMENT
10243         s1=dipderg(1,jj,i)*dip(1,kk,k)
10244 #endif
10245         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10246         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10247         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10248         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10249 #ifdef MOMENT
10250         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10251 #else
10252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10253 #endif
10254 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10255       endif
10256 C Derivatives in gamma(k-1)
10257 #ifdef MOMENT
10258       s1=dip(1,jj,i)*dipderg(1,kk,k)
10259 #endif
10260       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10261       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10262       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10263       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10264       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10265       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10266       vv(1)=pizda(1,1)-pizda(2,2)
10267       vv(2)=pizda(1,2)+pizda(2,1)
10268       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10269 #ifdef MOMENT
10270       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10271 #else
10272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10273 #endif
10274 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10275 C Derivatives in gamma(j-1) or gamma(l-1)
10276       if (j.gt.1) then
10277 #ifdef MOMENT
10278         s1=dipderg(3,jj,i)*dip(1,kk,k)
10279 #endif
10280         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10281         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10282         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10283         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10284         vv(1)=pizda(1,1)-pizda(2,2)
10285         vv(2)=pizda(1,2)+pizda(2,1)
10286         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10287 #ifdef MOMENT
10288         if (swap) then
10289           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10290         else
10291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10292         endif
10293 #endif
10294         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10295 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10296       endif
10297 C Derivatives in gamma(l-1) or gamma(j-1)
10298       if (l.gt.1) then
10299 #ifdef MOMENT
10300         s1=dip(1,jj,i)*dipderg(3,kk,k)
10301 #endif
10302         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10303         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10304         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10305         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10306         call matmat2(ADtEA1derg(1,1,2,1),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         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10310 #ifdef MOMENT
10311         if (swap) then
10312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10313         else
10314           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10315         endif
10316 #endif
10317         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10318 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10319       endif
10320 C Cartesian derivatives.
10321       if (lprn) then
10322         write (2,*) 'In eello6_graph2'
10323         do iii=1,2
10324           write (2,*) 'iii=',iii
10325           do kkk=1,5
10326             write (2,*) 'kkk=',kkk
10327             do jjj=1,2
10328               write (2,'(3(2f10.5),5x)')
10329      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10330             enddo
10331           enddo
10332         enddo
10333       endif
10334       do iii=1,2
10335         do kkk=1,5
10336           do lll=1,3
10337 #ifdef MOMENT
10338             if (iii.eq.1) then
10339               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10340             else
10341               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10342             endif
10343 #endif
10344             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10345      &        auxvec(1))
10346             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10347             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10348      &        auxvec(1))
10349             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10350             call transpose2(EUg(1,1,k),auxmat(1,1))
10351             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10352      &        pizda(1,1))
10353             vv(1)=pizda(1,1)-pizda(2,2)
10354             vv(2)=pizda(1,2)+pizda(2,1)
10355             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10356 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10357 #ifdef MOMENT
10358             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10359 #else
10360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10361 #endif
10362             if (swap) then
10363               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10364             else
10365               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10366             endif
10367           enddo
10368         enddo
10369       enddo
10370       return
10371       end
10372 c----------------------------------------------------------------------------
10373       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10374       implicit real*8 (a-h,o-z)
10375       include 'DIMENSIONS'
10376       include 'COMMON.IOUNITS'
10377       include 'COMMON.CHAIN'
10378       include 'COMMON.DERIV'
10379       include 'COMMON.INTERACT'
10380       include 'COMMON.CONTACTS'
10381       include 'COMMON.TORSION'
10382       include 'COMMON.VAR'
10383       include 'COMMON.GEO'
10384       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10385       logical swap
10386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10387 C                                                                              C
10388 C      Parallel       Antiparallel                                             C
10389 C                                                                              C
10390 C          o             o                                                     C
10391 C         /l\   /   \   /j\                                                    C
10392 C        /   \ /     \ /   \                                                   C
10393 C       /| o |o       o| o |\                                                  C
10394 C       j|/k\|  /      |/k\|l /                                                C
10395 C        /   \ /       /   \ /                                                 C
10396 C       /     o       /     o                                                  C
10397 C       i             i                                                        C
10398 C                                                                              C
10399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10400 C
10401 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10402 C           energy moment and not to the cluster cumulant.
10403       iti=itortyp(itype(i))
10404       if (j.lt.nres-1) then
10405         itj1=itype2loc(itype(j+1))
10406       else
10407         itj1=nloctyp
10408       endif
10409       itk=itype2loc(itype(k))
10410       itk1=itype2loc(itype(k+1))
10411       if (l.lt.nres-1) then
10412         itl1=itype2loc(itype(l+1))
10413       else
10414         itl1=nloctyp
10415       endif
10416 #ifdef MOMENT
10417       s1=dip(4,jj,i)*dip(4,kk,k)
10418 #endif
10419       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10420       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10421       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10422       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10423       call transpose2(EE(1,1,k),auxmat(1,1))
10424       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10425       vv(1)=pizda(1,1)+pizda(2,2)
10426       vv(2)=pizda(2,1)-pizda(1,2)
10427       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10428 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10429 cd     & "sum",-(s2+s3+s4)
10430 #ifdef MOMENT
10431       eello6_graph3=-(s1+s2+s3+s4)
10432 #else
10433       eello6_graph3=-(s2+s3+s4)
10434 #endif
10435 c      eello6_graph3=-s4
10436 C Derivatives in gamma(k-1)
10437       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10438       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10439       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10440       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10441 C Derivatives in gamma(l-1)
10442       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10443       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10444       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10445       vv(1)=pizda(1,1)+pizda(2,2)
10446       vv(2)=pizda(2,1)-pizda(1,2)
10447       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10448       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10449 C Cartesian derivatives.
10450       do iii=1,2
10451         do kkk=1,5
10452           do lll=1,3
10453 #ifdef MOMENT
10454             if (iii.eq.1) then
10455               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10456             else
10457               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10458             endif
10459 #endif
10460             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10461      &        auxvec(1))
10462             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10463             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10464      &        auxvec(1))
10465             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10466             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10467      &        pizda(1,1))
10468             vv(1)=pizda(1,1)+pizda(2,2)
10469             vv(2)=pizda(2,1)-pizda(1,2)
10470             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10471 #ifdef MOMENT
10472             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10473 #else
10474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10475 #endif
10476             if (swap) then
10477               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10478             else
10479               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10480             endif
10481 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10482           enddo
10483         enddo
10484       enddo
10485       return
10486       end
10487 c----------------------------------------------------------------------------
10488       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10489       implicit real*8 (a-h,o-z)
10490       include 'DIMENSIONS'
10491       include 'COMMON.IOUNITS'
10492       include 'COMMON.CHAIN'
10493       include 'COMMON.DERIV'
10494       include 'COMMON.INTERACT'
10495       include 'COMMON.CONTACTS'
10496       include 'COMMON.TORSION'
10497       include 'COMMON.VAR'
10498       include 'COMMON.GEO'
10499       include 'COMMON.FFIELD'
10500       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10501      & auxvec1(2),auxmat1(2,2)
10502       logical swap
10503 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10504 C                                                                              C
10505 C      Parallel       Antiparallel                                             C
10506 C                                                                              C
10507 C          o             o                                                     C
10508 C         /l\   /   \   /j\                                                    C
10509 C        /   \ /     \ /   \                                                   C
10510 C       /| o |o       o| o |\                                                  C
10511 C     \ j|/k\|      \  |/k\|l                                                  C
10512 C      \ /   \       \ /   \                                                   C
10513 C       o     \       o     \                                                  C
10514 C       i             i                                                        C
10515 C                                                                              C
10516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10517 C
10518 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10519 C           energy moment and not to the cluster cumulant.
10520 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10521       iti=itype2loc(itype(i))
10522       itj=itype2loc(itype(j))
10523       if (j.lt.nres-1) then
10524         itj1=itype2loc(itype(j+1))
10525       else
10526         itj1=nloctyp
10527       endif
10528       itk=itype2loc(itype(k))
10529       if (k.lt.nres-1) then
10530         itk1=itype2loc(itype(k+1))
10531       else
10532         itk1=nloctyp
10533       endif
10534       itl=itype2loc(itype(l))
10535       if (l.lt.nres-1) then
10536         itl1=itype2loc(itype(l+1))
10537       else
10538         itl1=nloctyp
10539       endif
10540 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10541 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10542 cd     & ' itl',itl,' itl1',itl1
10543 #ifdef MOMENT
10544       if (imat.eq.1) then
10545         s1=dip(3,jj,i)*dip(3,kk,k)
10546       else
10547         s1=dip(2,jj,j)*dip(2,kk,l)
10548       endif
10549 #endif
10550       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10551       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10552       if (j.eq.l+1) then
10553         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10554         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10555       else
10556         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10557         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10558       endif
10559       call transpose2(EUg(1,1,k),auxmat(1,1))
10560       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10561       vv(1)=pizda(1,1)-pizda(2,2)
10562       vv(2)=pizda(2,1)+pizda(1,2)
10563       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10564 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10565 #ifdef MOMENT
10566       eello6_graph4=-(s1+s2+s3+s4)
10567 #else
10568       eello6_graph4=-(s2+s3+s4)
10569 #endif
10570 C Derivatives in gamma(i-1)
10571       if (i.gt.1) then
10572 #ifdef MOMENT
10573         if (imat.eq.1) then
10574           s1=dipderg(2,jj,i)*dip(3,kk,k)
10575         else
10576           s1=dipderg(4,jj,j)*dip(2,kk,l)
10577         endif
10578 #endif
10579         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10580         if (j.eq.l+1) then
10581           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10582           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10583         else
10584           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10585           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10586         endif
10587         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10588         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10589 cd          write (2,*) 'turn6 derivatives'
10590 #ifdef MOMENT
10591           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10592 #else
10593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10594 #endif
10595         else
10596 #ifdef MOMENT
10597           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10598 #else
10599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10600 #endif
10601         endif
10602       endif
10603 C Derivatives in gamma(k-1)
10604 #ifdef MOMENT
10605       if (imat.eq.1) then
10606         s1=dip(3,jj,i)*dipderg(2,kk,k)
10607       else
10608         s1=dip(2,jj,j)*dipderg(4,kk,l)
10609       endif
10610 #endif
10611       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10612       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10613       if (j.eq.l+1) then
10614         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10615         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10616       else
10617         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10618         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10619       endif
10620       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10621       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10622       vv(1)=pizda(1,1)-pizda(2,2)
10623       vv(2)=pizda(2,1)+pizda(1,2)
10624       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10625       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10626 #ifdef MOMENT
10627         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10628 #else
10629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10630 #endif
10631       else
10632 #ifdef MOMENT
10633         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10634 #else
10635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10636 #endif
10637       endif
10638 C Derivatives in gamma(j-1) or gamma(l-1)
10639       if (l.eq.j+1 .and. l.gt.1) then
10640         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10641         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10642         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10643         vv(1)=pizda(1,1)-pizda(2,2)
10644         vv(2)=pizda(2,1)+pizda(1,2)
10645         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10646         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10647       else if (j.gt.1) then
10648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10651         vv(1)=pizda(1,1)-pizda(2,2)
10652         vv(2)=pizda(2,1)+pizda(1,2)
10653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10654         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10655           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10656         else
10657           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10658         endif
10659       endif
10660 C Cartesian derivatives.
10661       do iii=1,2
10662         do kkk=1,5
10663           do lll=1,3
10664 #ifdef MOMENT
10665             if (iii.eq.1) then
10666               if (imat.eq.1) then
10667                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10668               else
10669                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10670               endif
10671             else
10672               if (imat.eq.1) then
10673                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10674               else
10675                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10676               endif
10677             endif
10678 #endif
10679             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10680      &        auxvec(1))
10681             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10682             if (j.eq.l+1) then
10683               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10684      &          b1(1,j+1),auxvec(1))
10685               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10686             else
10687               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10688      &          b1(1,l+1),auxvec(1))
10689               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10690             endif
10691             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10692      &        pizda(1,1))
10693             vv(1)=pizda(1,1)-pizda(2,2)
10694             vv(2)=pizda(2,1)+pizda(1,2)
10695             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10696             if (swap) then
10697               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10698 #ifdef MOMENT
10699                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10700      &             -(s1+s2+s4)
10701 #else
10702                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10703      &             -(s2+s4)
10704 #endif
10705                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10706               else
10707 #ifdef MOMENT
10708                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10709 #else
10710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10711 #endif
10712                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10713               endif
10714             else
10715 #ifdef MOMENT
10716               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10717 #else
10718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10719 #endif
10720               if (l.eq.j+1) then
10721                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10722               else
10723                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10724               endif
10725             endif
10726           enddo
10727         enddo
10728       enddo
10729       return
10730       end
10731 c----------------------------------------------------------------------------
10732       double precision function eello_turn6(i,jj,kk)
10733       implicit real*8 (a-h,o-z)
10734       include 'DIMENSIONS'
10735       include 'COMMON.IOUNITS'
10736       include 'COMMON.CHAIN'
10737       include 'COMMON.DERIV'
10738       include 'COMMON.INTERACT'
10739       include 'COMMON.CONTACTS'
10740       include 'COMMON.TORSION'
10741       include 'COMMON.VAR'
10742       include 'COMMON.GEO'
10743       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10744      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10745      &  ggg1(3),ggg2(3)
10746       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10747      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10748 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10749 C           the respective energy moment and not to the cluster cumulant.
10750       s1=0.0d0
10751       s8=0.0d0
10752       s13=0.0d0
10753 c
10754       eello_turn6=0.0d0
10755       j=i+4
10756       k=i+1
10757       l=i+3
10758       iti=itype2loc(itype(i))
10759       itk=itype2loc(itype(k))
10760       itk1=itype2loc(itype(k+1))
10761       itl=itype2loc(itype(l))
10762       itj=itype2loc(itype(j))
10763 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10764 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10765 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10766 cd        eello6=0.0d0
10767 cd        return
10768 cd      endif
10769 cd      write (iout,*)
10770 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10771 cd     &   ' and',k,l
10772 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10773       do iii=1,2
10774         do kkk=1,5
10775           do lll=1,3
10776             derx_turn(lll,kkk,iii)=0.0d0
10777           enddo
10778         enddo
10779       enddo
10780 cd      eij=1.0d0
10781 cd      ekl=1.0d0
10782 cd      ekont=1.0d0
10783       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10784 cd      eello6_5=0.0d0
10785 cd      write (2,*) 'eello6_5',eello6_5
10786 #ifdef MOMENT
10787       call transpose2(AEA(1,1,1),auxmat(1,1))
10788       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10789       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10790       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10791 #endif
10792       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10793       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10794       s2 = scalar2(b1(1,k),vtemp1(1))
10795 #ifdef MOMENT
10796       call transpose2(AEA(1,1,2),atemp(1,1))
10797       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10798       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10799       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10800 #endif
10801       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10802       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10803       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10804 #ifdef MOMENT
10805       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10806       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10807       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10808       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10809       ss13 = scalar2(b1(1,k),vtemp4(1))
10810       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10811 #endif
10812 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10813 c      s1=0.0d0
10814 c      s2=0.0d0
10815 c      s8=0.0d0
10816 c      s12=0.0d0
10817 c      s13=0.0d0
10818       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10819 C Derivatives in gamma(i+2)
10820       s1d =0.0d0
10821       s8d =0.0d0
10822 #ifdef MOMENT
10823       call transpose2(AEA(1,1,1),auxmatd(1,1))
10824       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10825       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10826       call transpose2(AEAderg(1,1,2),atempd(1,1))
10827       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10828       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10829 #endif
10830       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10831       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10832       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10833 c      s1d=0.0d0
10834 c      s2d=0.0d0
10835 c      s8d=0.0d0
10836 c      s12d=0.0d0
10837 c      s13d=0.0d0
10838       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10839 C Derivatives in gamma(i+3)
10840 #ifdef MOMENT
10841       call transpose2(AEA(1,1,1),auxmatd(1,1))
10842       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10843       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10845 #endif
10846       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10847       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10848       s2d = scalar2(b1(1,k),vtemp1d(1))
10849 #ifdef MOMENT
10850       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10851       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10852 #endif
10853       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10854 #ifdef MOMENT
10855       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10856       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10857       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10858 #endif
10859 c      s1d=0.0d0
10860 c      s2d=0.0d0
10861 c      s8d=0.0d0
10862 c      s12d=0.0d0
10863 c      s13d=0.0d0
10864 #ifdef MOMENT
10865       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10866      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10867 #else
10868       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10869      &               -0.5d0*ekont*(s2d+s12d)
10870 #endif
10871 C Derivatives in gamma(i+4)
10872       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10873       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10875 #ifdef MOMENT
10876       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10877       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10878       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10879 #endif
10880 c      s1d=0.0d0
10881 c      s2d=0.0d0
10882 c      s8d=0.0d0
10883 C      s12d=0.0d0
10884 c      s13d=0.0d0
10885 #ifdef MOMENT
10886       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10887 #else
10888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10889 #endif
10890 C Derivatives in gamma(i+5)
10891 #ifdef MOMENT
10892       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10893       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10894       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10895 #endif
10896       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10897       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10898       s2d = scalar2(b1(1,k),vtemp1d(1))
10899 #ifdef MOMENT
10900       call transpose2(AEA(1,1,2),atempd(1,1))
10901       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10902       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10903 #endif
10904       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10906 #ifdef MOMENT
10907       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10908       ss13d = scalar2(b1(1,k),vtemp4d(1))
10909       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10910 #endif
10911 c      s1d=0.0d0
10912 c      s2d=0.0d0
10913 c      s8d=0.0d0
10914 c      s12d=0.0d0
10915 c      s13d=0.0d0
10916 #ifdef MOMENT
10917       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10918      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10919 #else
10920       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10921      &               -0.5d0*ekont*(s2d+s12d)
10922 #endif
10923 C Cartesian derivatives
10924       do iii=1,2
10925         do kkk=1,5
10926           do lll=1,3
10927 #ifdef MOMENT
10928             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10929             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10930             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10931 #endif
10932             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10933             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10934      &          vtemp1d(1))
10935             s2d = scalar2(b1(1,k),vtemp1d(1))
10936 #ifdef MOMENT
10937             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10938             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10939             s8d = -(atempd(1,1)+atempd(2,2))*
10940      &           scalar2(cc(1,1,l),vtemp2(1))
10941 #endif
10942             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10943      &           auxmatd(1,1))
10944             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10945             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10946 c      s1d=0.0d0
10947 c      s2d=0.0d0
10948 c      s8d=0.0d0
10949 c      s12d=0.0d0
10950 c      s13d=0.0d0
10951 #ifdef MOMENT
10952             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10953      &        - 0.5d0*(s1d+s2d)
10954 #else
10955             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10956      &        - 0.5d0*s2d
10957 #endif
10958 #ifdef MOMENT
10959             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10960      &        - 0.5d0*(s8d+s12d)
10961 #else
10962             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10963      &        - 0.5d0*s12d
10964 #endif
10965           enddo
10966         enddo
10967       enddo
10968 #ifdef MOMENT
10969       do kkk=1,5
10970         do lll=1,3
10971           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10972      &      achuj_tempd(1,1))
10973           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10974           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10975           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10976           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10977           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10978      &      vtemp4d(1))
10979           ss13d = scalar2(b1(1,k),vtemp4d(1))
10980           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10981           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10982         enddo
10983       enddo
10984 #endif
10985 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10986 cd     &  16*eel_turn6_num
10987 cd      goto 1112
10988       if (j.lt.nres-1) then
10989         j1=j+1
10990         j2=j-1
10991       else
10992         j1=j-1
10993         j2=j-2
10994       endif
10995       if (l.lt.nres-1) then
10996         l1=l+1
10997         l2=l-1
10998       else
10999         l1=l-1
11000         l2=l-2
11001       endif
11002       do ll=1,3
11003 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11004 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11005 cgrad        ghalf=0.5d0*ggg1(ll)
11006 cd        ghalf=0.0d0
11007         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11008         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11009         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11010      &    +ekont*derx_turn(ll,2,1)
11011         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11012         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11013      &    +ekont*derx_turn(ll,4,1)
11014         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11015         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11016         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11017 cgrad        ghalf=0.5d0*ggg2(ll)
11018 cd        ghalf=0.0d0
11019         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11020      &    +ekont*derx_turn(ll,2,2)
11021         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11022         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11023      &    +ekont*derx_turn(ll,4,2)
11024         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11025         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11026         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11027       enddo
11028 cd      goto 1112
11029 cgrad      do m=i+1,j-1
11030 cgrad        do ll=1,3
11031 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11032 cgrad        enddo
11033 cgrad      enddo
11034 cgrad      do m=k+1,l-1
11035 cgrad        do ll=1,3
11036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11037 cgrad        enddo
11038 cgrad      enddo
11039 cgrad1112  continue
11040 cgrad      do m=i+2,j2
11041 cgrad        do ll=1,3
11042 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11043 cgrad        enddo
11044 cgrad      enddo
11045 cgrad      do m=k+2,l2
11046 cgrad        do ll=1,3
11047 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11048 cgrad        enddo
11049 cgrad      enddo
11050 cd      do iii=1,nres-3
11051 cd        write (2,*) iii,g_corr6_loc(iii)
11052 cd      enddo
11053       eello_turn6=ekont*eel_turn6
11054 cd      write (2,*) 'ekont',ekont
11055 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11056       return
11057       end
11058
11059 C-----------------------------------------------------------------------------
11060       double precision function scalar(u,v)
11061 !DIR$ INLINEALWAYS scalar
11062 #ifndef OSF
11063 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11064 #endif
11065       implicit none
11066       double precision u(3),v(3)
11067 cd      double precision sc
11068 cd      integer i
11069 cd      sc=0.0d0
11070 cd      do i=1,3
11071 cd        sc=sc+u(i)*v(i)
11072 cd      enddo
11073 cd      scalar=sc
11074
11075       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11076       return
11077       end
11078 crc-------------------------------------------------
11079       SUBROUTINE MATVEC2(A1,V1,V2)
11080 !DIR$ INLINEALWAYS MATVEC2
11081 #ifndef OSF
11082 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11083 #endif
11084       implicit real*8 (a-h,o-z)
11085       include 'DIMENSIONS'
11086       DIMENSION A1(2,2),V1(2),V2(2)
11087 c      DO 1 I=1,2
11088 c        VI=0.0
11089 c        DO 3 K=1,2
11090 c    3     VI=VI+A1(I,K)*V1(K)
11091 c        Vaux(I)=VI
11092 c    1 CONTINUE
11093
11094       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11095       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11096
11097       v2(1)=vaux1
11098       v2(2)=vaux2
11099       END
11100 C---------------------------------------
11101       SUBROUTINE MATMAT2(A1,A2,A3)
11102 #ifndef OSF
11103 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11104 #endif
11105       implicit real*8 (a-h,o-z)
11106       include 'DIMENSIONS'
11107       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11108 c      DIMENSION AI3(2,2)
11109 c        DO  J=1,2
11110 c          A3IJ=0.0
11111 c          DO K=1,2
11112 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11113 c          enddo
11114 c          A3(I,J)=A3IJ
11115 c       enddo
11116 c      enddo
11117
11118       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11119       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11120       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11121       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11122
11123       A3(1,1)=AI3_11
11124       A3(2,1)=AI3_21
11125       A3(1,2)=AI3_12
11126       A3(2,2)=AI3_22
11127       END
11128
11129 c-------------------------------------------------------------------------
11130       double precision function scalar2(u,v)
11131 !DIR$ INLINEALWAYS scalar2
11132       implicit none
11133       double precision u(2),v(2)
11134       double precision sc
11135       integer i
11136       scalar2=u(1)*v(1)+u(2)*v(2)
11137       return
11138       end
11139
11140 C-----------------------------------------------------------------------------
11141
11142       subroutine transpose2(a,at)
11143 !DIR$ INLINEALWAYS transpose2
11144 #ifndef OSF
11145 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11146 #endif
11147       implicit none
11148       double precision a(2,2),at(2,2)
11149       at(1,1)=a(1,1)
11150       at(1,2)=a(2,1)
11151       at(2,1)=a(1,2)
11152       at(2,2)=a(2,2)
11153       return
11154       end
11155 c--------------------------------------------------------------------------
11156       subroutine transpose(n,a,at)
11157       implicit none
11158       integer n,i,j
11159       double precision a(n,n),at(n,n)
11160       do i=1,n
11161         do j=1,n
11162           at(j,i)=a(i,j)
11163         enddo
11164       enddo
11165       return
11166       end
11167 C---------------------------------------------------------------------------
11168       subroutine prodmat3(a1,a2,kk,transp,prod)
11169 !DIR$ INLINEALWAYS prodmat3
11170 #ifndef OSF
11171 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11172 #endif
11173       implicit none
11174       integer i,j
11175       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11176       logical transp
11177 crc      double precision auxmat(2,2),prod_(2,2)
11178
11179       if (transp) then
11180 crc        call transpose2(kk(1,1),auxmat(1,1))
11181 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11182 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11183
11184            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11185      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11186            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11187      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11188            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11189      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11190            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11191      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11192
11193       else
11194 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11195 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11196
11197            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11198      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11199            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11200      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11201            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11202      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11203            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11204      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11205
11206       endif
11207 c      call transpose2(a2(1,1),a2t(1,1))
11208
11209 crc      print *,transp
11210 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11211 crc      print *,((prod(i,j),i=1,2),j=1,2)
11212
11213       return
11214       end
11215 CCC----------------------------------------------
11216       subroutine Eliptransfer(eliptran)
11217       implicit real*8 (a-h,o-z)
11218       include 'DIMENSIONS'
11219       include 'COMMON.GEO'
11220       include 'COMMON.VAR'
11221       include 'COMMON.LOCAL'
11222       include 'COMMON.CHAIN'
11223       include 'COMMON.DERIV'
11224       include 'COMMON.NAMES'
11225       include 'COMMON.INTERACT'
11226       include 'COMMON.IOUNITS'
11227       include 'COMMON.CALC'
11228       include 'COMMON.CONTROL'
11229       include 'COMMON.SPLITELE'
11230       include 'COMMON.SBRIDGE'
11231 C this is done by Adasko
11232 C      print *,"wchodze"
11233 C structure of box:
11234 C      water
11235 C--bordliptop-- buffore starts
11236 C--bufliptop--- here true lipid starts
11237 C      lipid
11238 C--buflipbot--- lipid ends buffore starts
11239 C--bordlipbot--buffore ends
11240       eliptran=0.0
11241       do i=ilip_start,ilip_end
11242 C       do i=1,1
11243         if (itype(i).eq.ntyp1) cycle
11244
11245         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11246         if (positi.le.0.0) positi=positi+boxzsize
11247 C        print *,i
11248 C first for peptide groups
11249 c for each residue check if it is in lipid or lipid water border area
11250        if ((positi.gt.bordlipbot)
11251      &.and.(positi.lt.bordliptop)) then
11252 C the energy transfer exist
11253         if (positi.lt.buflipbot) then
11254 C what fraction I am in
11255          fracinbuf=1.0d0-
11256      &        ((positi-bordlipbot)/lipbufthick)
11257 C lipbufthick is thickenes of lipid buffore
11258          sslip=sscalelip(fracinbuf)
11259          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11260          eliptran=eliptran+sslip*pepliptran
11261          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11262          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11263 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11264
11265 C        print *,"doing sccale for lower part"
11266 C         print *,i,sslip,fracinbuf,ssgradlip
11267         elseif (positi.gt.bufliptop) then
11268          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11269          sslip=sscalelip(fracinbuf)
11270          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11271          eliptran=eliptran+sslip*pepliptran
11272          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11273          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11274 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11275 C          print *, "doing sscalefor top part"
11276 C         print *,i,sslip,fracinbuf,ssgradlip
11277         else
11278          eliptran=eliptran+pepliptran
11279 C         print *,"I am in true lipid"
11280         endif
11281 C       else
11282 C       eliptran=elpitran+0.0 ! I am in water
11283        endif
11284        enddo
11285 C       print *, "nic nie bylo w lipidzie?"
11286 C now multiply all by the peptide group transfer factor
11287 C       eliptran=eliptran*pepliptran
11288 C now the same for side chains
11289 CV       do i=1,1
11290        do i=ilip_start,ilip_end
11291         if (itype(i).eq.ntyp1) cycle
11292         positi=(mod(c(3,i+nres),boxzsize))
11293         if (positi.le.0) positi=positi+boxzsize
11294 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11295 c for each residue check if it is in lipid or lipid water border area
11296 C       respos=mod(c(3,i+nres),boxzsize)
11297 C       print *,positi,bordlipbot,buflipbot
11298        if ((positi.gt.bordlipbot)
11299      & .and.(positi.lt.bordliptop)) then
11300 C the energy transfer exist
11301         if (positi.lt.buflipbot) then
11302          fracinbuf=1.0d0-
11303      &     ((positi-bordlipbot)/lipbufthick)
11304 C lipbufthick is thickenes of lipid buffore
11305          sslip=sscalelip(fracinbuf)
11306          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11307          eliptran=eliptran+sslip*liptranene(itype(i))
11308          gliptranx(3,i)=gliptranx(3,i)
11309      &+ssgradlip*liptranene(itype(i))
11310          gliptranc(3,i-1)= gliptranc(3,i-1)
11311      &+ssgradlip*liptranene(itype(i))
11312 C         print *,"doing sccale for lower part"
11313         elseif (positi.gt.bufliptop) then
11314          fracinbuf=1.0d0-
11315      &((bordliptop-positi)/lipbufthick)
11316          sslip=sscalelip(fracinbuf)
11317          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11318          eliptran=eliptran+sslip*liptranene(itype(i))
11319          gliptranx(3,i)=gliptranx(3,i)
11320      &+ssgradlip*liptranene(itype(i))
11321          gliptranc(3,i-1)= gliptranc(3,i-1)
11322      &+ssgradlip*liptranene(itype(i))
11323 C          print *, "doing sscalefor top part",sslip,fracinbuf
11324         else
11325          eliptran=eliptran+liptranene(itype(i))
11326 C         print *,"I am in true lipid"
11327         endif
11328         endif ! if in lipid or buffor
11329 C       else
11330 C       eliptran=elpitran+0.0 ! I am in water
11331        enddo
11332        return
11333        end
11334 C---------------------------------------------------------
11335 C AFM soubroutine for constant force
11336        subroutine AFMforce(Eafmforce)
11337        implicit real*8 (a-h,o-z)
11338       include 'DIMENSIONS'
11339       include 'COMMON.GEO'
11340       include 'COMMON.VAR'
11341       include 'COMMON.LOCAL'
11342       include 'COMMON.CHAIN'
11343       include 'COMMON.DERIV'
11344       include 'COMMON.NAMES'
11345       include 'COMMON.INTERACT'
11346       include 'COMMON.IOUNITS'
11347       include 'COMMON.CALC'
11348       include 'COMMON.CONTROL'
11349       include 'COMMON.SPLITELE'
11350       include 'COMMON.SBRIDGE'
11351       real*8 diffafm(3)
11352       dist=0.0d0
11353       Eafmforce=0.0d0
11354       do i=1,3
11355       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11356       dist=dist+diffafm(i)**2
11357       enddo
11358       dist=dsqrt(dist)
11359       Eafmforce=-forceAFMconst*(dist-distafminit)
11360       do i=1,3
11361       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11362       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11363       enddo
11364 C      print *,'AFM',Eafmforce
11365       return
11366       end
11367 C---------------------------------------------------------
11368 C AFM subroutine with pseudoconstant velocity
11369        subroutine AFMvel(Eafmforce)
11370        implicit real*8 (a-h,o-z)
11371       include 'DIMENSIONS'
11372       include 'COMMON.GEO'
11373       include 'COMMON.VAR'
11374       include 'COMMON.LOCAL'
11375       include 'COMMON.CHAIN'
11376       include 'COMMON.DERIV'
11377       include 'COMMON.NAMES'
11378       include 'COMMON.INTERACT'
11379       include 'COMMON.IOUNITS'
11380       include 'COMMON.CALC'
11381       include 'COMMON.CONTROL'
11382       include 'COMMON.SPLITELE'
11383       include 'COMMON.SBRIDGE'
11384       real*8 diffafm(3)
11385 C Only for check grad COMMENT if not used for checkgrad
11386 C      totT=3.0d0
11387 C--------------------------------------------------------
11388 C      print *,"wchodze"
11389       dist=0.0d0
11390       Eafmforce=0.0d0
11391       do i=1,3
11392       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11393       dist=dist+diffafm(i)**2
11394       enddo
11395       dist=dsqrt(dist)
11396       Eafmforce=0.5d0*forceAFMconst
11397      & *(distafminit+totTafm*velAFMconst-dist)**2
11398 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11399       do i=1,3
11400       gradafm(i,afmend-1)=-forceAFMconst*
11401      &(distafminit+totTafm*velAFMconst-dist)
11402      &*diffafm(i)/dist
11403       gradafm(i,afmbeg-1)=forceAFMconst*
11404      &(distafminit+totTafm*velAFMconst-dist)
11405      &*diffafm(i)/dist
11406       enddo
11407 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11408       return
11409       end
11410 C-----------------------------------------------------------
11411 C first for shielding is setting of function of side-chains
11412        subroutine set_shield_fac
11413       implicit real*8 (a-h,o-z)
11414       include 'DIMENSIONS'
11415       include 'COMMON.CHAIN'
11416       include 'COMMON.DERIV'
11417       include 'COMMON.IOUNITS'
11418       include 'COMMON.SHIELD'
11419       include 'COMMON.INTERACT'
11420 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11421       double precision div77_81/0.974996043d0/,
11422      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11423
11424 C the vector between center of side_chain and peptide group
11425        double precision pep_side(3),long,side_calf(3),
11426      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11427      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11428 C the line belowe needs to be changed for FGPROC>1
11429       do i=1,nres-1
11430       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11431       ishield_list(i)=0
11432 Cif there two consequtive dummy atoms there is no peptide group between them
11433 C the line below has to be changed for FGPROC>1
11434       VolumeTotal=0.0
11435       do k=1,nres
11436        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11437        dist_pep_side=0.0
11438        dist_side_calf=0.0
11439        do j=1,3
11440 C first lets set vector conecting the ithe side-chain with kth side-chain
11441       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11442 C      pep_side(j)=2.0d0
11443 C and vector conecting the side-chain with its proper calfa
11444       side_calf(j)=c(j,k+nres)-c(j,k)
11445 C      side_calf(j)=2.0d0
11446       pept_group(j)=c(j,i)-c(j,i+1)
11447 C lets have their lenght
11448       dist_pep_side=pep_side(j)**2+dist_pep_side
11449       dist_side_calf=dist_side_calf+side_calf(j)**2
11450       dist_pept_group=dist_pept_group+pept_group(j)**2
11451       enddo
11452        dist_pep_side=dsqrt(dist_pep_side)
11453        dist_pept_group=dsqrt(dist_pept_group)
11454        dist_side_calf=dsqrt(dist_side_calf)
11455       do j=1,3
11456         pep_side_norm(j)=pep_side(j)/dist_pep_side
11457         side_calf_norm(j)=dist_side_calf
11458       enddo
11459 C now sscale fraction
11460        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11461 C       print *,buff_shield,"buff"
11462 C now sscale
11463         if (sh_frac_dist.le.0.0) cycle
11464 C If we reach here it means that this side chain reaches the shielding sphere
11465 C Lets add him to the list for gradient
11466         ishield_list(i)=ishield_list(i)+1
11467 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11468 C this list is essential otherwise problem would be O3
11469         shield_list(ishield_list(i),i)=k
11470 C Lets have the sscale value
11471         if (sh_frac_dist.gt.1.0) then
11472          scale_fac_dist=1.0d0
11473          do j=1,3
11474          sh_frac_dist_grad(j)=0.0d0
11475          enddo
11476         else
11477          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11478      &                   *(2.0*sh_frac_dist-3.0d0)
11479          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11480      &                  /dist_pep_side/buff_shield*0.5
11481 C remember for the final gradient multiply sh_frac_dist_grad(j)
11482 C for side_chain by factor -2 !
11483          do j=1,3
11484          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11485 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11486 C     &                    sh_frac_dist_grad(j)
11487          enddo
11488         endif
11489 C        if ((i.eq.3).and.(k.eq.2)) then
11490 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11491 C     & ,"TU"
11492 C        endif
11493
11494 C this is what is now we have the distance scaling now volume...
11495       short=short_r_sidechain(itype(k))
11496       long=long_r_sidechain(itype(k))
11497       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11498 C now costhet_grad
11499 C       costhet=0.0d0
11500        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11501 C       costhet_fac=0.0d0
11502        do j=1,3
11503          costhet_grad(j)=costhet_fac*pep_side(j)
11504        enddo
11505 C remember for the final gradient multiply costhet_grad(j)
11506 C for side_chain by factor -2 !
11507 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11508 C pep_side0pept_group is vector multiplication
11509       pep_side0pept_group=0.0
11510       do j=1,3
11511       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11512       enddo
11513       cosalfa=(pep_side0pept_group/
11514      & (dist_pep_side*dist_side_calf))
11515       fac_alfa_sin=1.0-cosalfa**2
11516       fac_alfa_sin=dsqrt(fac_alfa_sin)
11517       rkprim=fac_alfa_sin*(long-short)+short
11518 C now costhet_grad
11519        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11520        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11521
11522        do j=1,3
11523          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11524      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11525      &*(long-short)/fac_alfa_sin*cosalfa/
11526      &((dist_pep_side*dist_side_calf))*
11527      &((side_calf(j))-cosalfa*
11528      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11529
11530         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11531      &*(long-short)/fac_alfa_sin*cosalfa
11532      &/((dist_pep_side*dist_side_calf))*
11533      &(pep_side(j)-
11534      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11535        enddo
11536
11537       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11538      &                    /VSolvSphere_div
11539      &                    *wshield
11540 C now the gradient...
11541 C grad_shield is gradient of Calfa for peptide groups
11542 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11543 C     &               costhet,cosphi
11544 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11545 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11546       do j=1,3
11547       grad_shield(j,i)=grad_shield(j,i)
11548 C gradient po skalowaniu
11549      &                +(sh_frac_dist_grad(j)
11550 C  gradient po costhet
11551      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11552      &-scale_fac_dist*(cosphi_grad_long(j))
11553      &/(1.0-cosphi) )*div77_81
11554      &*VofOverlap
11555 C grad_shield_side is Cbeta sidechain gradient
11556       grad_shield_side(j,ishield_list(i),i)=
11557      &        (sh_frac_dist_grad(j)*(-2.0d0)
11558      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11559      &       +scale_fac_dist*(cosphi_grad_long(j))
11560      &        *2.0d0/(1.0-cosphi))
11561      &        *div77_81*VofOverlap
11562
11563        grad_shield_loc(j,ishield_list(i),i)=
11564      &   scale_fac_dist*cosphi_grad_loc(j)
11565      &        *2.0d0/(1.0-cosphi)
11566      &        *div77_81*VofOverlap
11567       enddo
11568       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11569       enddo
11570       fac_shield(i)=VolumeTotal*div77_81+div4_81
11571 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11572       enddo
11573       return
11574       end
11575 C--------------------------------------------------------------------------
11576       double precision function tschebyshev(m,n,x,y)
11577       implicit none
11578       include "DIMENSIONS"
11579       integer i,m,n
11580       double precision x(n),y,yy(0:maxvar),aux
11581 c Tschebyshev polynomial. Note that the first term is omitted
11582 c m=0: the constant term is included
11583 c m=1: the constant term is not included
11584       yy(0)=1.0d0
11585       yy(1)=y
11586       do i=2,n
11587         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11588       enddo
11589       aux=0.0d0
11590       do i=m,n
11591         aux=aux+x(i)*yy(i)
11592       enddo
11593       tschebyshev=aux
11594       return
11595       end
11596 C--------------------------------------------------------------------------
11597       double precision function gradtschebyshev(m,n,x,y)
11598       implicit none
11599       include "DIMENSIONS"
11600       integer i,m,n
11601       double precision x(n+1),y,yy(0:maxvar),aux
11602 c Tschebyshev polynomial. Note that the first term is omitted
11603 c m=0: the constant term is included
11604 c m=1: the constant term is not included
11605       yy(0)=1.0d0
11606       yy(1)=2.0d0*y
11607       do i=2,n
11608         yy(i)=2*y*yy(i-1)-yy(i-2)
11609       enddo
11610       aux=0.0d0
11611       do i=m,n
11612         aux=aux+x(i+1)*yy(i)*(i+1)
11613 C        print *, x(i+1),yy(i),i
11614       enddo
11615       gradtschebyshev=aux
11616       return
11617       end
11618 C------------------------------------------------------------------------
11619 C first for shielding is setting of function of side-chains
11620        subroutine set_shield_fac2
11621       implicit real*8 (a-h,o-z)
11622       include 'DIMENSIONS'
11623       include 'COMMON.CHAIN'
11624       include 'COMMON.DERIV'
11625       include 'COMMON.IOUNITS'
11626       include 'COMMON.SHIELD'
11627       include 'COMMON.INTERACT'
11628 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11629       double precision div77_81/0.974996043d0/,
11630      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11631
11632 C the vector between center of side_chain and peptide group
11633        double precision pep_side(3),long,side_calf(3),
11634      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11635      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11636 C the line belowe needs to be changed for FGPROC>1
11637       do i=1,nres-1
11638       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11639       ishield_list(i)=0
11640 Cif there two consequtive dummy atoms there is no peptide group between them
11641 C the line below has to be changed for FGPROC>1
11642       VolumeTotal=0.0
11643       do k=1,nres
11644        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11645        dist_pep_side=0.0
11646        dist_side_calf=0.0
11647        do j=1,3
11648 C first lets set vector conecting the ithe side-chain with kth side-chain
11649       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11650 C      pep_side(j)=2.0d0
11651 C and vector conecting the side-chain with its proper calfa
11652       side_calf(j)=c(j,k+nres)-c(j,k)
11653 C      side_calf(j)=2.0d0
11654       pept_group(j)=c(j,i)-c(j,i+1)
11655 C lets have their lenght
11656       dist_pep_side=pep_side(j)**2+dist_pep_side
11657       dist_side_calf=dist_side_calf+side_calf(j)**2
11658       dist_pept_group=dist_pept_group+pept_group(j)**2
11659       enddo
11660        dist_pep_side=dsqrt(dist_pep_side)
11661        dist_pept_group=dsqrt(dist_pept_group)
11662        dist_side_calf=dsqrt(dist_side_calf)
11663       do j=1,3
11664         pep_side_norm(j)=pep_side(j)/dist_pep_side
11665         side_calf_norm(j)=dist_side_calf
11666       enddo
11667 C now sscale fraction
11668        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11669 C       print *,buff_shield,"buff"
11670 C now sscale
11671         if (sh_frac_dist.le.0.0) cycle
11672 C If we reach here it means that this side chain reaches the shielding sphere
11673 C Lets add him to the list for gradient
11674         ishield_list(i)=ishield_list(i)+1
11675 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11676 C this list is essential otherwise problem would be O3
11677         shield_list(ishield_list(i),i)=k
11678 C Lets have the sscale value
11679         if (sh_frac_dist.gt.1.0) then
11680          scale_fac_dist=1.0d0
11681          do j=1,3
11682          sh_frac_dist_grad(j)=0.0d0
11683          enddo
11684         else
11685          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11686      &                   *(2.0d0*sh_frac_dist-3.0d0)
11687          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11688      &                  /dist_pep_side/buff_shield*0.5d0
11689 C remember for the final gradient multiply sh_frac_dist_grad(j)
11690 C for side_chain by factor -2 !
11691          do j=1,3
11692          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11693 C         sh_frac_dist_grad(j)=0.0d0
11694 C         scale_fac_dist=1.0d0
11695 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11696 C     &                    sh_frac_dist_grad(j)
11697          enddo
11698         endif
11699 C this is what is now we have the distance scaling now volume...
11700       short=short_r_sidechain(itype(k))
11701       long=long_r_sidechain(itype(k))
11702       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11703       sinthet=short/dist_pep_side*costhet
11704 C now costhet_grad
11705 C       costhet=0.6d0
11706 C       sinthet=0.8
11707        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11708 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11709 C     &             -short/dist_pep_side**2/costhet)
11710 C       costhet_fac=0.0d0
11711        do j=1,3
11712          costhet_grad(j)=costhet_fac*pep_side(j)
11713        enddo
11714 C remember for the final gradient multiply costhet_grad(j)
11715 C for side_chain by factor -2 !
11716 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11717 C pep_side0pept_group is vector multiplication
11718       pep_side0pept_group=0.0d0
11719       do j=1,3
11720       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11721       enddo
11722       cosalfa=(pep_side0pept_group/
11723      & (dist_pep_side*dist_side_calf))
11724       fac_alfa_sin=1.0d0-cosalfa**2
11725       fac_alfa_sin=dsqrt(fac_alfa_sin)
11726       rkprim=fac_alfa_sin*(long-short)+short
11727 C      rkprim=short
11728
11729 C now costhet_grad
11730        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11731 C       cosphi=0.6
11732        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11733        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11734      &      dist_pep_side**2)
11735 C       sinphi=0.8
11736        do j=1,3
11737          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11738      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11739      &*(long-short)/fac_alfa_sin*cosalfa/
11740      &((dist_pep_side*dist_side_calf))*
11741      &((side_calf(j))-cosalfa*
11742      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11743 C       cosphi_grad_long(j)=0.0d0
11744         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11745      &*(long-short)/fac_alfa_sin*cosalfa
11746      &/((dist_pep_side*dist_side_calf))*
11747      &(pep_side(j)-
11748      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11749 C       cosphi_grad_loc(j)=0.0d0
11750        enddo
11751 C      print *,sinphi,sinthet
11752 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
11753 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
11754       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11755      &                    /VSolvSphere_div
11756 C     &                    *wshield
11757 C now the gradient...
11758       do j=1,3
11759       grad_shield(j,i)=grad_shield(j,i)
11760 C gradient po skalowaniu
11761      &                +(sh_frac_dist_grad(j)*VofOverlap
11762 C  gradient po costhet
11763      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11764      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11765      &       sinphi/sinthet*costhet*costhet_grad(j)
11766      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11767      & )*wshield
11768 C grad_shield_side is Cbeta sidechain gradient
11769       grad_shield_side(j,ishield_list(i),i)=
11770      &        (sh_frac_dist_grad(j)*(-2.0d0)
11771      &        *VofOverlap
11772      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11773      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11774      &       sinphi/sinthet*costhet*costhet_grad(j)
11775      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11776      &       )*wshield
11777
11778        grad_shield_loc(j,ishield_list(i),i)=
11779      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11780      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11781      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11782      &        ))
11783      &        *wshield
11784       enddo
11785 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
11786 c     & scale_fac_dist
11787       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11788       enddo
11789       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11790 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
11791 c     &  " wshield",wshield
11792 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11793       enddo
11794       return
11795       end
11796 C-----------------------------------------------------------------------
11797 C-----------------------------------------------------------
11798 C This subroutine is to mimic the histone like structure but as well can be
11799 C utilizet to nanostructures (infinit) small modification has to be used to
11800 C make it finite (z gradient at the ends has to be changes as well as the x,y
11801 C gradient has to be modified at the ends
11802 C The energy function is Kihara potential
11803 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11804 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11805 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11806 C simple Kihara potential
11807       subroutine calctube(Etube)
11808        implicit real*8 (a-h,o-z)
11809       include 'DIMENSIONS'
11810       include 'COMMON.GEO'
11811       include 'COMMON.VAR'
11812       include 'COMMON.LOCAL'
11813       include 'COMMON.CHAIN'
11814       include 'COMMON.DERIV'
11815       include 'COMMON.NAMES'
11816       include 'COMMON.INTERACT'
11817       include 'COMMON.IOUNITS'
11818       include 'COMMON.CALC'
11819       include 'COMMON.CONTROL'
11820       include 'COMMON.SPLITELE'
11821       include 'COMMON.SBRIDGE'
11822       double precision tub_r,vectube(3),enetube(maxres*2)
11823       Etube=0.0d0
11824       do i=1,2*nres
11825         enetube(i)=0.0d0
11826       enddo
11827 C first we calculate the distance from tube center
11828 C first sugare-phosphate group for NARES this would be peptide group
11829 C for UNRES
11830       do i=1,nres
11831 C lets ommit dummy atoms for now
11832        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11833 C now calculate distance from center of tube and direction vectors
11834       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11835           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11836       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11837           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11838       vectube(1)=vectube(1)-tubecenter(1)
11839       vectube(2)=vectube(2)-tubecenter(2)
11840
11841 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11842 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11843
11844 C as the tube is infinity we do not calculate the Z-vector use of Z
11845 C as chosen axis
11846       vectube(3)=0.0d0
11847 C now calculte the distance
11848        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11849 C now normalize vector
11850       vectube(1)=vectube(1)/tub_r
11851       vectube(2)=vectube(2)/tub_r
11852 C calculte rdiffrence between r and r0
11853       rdiff=tub_r-tubeR0
11854 C and its 6 power
11855       rdiff6=rdiff**6.0d0
11856 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11857        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11858 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11859 C       print *,rdiff,rdiff6,pep_aa_tube
11860 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11861 C now we calculate gradient
11862        fac=(-12.0d0*pep_aa_tube/rdiff6+
11863      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11864 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11865 C     &rdiff,fac
11866
11867 C now direction of gg_tube vector
11868         do j=1,3
11869         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11870         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11871         enddo
11872         enddo
11873 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11874         do i=1,nres
11875 C Lets not jump over memory as we use many times iti
11876          iti=itype(i)
11877 C lets ommit dummy atoms for now
11878          if ((iti.eq.ntyp1)
11879 C in UNRES uncomment the line below as GLY has no side-chain...
11880 C      .or.(iti.eq.10)
11881      &   ) cycle
11882           vectube(1)=c(1,i+nres)
11883           vectube(1)=mod(vectube(1),boxxsize)
11884           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11885           vectube(2)=c(2,i+nres)
11886           vectube(2)=mod(vectube(2),boxxsize)
11887           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11888
11889       vectube(1)=vectube(1)-tubecenter(1)
11890       vectube(2)=vectube(2)-tubecenter(2)
11891
11892 C as the tube is infinity we do not calculate the Z-vector use of Z
11893 C as chosen axis
11894       vectube(3)=0.0d0
11895 C now calculte the distance
11896        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11897 C now normalize vector
11898       vectube(1)=vectube(1)/tub_r
11899       vectube(2)=vectube(2)/tub_r
11900 C calculte rdiffrence between r and r0
11901       rdiff=tub_r-tubeR0
11902 C and its 6 power
11903       rdiff6=rdiff**6.0d0
11904 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11905        sc_aa_tube=sc_aa_tube_par(iti)
11906        sc_bb_tube=sc_bb_tube_par(iti)
11907        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11908 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11909 C now we calculate gradient
11910        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11911      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11912 C now direction of gg_tube vector
11913          do j=1,3
11914           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11915           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11916          enddo
11917         enddo
11918         do i=1,2*nres
11919           Etube=Etube+enetube(i)
11920         enddo
11921 C        print *,"ETUBE", etube
11922         return
11923         end
11924 C TO DO 1) add to total energy
11925 C       2) add to gradient summation
11926 C       3) add reading parameters (AND of course oppening of PARAM file)
11927 C       4) add reading the center of tube
11928 C       5) add COMMONs
11929 C       6) add to zerograd
11930
11931 C-----------------------------------------------------------------------
11932 C-----------------------------------------------------------
11933 C This subroutine is to mimic the histone like structure but as well can be
11934 C utilizet to nanostructures (infinit) small modification has to be used to
11935 C make it finite (z gradient at the ends has to be changes as well as the x,y
11936 C gradient has to be modified at the ends
11937 C The energy function is Kihara potential
11938 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11939 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11940 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11941 C simple Kihara potential
11942       subroutine calctube2(Etube)
11943        implicit real*8 (a-h,o-z)
11944       include 'DIMENSIONS'
11945       include 'COMMON.GEO'
11946       include 'COMMON.VAR'
11947       include 'COMMON.LOCAL'
11948       include 'COMMON.CHAIN'
11949       include 'COMMON.DERIV'
11950       include 'COMMON.NAMES'
11951       include 'COMMON.INTERACT'
11952       include 'COMMON.IOUNITS'
11953       include 'COMMON.CALC'
11954       include 'COMMON.CONTROL'
11955       include 'COMMON.SPLITELE'
11956       include 'COMMON.SBRIDGE'
11957       double precision tub_r,vectube(3),enetube(maxres*2)
11958       Etube=0.0d0
11959       do i=1,2*nres
11960         enetube(i)=0.0d0
11961       enddo
11962 C first we calculate the distance from tube center
11963 C first sugare-phosphate group for NARES this would be peptide group
11964 C for UNRES
11965       do i=1,nres
11966 C lets ommit dummy atoms for now
11967        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11968 C now calculate distance from center of tube and direction vectors
11969       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11970           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11971       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11972           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11973       vectube(1)=vectube(1)-tubecenter(1)
11974       vectube(2)=vectube(2)-tubecenter(2)
11975
11976 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11977 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11978
11979 C as the tube is infinity we do not calculate the Z-vector use of Z
11980 C as chosen axis
11981       vectube(3)=0.0d0
11982 C now calculte the distance
11983        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11984 C now normalize vector
11985       vectube(1)=vectube(1)/tub_r
11986       vectube(2)=vectube(2)/tub_r
11987 C calculte rdiffrence between r and r0
11988       rdiff=tub_r-tubeR0
11989 C and its 6 power
11990       rdiff6=rdiff**6.0d0
11991 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11992        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11993 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11994 C       print *,rdiff,rdiff6,pep_aa_tube
11995 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11996 C now we calculate gradient
11997        fac=(-12.0d0*pep_aa_tube/rdiff6+
11998      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11999 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12000 C     &rdiff,fac
12001
12002 C now direction of gg_tube vector
12003         do j=1,3
12004         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12005         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12006         enddo
12007         enddo
12008 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12009         do i=1,nres
12010 C Lets not jump over memory as we use many times iti
12011          iti=itype(i)
12012 C lets ommit dummy atoms for now
12013          if ((iti.eq.ntyp1)
12014 C in UNRES uncomment the line below as GLY has no side-chain...
12015      &      .or.(iti.eq.10)
12016      &   ) cycle
12017           vectube(1)=c(1,i+nres)
12018           vectube(1)=mod(vectube(1),boxxsize)
12019           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12020           vectube(2)=c(2,i+nres)
12021           vectube(2)=mod(vectube(2),boxxsize)
12022           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12023
12024       vectube(1)=vectube(1)-tubecenter(1)
12025       vectube(2)=vectube(2)-tubecenter(2)
12026 C THIS FRAGMENT MAKES TUBE FINITE
12027         positi=(mod(c(3,i+nres),boxzsize))
12028         if (positi.le.0) positi=positi+boxzsize
12029 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12030 c for each residue check if it is in lipid or lipid water border area
12031 C       respos=mod(c(3,i+nres),boxzsize)
12032        print *,positi,bordtubebot,buftubebot,bordtubetop
12033        if ((positi.gt.bordtubebot)
12034      & .and.(positi.lt.bordtubetop)) then
12035 C the energy transfer exist
12036         if (positi.lt.buftubebot) then
12037          fracinbuf=1.0d0-
12038      &     ((positi-bordtubebot)/tubebufthick)
12039 C lipbufthick is thickenes of lipid buffore
12040          sstube=sscalelip(fracinbuf)
12041          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12042          print *,ssgradtube, sstube,tubetranene(itype(i))
12043          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12044          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12045      &+ssgradtube*tubetranene(itype(i))
12046          gg_tube(3,i-1)= gg_tube(3,i-1)
12047      &+ssgradtube*tubetranene(itype(i))
12048 C         print *,"doing sccale for lower part"
12049         elseif (positi.gt.buftubetop) then
12050          fracinbuf=1.0d0-
12051      &((bordtubetop-positi)/tubebufthick)
12052          sstube=sscalelip(fracinbuf)
12053          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12054          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12055 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12056 C     &+ssgradtube*tubetranene(itype(i))
12057 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12058 C     &+ssgradtube*tubetranene(itype(i))
12059 C          print *, "doing sscalefor top part",sslip,fracinbuf
12060         else
12061          sstube=1.0d0
12062          ssgradtube=0.0d0
12063          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12064 C         print *,"I am in true lipid"
12065         endif
12066         else
12067 C          sstube=0.0d0
12068 C          ssgradtube=0.0d0
12069         cycle
12070         endif ! if in lipid or buffor
12071 CEND OF FINITE FRAGMENT
12072 C as the tube is infinity we do not calculate the Z-vector use of Z
12073 C as chosen axis
12074       vectube(3)=0.0d0
12075 C now calculte the distance
12076        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12077 C now normalize vector
12078       vectube(1)=vectube(1)/tub_r
12079       vectube(2)=vectube(2)/tub_r
12080 C calculte rdiffrence between r and r0
12081       rdiff=tub_r-tubeR0
12082 C and its 6 power
12083       rdiff6=rdiff**6.0d0
12084 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12085        sc_aa_tube=sc_aa_tube_par(iti)
12086        sc_bb_tube=sc_bb_tube_par(iti)
12087        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12088      &                 *sstube+enetube(i+nres)
12089 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12090 C now we calculate gradient
12091        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12092      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12093 C now direction of gg_tube vector
12094          do j=1,3
12095           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12096           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12097          enddo
12098          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12099      &+ssgradtube*enetube(i+nres)/sstube
12100          gg_tube(3,i-1)= gg_tube(3,i-1)
12101      &+ssgradtube*enetube(i+nres)/sstube
12102
12103         enddo
12104         do i=1,2*nres
12105           Etube=Etube+enetube(i)
12106         enddo
12107 C        print *,"ETUBE", etube
12108         return
12109         end
12110 C TO DO 1) add to total energy
12111 C       2) add to gradient summation
12112 C       3) add reading parameters (AND of course oppening of PARAM file)
12113 C       4) add reading the center of tube
12114 C       5) add COMMONs
12115 C       6) add to zerograd
12116