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 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.eq.1) then
 146        call set_shield_fac
 147       else if  (shield_mode.eq.2) then
 148        call set_shield_fac2
 149       endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172         write (iout,*) "Soft-spheer ELEC potential"
 173 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174 c     &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 207         call ebend(ebe,ethetacnstr)
 208         endif
 209 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 210 C energy function
 211        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 212          call ebend_kcc(ebe,ethetacnstr)
 213         endif
 214       else
 215         ebe=0
 216         ethetacnstr=0
 217       endif
 218 c      print *,"Processor",myrank," computed UB"
 219 C
 220 C Calculate the SC local energy.
 221 C
 222 C      print *,"TU DOCHODZE?"
 223       call esc(escloc)
 224 c      print *,"Processor",myrank," computed USC"
 225 C
 226 C Calculate the virtual-bond torsional energy.
 227 C
 228 cd    print *,'nterm=',nterm
 229 C      print *,"tor",tor_mode
 230       if (wtor.gt.0) then
 231        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 232        call etor(etors,edihcnstr)
 233        endif
 234 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 235 C energy function
 236        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 237        call etor_kcc(etors,edihcnstr)
 238        endif
 239       else
 240        etors=0
 241        edihcnstr=0
 242       endif
 243 c      print *,"Processor",myrank," computed Utor"
 244 C
 245 C 6/23/01 Calculate double-torsional energy
 246 C
 247       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 248        call etor_d(etors_d)
 249       else
 250        etors_d=0
 251       endif
 252 c      print *,"Processor",myrank," computed Utord"
 253 C
 254 C 21/5/07 Calculate local sicdechain correlation energy
 255 C
 256       if (wsccor.gt.0.0d0) then
 257         call eback_sc_corr(esccor)
 258       else
 259         esccor=0.0d0
 260       endif
 261 C      print *,"PRZED MULIt"
 262 c      print *,"Processor",myrank," computed Usccorr"
 263 C
 264 C 12/1/95 Multi-body terms
 265 C
 266       n_corr=0
 267       n_corr1=0
 268       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 269      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 270          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 271 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 272 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 273       else
 274          ecorr=0.0d0
 275          ecorr5=0.0d0
 276          ecorr6=0.0d0
 277          eturn6=0.0d0
 278       endif
 279       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 280          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 281 cd         write (iout,*) "multibody_hb ecorr",ecorr
 282       endif
 283 c      print *,"Processor",myrank," computed Ucorr"
 284 C
 285 C If performing constraint dynamics, call the constraint energy
 286 C  after the equilibration time
 287       if(usampl.and.totT.gt.eq_time) then
 288          call EconstrQ
 289          call Econstr_back
 290       else
 291          Uconst=0.0d0
 292          Uconst_back=0.0d0
 293       endif
 294 C 01/27/2015 added by adasko
 295 C the energy component below is energy transfer into lipid environment
 296 C based on partition function
 297 C      print *,"przed lipidami"
 298       if (wliptran.gt.0) then
 299         call Eliptransfer(eliptran)
 300       endif
 301 C      print *,"za lipidami"
 302       if (AFMlog.gt.0) then
 303         call AFMforce(Eafmforce)
 304       else if (selfguide.gt.0) then
 305         call AFMvel(Eafmforce)
 306       endif
 307 #ifdef TIMING
 308       time_enecalc=time_enecalc+MPI_Wtime()-time00
 309 #endif
 310 c      print *,"Processor",myrank," computed Uconstr"
 311 #ifdef TIMING
 312       time00=MPI_Wtime()
 313 #endif
 314 c
 315 C Sum the energies
 316 C
 317       energia(1)=evdw
 318 #ifdef SCP14
 319       energia(2)=evdw2-evdw2_14
 320       energia(18)=evdw2_14
 321 #else
 322       energia(2)=evdw2
 323       energia(18)=0.0d0
 324 #endif
 325 #ifdef SPLITELE
 326       energia(3)=ees
 327       energia(16)=evdw1
 328 #else
 329       energia(3)=ees+evdw1
 330       energia(16)=0.0d0
 331 #endif
 332       energia(4)=ecorr
 333       energia(5)=ecorr5
 334       energia(6)=ecorr6
 335       energia(7)=eel_loc
 336       energia(8)=eello_turn3
 337       energia(9)=eello_turn4
 338       energia(10)=eturn6
 339       energia(11)=ebe
 340       energia(12)=escloc
 341       energia(13)=etors
 342       energia(14)=etors_d
 343       energia(15)=ehpb
 344       energia(19)=edihcnstr
 345       energia(17)=estr
 346       energia(20)=Uconst+Uconst_back
 347       energia(21)=esccor
 348       energia(22)=eliptran
 349       energia(23)=Eafmforce
 350       energia(24)=ethetacnstr
 351 c    Here are the energies showed per procesor if the are more processors
 352 c    per molecule then we sum it up in sum_energy subroutine
 353 c      print *," Processor",myrank," calls SUM_ENERGY"
 354       call sum_energy(energia,.true.)
 355       if (dyn_ss) call dyn_set_nss
 356 c      print *," Processor",myrank," left SUM_ENERGY"
 357 #ifdef TIMING
 358       time_sumene=time_sumene+MPI_Wtime()-time00
 359 #endif
 360       return
 361       end
 362 c-------------------------------------------------------------------------------
 363       subroutine sum_energy(energia,reduce)
 364       implicit real*8 (a-h,o-z)
 365       include 'DIMENSIONS'
 366 #ifndef ISNAN
 367       external proc_proc
 368 #ifdef WINPGI
 369 cMS$ATTRIBUTES C ::  proc_proc
 370 #endif
 371 #endif
 372 #ifdef MPI
 373       include "mpif.h"
 374 #endif
 375       include 'COMMON.SETUP'
 376       include 'COMMON.IOUNITS'
 377       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 378       include 'COMMON.FFIELD'
 379       include 'COMMON.DERIV'
 380       include 'COMMON.INTERACT'
 381       include 'COMMON.SBRIDGE'
 382       include 'COMMON.CHAIN'
 383       include 'COMMON.VAR'
 384       include 'COMMON.CONTROL'
 385       include 'COMMON.TIME1'
 386       logical reduce
 387 #ifdef MPI
 388       if (nfgtasks.gt.1 .and. reduce) then
 389 #ifdef DEBUG
 390         write (iout,*) "energies before REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         do i=0,n_ene
 395           enebuff(i)=energia(i)
 396         enddo
 397         time00=MPI_Wtime()
 398         call MPI_Barrier(FG_COMM,IERR)
 399         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 400         time00=MPI_Wtime()
 401         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 402      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 403 #ifdef DEBUG
 404         write (iout,*) "energies after REDUCE"
 405         call enerprint(energia)
 406         call flush(iout)
 407 #endif
 408         time_Reduce=time_Reduce+MPI_Wtime()-time00
 409       endif
 410       if (fg_rank.eq.0) then
 411 #endif
 412       evdw=energia(1)
 413 #ifdef SCP14
 414       evdw2=energia(2)+energia(18)
 415       evdw2_14=energia(18)
 416 #else
 417       evdw2=energia(2)
 418 #endif
 419 #ifdef SPLITELE
 420       ees=energia(3)
 421       evdw1=energia(16)
 422 #else
 423       ees=energia(3)
 424       evdw1=0.0d0
 425 #endif
 426       ecorr=energia(4)
 427       ecorr5=energia(5)
 428       ecorr6=energia(6)
 429       eel_loc=energia(7)
 430       eello_turn3=energia(8)
 431       eello_turn4=energia(9)
 432       eturn6=energia(10)
 433       ebe=energia(11)
 434       escloc=energia(12)
 435       etors=energia(13)
 436       etors_d=energia(14)
 437       ehpb=energia(15)
 438       edihcnstr=energia(19)
 439       estr=energia(17)
 440       Uconst=energia(20)
 441       esccor=energia(21)
 442       eliptran=energia(22)
 443       Eafmforce=energia(23)
 444       ethetacnstr=energia(24)
 445 #ifdef SPLITELE
 446       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 447      & +wang*ebe+wtor*etors+wscloc*escloc
 448      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 449      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 450      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 451      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 452      & +ethetacnstr
 453 #else
 454       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 455      & +wang*ebe+wtor*etors+wscloc*escloc
 456      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 457      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 458      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 459      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 460      & +Eafmforce
 461      & +ethetacnstr
 462 #endif
 463       energia(0)=etot
 464 c detecting NaNQ
 465 #ifdef ISNAN
 466 #ifdef AIX
 467       if (isnan(etot).ne.0) energia(0)=1.0d+99
 468 #else
 469       if (isnan(etot)) energia(0)=1.0d+99
 470 #endif
 471 #else
 472       i=0
 473 #ifdef WINPGI
 474       idumm=proc_proc(etot,i)
 475 #else
 476       call proc_proc(etot,i)
 477 #endif
 478       if(i.eq.1)energia(0)=1.0d+99
 479 #endif
 480 #ifdef MPI
 481       endif
 482 #endif
 483       return
 484       end
 485 c-------------------------------------------------------------------------------
 486       subroutine sum_gradient
 487       implicit real*8 (a-h,o-z)
 488       include 'DIMENSIONS'
 489 #ifndef ISNAN
 490       external proc_proc
 491 #ifdef WINPGI
 492 cMS$ATTRIBUTES C ::  proc_proc
 493 #endif
 494 #endif
 495 #ifdef MPI
 496       include 'mpif.h'
 497 #endif
 498       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 499      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 500      & ,gloc_scbuf(3,-1:maxres)
 501       include 'COMMON.SETUP'
 502       include 'COMMON.IOUNITS'
 503       include 'COMMON.FFIELD'
 504       include 'COMMON.DERIV'
 505       include 'COMMON.INTERACT'
 506       include 'COMMON.SBRIDGE'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.VAR'
 509       include 'COMMON.CONTROL'
 510       include 'COMMON.TIME1'
 511       include 'COMMON.MAXGRAD'
 512       include 'COMMON.SCCOR'
 513 #ifdef TIMING
 514       time01=MPI_Wtime()
 515 #endif
 516 #ifdef DEBUG
 517       write (iout,*) "sum_gradient gvdwc, gvdwx"
 518       do i=1,nres
 519         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 520      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 521       enddo
 522       call flush(iout)
 523 #endif
 524 #ifdef MPI
 525 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 526         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 527      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 528 #endif
 529 C
 530 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 531 C            in virtual-bond-vector coordinates
 532 C
 533 #ifdef DEBUG
 534 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 535 c      do i=1,nres-1
 536 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 537 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 538 c      enddo
 539 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 540 c      do i=1,nres-1
 541 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 542 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 543 c      enddo
 544       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 545       do i=1,nres
 546         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 547      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 548      &   g_corr5_loc(i)
 549       enddo
 550       call flush(iout)
 551 #endif
 552 #ifdef SPLITELE
 553       do i=0,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564      &                +wliptran*gliptranc(j,i)
 565      &                +gradafm(j,i)
 566      &                 +welec*gshieldc(j,i)
 567      &                 +wcorr*gshieldc_ec(j,i)
 568      &                 +wturn3*gshieldc_t3(j,i)
 569      &                 +wturn4*gshieldc_t4(j,i)
 570      &                 +wel_loc*gshieldc_ll(j,i)
 571
 572
 573         enddo
 574       enddo
 575 #else
 576       do i=0,nct
 577         do j=1,3
 578           gradbufc(j,i)=wsc*gvdwc(j,i)+
 579      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 580      &                welec*gelc_long(j,i)+
 581      &                wbond*gradb(j,i)+
 582      &                wel_loc*gel_loc_long(j,i)+
 583      &                wcorr*gradcorr_long(j,i)+
 584      &                wcorr5*gradcorr5_long(j,i)+
 585      &                wcorr6*gradcorr6_long(j,i)+
 586      &                wturn6*gcorr6_turn_long(j,i)+
 587      &                wstrain*ghpbc(j,i)
 588      &                +wliptran*gliptranc(j,i)
 589      &                +gradafm(j,i)
 590      &                 +welec*gshieldc(j,i)
 591      &                 +wcorr*gshieldc_ec(j,i)
 592      &                 +wturn4*gshieldc_t4(j,i)
 593      &                 +wel_loc*gshieldc_ll(j,i)
 594
 595
 596         enddo
 597       enddo
 598 #endif
 599 #ifdef MPI
 600       if (nfgtasks.gt.1) then
 601       time00=MPI_Wtime()
 602 #ifdef DEBUG
 603       write (iout,*) "gradbufc before allreduce"
 604       do i=1,nres
 605         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 606       enddo
 607       call flush(iout)
 608 #endif
 609       do i=0,nres
 610         do j=1,3
 611           gradbufc_sum(j,i)=gradbufc(j,i)
 612         enddo
 613       enddo
 614 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 615 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 616 c      time_reduce=time_reduce+MPI_Wtime()-time00
 617 #ifdef DEBUG
 618 c      write (iout,*) "gradbufc_sum after allreduce"
 619 c      do i=1,nres
 620 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 621 c      enddo
 622 c      call flush(iout)
 623 #endif
 624 #ifdef TIMING
 625 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 626 #endif
 627       do i=nnt,nres
 628         do k=1,3
 629           gradbufc(k,i)=0.0d0
 630         enddo
 631       enddo
 632 #ifdef DEBUG
 633       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 634       write (iout,*) (i," jgrad_start",jgrad_start(i),
 635      &                  " jgrad_end  ",jgrad_end(i),
 636      &                  i=igrad_start,igrad_end)
 637 #endif
 638 c
 639 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 640 c do not parallelize this part.
 641 c
 642 c      do i=igrad_start,igrad_end
 643 c        do j=jgrad_start(i),jgrad_end(i)
 644 c          do k=1,3
 645 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 646 c          enddo
 647 c        enddo
 648 c      enddo
 649       do j=1,3
 650         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 651       enddo
 652       do i=nres-2,-1,-1
 653         do j=1,3
 654           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 655         enddo
 656       enddo
 657 #ifdef DEBUG
 658       write (iout,*) "gradbufc after summing"
 659       do i=1,nres
 660         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 661       enddo
 662       call flush(iout)
 663 #endif
 664       else
 665 #endif
 666 #ifdef DEBUG
 667       write (iout,*) "gradbufc"
 668       do i=1,nres
 669         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 670       enddo
 671       call flush(iout)
 672 #endif
 673       do i=-1,nres
 674         do j=1,3
 675           gradbufc_sum(j,i)=gradbufc(j,i)
 676           gradbufc(j,i)=0.0d0
 677         enddo
 678       enddo
 679       do j=1,3
 680         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 681       enddo
 682       do i=nres-2,-1,-1
 683         do j=1,3
 684           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 685         enddo
 686       enddo
 687 c      do i=nnt,nres-1
 688 c        do k=1,3
 689 c          gradbufc(k,i)=0.0d0
 690 c        enddo
 691 c        do j=i+1,nres
 692 c          do k=1,3
 693 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 694 c          enddo
 695 c        enddo
 696 c      enddo
 697 #ifdef DEBUG
 698       write (iout,*) "gradbufc after summing"
 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 #ifdef MPI
 705       endif
 706 #endif
 707       do k=1,3
 708         gradbufc(k,nres)=0.0d0
 709       enddo
 710       do i=-1,nct
 711         do j=1,3
 712 #ifdef SPLITELE
 713 C          print *,gradbufc(1,13)
 714 C          print *,welec*gelc(1,13)
 715 C          print *,wel_loc*gel_loc(1,13)
 716 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 717 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 718 C          print *,wel_loc*gel_loc_long(1,13)
 719 C          print *,gradafm(1,13),"AFM"
 720           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 721      &                wel_loc*gel_loc(j,i)+
 722      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 723      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 724      &                wel_loc*gel_loc_long(j,i)+
 725      &                wcorr*gradcorr_long(j,i)+
 726      &                wcorr5*gradcorr5_long(j,i)+
 727      &                wcorr6*gradcorr6_long(j,i)+
 728      &                wturn6*gcorr6_turn_long(j,i))+
 729      &                wbond*gradb(j,i)+
 730      &                wcorr*gradcorr(j,i)+
 731      &                wturn3*gcorr3_turn(j,i)+
 732      &                wturn4*gcorr4_turn(j,i)+
 733      &                wcorr5*gradcorr5(j,i)+
 734      &                wcorr6*gradcorr6(j,i)+
 735      &                wturn6*gcorr6_turn(j,i)+
 736      &                wsccor*gsccorc(j,i)
 737      &               +wscloc*gscloc(j,i)
 738      &               +wliptran*gliptranc(j,i)
 739      &                +gradafm(j,i)
 740      &                 +welec*gshieldc(j,i)
 741      &                 +welec*gshieldc_loc(j,i)
 742      &                 +wcorr*gshieldc_ec(j,i)
 743      &                 +wcorr*gshieldc_loc_ec(j,i)
 744      &                 +wturn3*gshieldc_t3(j,i)
 745      &                 +wturn3*gshieldc_loc_t3(j,i)
 746      &                 +wturn4*gshieldc_t4(j,i)
 747      &                 +wturn4*gshieldc_loc_t4(j,i)
 748      &                 +wel_loc*gshieldc_ll(j,i)
 749      &                 +wel_loc*gshieldc_loc_ll(j,i)
 750
 751
 752
 753
 754
 755
 756 #else
 757           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 758      &                wel_loc*gel_loc(j,i)+
 759      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 760      &                welec*gelc_long(j,i)+
 761      &                wel_loc*gel_loc_long(j,i)+
 762      &                wcorr*gcorr_long(j,i)+
 763      &                wcorr5*gradcorr5_long(j,i)+
 764      &                wcorr6*gradcorr6_long(j,i)+
 765      &                wturn6*gcorr6_turn_long(j,i))+
 766      &                wbond*gradb(j,i)+
 767      &                wcorr*gradcorr(j,i)+
 768      &                wturn3*gcorr3_turn(j,i)+
 769      &                wturn4*gcorr4_turn(j,i)+
 770      &                wcorr5*gradcorr5(j,i)+
 771      &                wcorr6*gradcorr6(j,i)+
 772      &                wturn6*gcorr6_turn(j,i)+
 773      &                wsccor*gsccorc(j,i)
 774      &               +wscloc*gscloc(j,i)
 775      &               +wliptran*gliptranc(j,i)
 776      &                +gradafm(j,i)
 777      &                 +welec*gshieldc(j,i)
 778      &                 +welec*gshieldc_loc(j,i)
 779      &                 +wcorr*gshieldc_ec(j,i)
 780      &                 +wcorr*gshieldc_loc_ec(j,i)
 781      &                 +wturn3*gshieldc_t3(j,i)
 782      &                 +wturn3*gshieldc_loc_t3(j,i)
 783      &                 +wturn4*gshieldc_t4(j,i)
 784      &                 +wturn4*gshieldc_loc_t4(j,i)
 785      &                 +wel_loc*gshieldc_ll(j,i)
 786      &                 +wel_loc*gshieldc_loc_ll(j,i)
 787
 788
 789
 790
 791
 792 #endif
 793           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 794      &                  wbond*gradbx(j,i)+
 795      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 796      &                  wsccor*gsccorx(j,i)
 797      &                 +wscloc*gsclocx(j,i)
 798      &                 +wliptran*gliptranx(j,i)
 799      &                 +welec*gshieldx(j,i)
 800      &                 +wcorr*gshieldx_ec(j,i)
 801      &                 +wturn3*gshieldx_t3(j,i)
 802      &                 +wturn4*gshieldx_t4(j,i)
 803      &                 +wel_loc*gshieldx_ll(j,i)
 804
 805
 806
 807         enddo
 808       enddo
 809 #ifdef DEBUG
 810       write (iout,*) "gloc before adding corr"
 811       do i=1,4*nres
 812         write (iout,*) i,gloc(i,icg)
 813       enddo
 814 #endif
 815       do i=1,nres-3
 816         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 817      &   +wcorr5*g_corr5_loc(i)
 818      &   +wcorr6*g_corr6_loc(i)
 819      &   +wturn4*gel_loc_turn4(i)
 820      &   +wturn3*gel_loc_turn3(i)
 821      &   +wturn6*gel_loc_turn6(i)
 822      &   +wel_loc*gel_loc_loc(i)
 823       enddo
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after adding corr"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830 #ifdef MPI
 831       if (nfgtasks.gt.1) then
 832         do j=1,3
 833           do i=1,nres
 834             gradbufc(j,i)=gradc(j,i,icg)
 835             gradbufx(j,i)=gradx(j,i,icg)
 836           enddo
 837         enddo
 838         do i=1,4*nres
 839           glocbuf(i)=gloc(i,icg)
 840         enddo
 841 c#define DEBUG
 842 #ifdef DEBUG
 843       write (iout,*) "gloc_sc before reduce"
 844       do i=1,nres
 845        do j=1,1
 846         write (iout,*) i,j,gloc_sc(j,i,icg)
 847        enddo
 848       enddo
 849 #endif
 850 c#undef DEBUG
 851         do i=1,nres
 852          do j=1,3
 853           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 854          enddo
 855         enddo
 856         time00=MPI_Wtime()
 857         call MPI_Barrier(FG_COMM,IERR)
 858         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 859         time00=MPI_Wtime()
 860         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 861      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 862         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 863      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 864         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         time_reduce=time_reduce+MPI_Wtime()-time00
 867         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 868      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 869         time_reduce=time_reduce+MPI_Wtime()-time00
 870 c#define DEBUG
 871 #ifdef DEBUG
 872       write (iout,*) "gloc_sc after reduce"
 873       do i=1,nres
 874        do j=1,1
 875         write (iout,*) i,j,gloc_sc(j,i,icg)
 876        enddo
 877       enddo
 878 #endif
 879 c#undef DEBUG
 880 #ifdef DEBUG
 881       write (iout,*) "gloc after reduce"
 882       do i=1,4*nres
 883         write (iout,*) i,gloc(i,icg)
 884       enddo
 885 #endif
 886       endif
 887 #endif
 888       if (gnorm_check) then
 889 c
 890 c Compute the maximum elements of the gradient
 891 c
 892       gvdwc_max=0.0d0
 893       gvdwc_scp_max=0.0d0
 894       gelc_max=0.0d0
 895       gvdwpp_max=0.0d0
 896       gradb_max=0.0d0
 897       ghpbc_max=0.0d0
 898       gradcorr_max=0.0d0
 899       gel_loc_max=0.0d0
 900       gcorr3_turn_max=0.0d0
 901       gcorr4_turn_max=0.0d0
 902       gradcorr5_max=0.0d0
 903       gradcorr6_max=0.0d0
 904       gcorr6_turn_max=0.0d0
 905       gsccorc_max=0.0d0
 906       gscloc_max=0.0d0
 907       gvdwx_max=0.0d0
 908       gradx_scp_max=0.0d0
 909       ghpbx_max=0.0d0
 910       gradxorr_max=0.0d0
 911       gsccorx_max=0.0d0
 912       gsclocx_max=0.0d0
 913       do i=1,nct
 914         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 915         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 916         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 917         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 918      &   gvdwc_scp_max=gvdwc_scp_norm
 919         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 920         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 921         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 922         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 923         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 924         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 925         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 926         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 927         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 928         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 929         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 930         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 931         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 932      &    gcorr3_turn(1,i)))
 933         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 934      &    gcorr3_turn_max=gcorr3_turn_norm
 935         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 936      &    gcorr4_turn(1,i)))
 937         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 938      &    gcorr4_turn_max=gcorr4_turn_norm
 939         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 940         if (gradcorr5_norm.gt.gradcorr5_max)
 941      &    gradcorr5_max=gradcorr5_norm
 942         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 943         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 944         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 945      &    gcorr6_turn(1,i)))
 946         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 947      &    gcorr6_turn_max=gcorr6_turn_norm
 948         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 949         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 950         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 951         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 952         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 953         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 954         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 955         if (gradx_scp_norm.gt.gradx_scp_max)
 956      &    gradx_scp_max=gradx_scp_norm
 957         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 958         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 959         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 960         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 961         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 962         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 963         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 964         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 965       enddo
 966       if (gradout) then
 967 #ifdef AIX
 968         open(istat,file=statname,position="append")
 969 #else
 970         open(istat,file=statname,access="append")
 971 #endif
 972         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 973      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 974      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 975      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 976      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 977      &     gsccorx_max,gsclocx_max
 978         close(istat)
 979         if (gvdwc_max.gt.1.0d4) then
 980           write (iout,*) "gvdwc gvdwx gradb gradbx"
 981           do i=nnt,nct
 982             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 983      &        gradb(j,i),gradbx(j,i),j=1,3)
 984           enddo
 985           call pdbout(0.0d0,'cipiszcze',iout)
 986           call flush(iout)
 987         endif
 988       endif
 989       endif
 990 #ifdef DEBUG
 991       write (iout,*) "gradc gradx gloc"
 992       do i=1,nres
 993         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 994      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 995       enddo
 996 #endif
 997 #ifdef TIMING
 998       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 999 #endif
1000       return
1001       end
1002 c-------------------------------------------------------------------------------
1003       subroutine rescale_weights(t_bath)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.CONTROL'
1010       double precision kfac /2.4d0/
1011       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1012 c      facT=temp0/t_bath
1013 c      facT=2*temp0/(t_bath+temp0)
1014       if (rescale_mode.eq.0) then
1015         facT=1.0d0
1016         facT2=1.0d0
1017         facT3=1.0d0
1018         facT4=1.0d0
1019         facT5=1.0d0
1020       else if (rescale_mode.eq.1) then
1021         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1022         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1023         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1024         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1025         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1026       else if (rescale_mode.eq.2) then
1027         x=t_bath/temp0
1028         x2=x*x
1029         x3=x2*x
1030         x4=x3*x
1031         x5=x4*x
1032         facT=licznik/dlog(dexp(x)+dexp(-x))
1033         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1034         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1035         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1036         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1037       else
1038         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1039         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1040 #ifdef MPI
1041        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1042 #endif
1043        stop 555
1044       endif
1045       if (shield_mode.gt.0) then
1046        wscp=weights(2)*fact
1047        wsc=weights(1)*fact
1048        wvdwpp=weights(16)*fact
1049       endif
1050       welec=weights(3)*fact
1051       wcorr=weights(4)*fact3
1052       wcorr5=weights(5)*fact4
1053       wcorr6=weights(6)*fact5
1054       wel_loc=weights(7)*fact2
1055       wturn3=weights(8)*fact2
1056       wturn4=weights(9)*fact3
1057       wturn6=weights(10)*fact5
1058       wtor=weights(13)*fact
1059       wtor_d=weights(14)*fact2
1060       wsccor=weights(21)*fact
1061
1062       return
1063       end
1064 C------------------------------------------------------------------------
1065       subroutine enerprint(energia)
1066       implicit real*8 (a-h,o-z)
1067       include 'DIMENSIONS'
1068       include 'COMMON.IOUNITS'
1069       include 'COMMON.FFIELD'
1070       include 'COMMON.SBRIDGE'
1071       include 'COMMON.MD'
1072       double precision energia(0:n_ene)
1073       etot=energia(0)
1074       evdw=energia(1)
1075       evdw2=energia(2)
1076 #ifdef SCP14
1077       evdw2=energia(2)+energia(18)
1078 #else
1079       evdw2=energia(2)
1080 #endif
1081       ees=energia(3)
1082 #ifdef SPLITELE
1083       evdw1=energia(16)
1084 #endif
1085       ecorr=energia(4)
1086       ecorr5=energia(5)
1087       ecorr6=energia(6)
1088       eel_loc=energia(7)
1089       eello_turn3=energia(8)
1090       eello_turn4=energia(9)
1091       eello_turn6=energia(10)
1092       ebe=energia(11)
1093       escloc=energia(12)
1094       etors=energia(13)
1095       etors_d=energia(14)
1096       ehpb=energia(15)
1097       edihcnstr=energia(19)
1098       estr=energia(17)
1099       Uconst=energia(20)
1100       esccor=energia(21)
1101       eliptran=energia(22)
1102       Eafmforce=energia(23)
1103       ethetacnstr=energia(24)
1104 #ifdef SPLITELE
1105       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1106      &  estr,wbond,ebe,wang,
1107      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1108      &  ecorr,wcorr,
1109      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1110      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1111      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1112      &  etot
1113    10 format (/'Virtual-chain energies:'//
1114      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1115      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1116      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1117      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1118      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1119      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1120      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1121      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1122      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1123      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1124      & ' (SS bridges & dist. cnstr.)'/
1125      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1126      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1127      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1128      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1129      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1130      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1131      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1132      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1133      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1134      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1135      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1136      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1137      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1138      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1139      & 'ETOT=  ',1pE16.6,' (total)')
1140
1141 #else
1142       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1143      &  estr,wbond,ebe,wang,
1144      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1145      &  ecorr,wcorr,
1146      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1147      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1148      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1149      &  etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1154      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1155      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1156      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1157      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1158      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1159      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1160      & ' (SS bridges & dist. cnstr.)'/
1161      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1162      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1163      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1164      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1165      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1166      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1167      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1168      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1169      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1170      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1171      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1172      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1173      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1174      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1175      & 'ETOT=  ',1pE16.6,' (total)')
1176 #endif
1177       return
1178       end
1179 C-----------------------------------------------------------------------
1180       subroutine elj(evdw)
1181 C
1182 C This subroutine calculates the interaction energy of nonbonded side chains
1183 C assuming the LJ potential of interaction.
1184 C
1185       implicit real*8 (a-h,o-z)
1186       include 'DIMENSIONS'
1187       parameter (accur=1.0d-10)
1188       include 'COMMON.GEO'
1189       include 'COMMON.VAR'
1190       include 'COMMON.LOCAL'
1191       include 'COMMON.CHAIN'
1192       include 'COMMON.DERIV'
1193       include 'COMMON.INTERACT'
1194       include 'COMMON.TORSION'
1195       include 'COMMON.SBRIDGE'
1196       include 'COMMON.NAMES'
1197       include 'COMMON.IOUNITS'
1198       include 'COMMON.CONTACTS'
1199       dimension gg(3)
1200 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1201       evdw=0.0D0
1202       do i=iatsc_s,iatsc_e
1203         itypi=iabs(itype(i))
1204         if (itypi.eq.ntyp1) cycle
1205         itypi1=iabs(itype(i+1))
1206         xi=c(1,nres+i)
1207         yi=c(2,nres+i)
1208         zi=c(3,nres+i)
1209 C Change 12/1/95
1210         num_conti=0
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1216 cd   &                  'iend=',iend(i,iint)
1217           do j=istart(i,iint),iend(i,iint)
1218             itypj=iabs(itype(j))
1219             if (itypj.eq.ntyp1) cycle
1220             xj=c(1,nres+j)-xi
1221             yj=c(2,nres+j)-yi
1222             zj=c(3,nres+j)-zi
1223 C Change 12/1/95 to calculate four-body interactions
1224             rij=xj*xj+yj*yj+zj*zj
1225             rrij=1.0D0/rij
1226 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1227             eps0ij=eps(itypi,itypj)
1228             fac=rrij**expon2
1229 C have you changed here?
1230             e1=fac*fac*aa
1231             e2=fac*bb
1232             evdwij=e1+e2
1233 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1234 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1235 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1236 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1237 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1238 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1239             evdw=evdw+evdwij
1240 C
1241 C Calculate the components of the gradient in DC and X
1242 C
1243             fac=-rrij*(e1+evdwij)
1244             gg(1)=xj*fac
1245             gg(2)=yj*fac
1246             gg(3)=zj*fac
1247             do k=1,3
1248               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1249               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1250               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1251               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1252             enddo
1253 cgrad            do k=i,j-1
1254 cgrad              do l=1,3
1255 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1256 cgrad              enddo
1257 cgrad            enddo
1258 C
1259 C 12/1/95, revised on 5/20/97
1260 C
1261 C Calculate the contact function. The ith column of the array JCONT will
1262 C contain the numbers of atoms that make contacts with the atom I (of numbers
1263 C greater than I). The arrays FACONT and GACONT will contain the values of
1264 C the contact function and its derivative.
1265 C
1266 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1267 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1268 C Uncomment next line, if the correlation interactions are contact function only
1269             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1270               rij=dsqrt(rij)
1271               sigij=sigma(itypi,itypj)
1272               r0ij=rs0(itypi,itypj)
1273 C
1274 C Check whether the SC's are not too far to make a contact.
1275 C
1276               rcut=1.5d0*r0ij
1277               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1278 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1279 C
1280               if (fcont.gt.0.0D0) then
1281 C If the SC-SC distance if close to sigma, apply spline.
1282 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1283 cAdam &             fcont1,fprimcont1)
1284 cAdam           fcont1=1.0d0-fcont1
1285 cAdam           if (fcont1.gt.0.0d0) then
1286 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1287 cAdam             fcont=fcont*fcont1
1288 cAdam           endif
1289 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1290 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1291 cga             do k=1,3
1292 cga               gg(k)=gg(k)*eps0ij
1293 cga             enddo
1294 cga             eps0ij=-evdwij*eps0ij
1295 C Uncomment for AL's type of SC correlation interactions.
1296 cadam           eps0ij=-evdwij
1297                 num_conti=num_conti+1
1298                 jcont(num_conti,i)=j
1299                 facont(num_conti,i)=fcont*eps0ij
1300                 fprimcont=eps0ij*fprimcont/rij
1301                 fcont=expon*fcont
1302 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1303 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1304 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1305 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1306                 gacont(1,num_conti,i)=-fprimcont*xj
1307                 gacont(2,num_conti,i)=-fprimcont*yj
1308                 gacont(3,num_conti,i)=-fprimcont*zj
1309 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1310 cd              write (iout,'(2i3,3f10.5)')
1311 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1312               endif
1313             endif
1314           enddo      ! j
1315         enddo        ! iint
1316 C Change 12/1/95
1317         num_cont(i)=num_conti
1318       enddo          ! i
1319       do i=1,nct
1320         do j=1,3
1321           gvdwc(j,i)=expon*gvdwc(j,i)
1322           gvdwx(j,i)=expon*gvdwx(j,i)
1323         enddo
1324       enddo
1325 C******************************************************************************
1326 C
1327 C                              N O T E !!!
1328 C
1329 C To save time, the factor of EXPON has been extracted from ALL components
1330 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1331 C use!
1332 C
1333 C******************************************************************************
1334       return
1335       end
1336 C-----------------------------------------------------------------------------
1337       subroutine eljk(evdw)
1338 C
1339 C This subroutine calculates the interaction energy of nonbonded side chains
1340 C assuming the LJK potential of interaction.
1341 C
1342       implicit real*8 (a-h,o-z)
1343       include 'DIMENSIONS'
1344       include 'COMMON.GEO'
1345       include 'COMMON.VAR'
1346       include 'COMMON.LOCAL'
1347       include 'COMMON.CHAIN'
1348       include 'COMMON.DERIV'
1349       include 'COMMON.INTERACT'
1350       include 'COMMON.IOUNITS'
1351       include 'COMMON.NAMES'
1352       dimension gg(3)
1353       logical scheck
1354 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1355       evdw=0.0D0
1356       do i=iatsc_s,iatsc_e
1357         itypi=iabs(itype(i))
1358         if (itypi.eq.ntyp1) cycle
1359         itypi1=iabs(itype(i+1))
1360         xi=c(1,nres+i)
1361         yi=c(2,nres+i)
1362         zi=c(3,nres+i)
1363 C
1364 C Calculate SC interaction energy.
1365 C
1366         do iint=1,nint_gr(i)
1367           do j=istart(i,iint),iend(i,iint)
1368             itypj=iabs(itype(j))
1369             if (itypj.eq.ntyp1) cycle
1370             xj=c(1,nres+j)-xi
1371             yj=c(2,nres+j)-yi
1372             zj=c(3,nres+j)-zi
1373             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1374             fac_augm=rrij**expon
1375             e_augm=augm(itypi,itypj)*fac_augm
1376             r_inv_ij=dsqrt(rrij)
1377             rij=1.0D0/r_inv_ij
1378             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1379             fac=r_shift_inv**expon
1380 C have you changed here?
1381             e1=fac*fac*aa
1382             e2=fac*bb
1383             evdwij=e_augm+e1+e2
1384 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1385 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1386 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1387 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1388 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1389 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1390 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1391             evdw=evdw+evdwij
1392 C
1393 C Calculate the components of the gradient in DC and X
1394 C
1395             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1396             gg(1)=xj*fac
1397             gg(2)=yj*fac
1398             gg(3)=zj*fac
1399             do k=1,3
1400               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1401               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1402               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1403               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1404             enddo
1405 cgrad            do k=i,j-1
1406 cgrad              do l=1,3
1407 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1408 cgrad              enddo
1409 cgrad            enddo
1410           enddo      ! j
1411         enddo        ! iint
1412       enddo          ! i
1413       do i=1,nct
1414         do j=1,3
1415           gvdwc(j,i)=expon*gvdwc(j,i)
1416           gvdwx(j,i)=expon*gvdwx(j,i)
1417         enddo
1418       enddo
1419       return
1420       end
1421 C-----------------------------------------------------------------------------
1422       subroutine ebp(evdw)
1423 C
1424 C This subroutine calculates the interaction energy of nonbonded side chains
1425 C assuming the Berne-Pechukas potential of interaction.
1426 C
1427       implicit real*8 (a-h,o-z)
1428       include 'DIMENSIONS'
1429       include 'COMMON.GEO'
1430       include 'COMMON.VAR'
1431       include 'COMMON.LOCAL'
1432       include 'COMMON.CHAIN'
1433       include 'COMMON.DERIV'
1434       include 'COMMON.NAMES'
1435       include 'COMMON.INTERACT'
1436       include 'COMMON.IOUNITS'
1437       include 'COMMON.CALC'
1438       common /srutu/ icall
1439 c     double precision rrsave(maxdim)
1440       logical lprn
1441       evdw=0.0D0
1442 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1443       evdw=0.0D0
1444 c     if (icall.eq.0) then
1445 c       lprn=.true.
1446 c     else
1447         lprn=.false.
1448 c     endif
1449       ind=0
1450       do i=iatsc_s,iatsc_e
1451         itypi=iabs(itype(i))
1452         if (itypi.eq.ntyp1) cycle
1453         itypi1=iabs(itype(i+1))
1454         xi=c(1,nres+i)
1455         yi=c(2,nres+i)
1456         zi=c(3,nres+i)
1457         dxi=dc_norm(1,nres+i)
1458         dyi=dc_norm(2,nres+i)
1459         dzi=dc_norm(3,nres+i)
1460 c        dsci_inv=dsc_inv(itypi)
1461         dsci_inv=vbld_inv(i+nres)
1462 C
1463 C Calculate SC interaction energy.
1464 C
1465         do iint=1,nint_gr(i)
1466           do j=istart(i,iint),iend(i,iint)
1467             ind=ind+1
1468             itypj=iabs(itype(j))
1469             if (itypj.eq.ntyp1) cycle
1470 c            dscj_inv=dsc_inv(itypj)
1471             dscj_inv=vbld_inv(j+nres)
1472             chi1=chi(itypi,itypj)
1473             chi2=chi(itypj,itypi)
1474             chi12=chi1*chi2
1475             chip1=chip(itypi)
1476             chip2=chip(itypj)
1477             chip12=chip1*chip2
1478             alf1=alp(itypi)
1479             alf2=alp(itypj)
1480             alf12=0.5D0*(alf1+alf2)
1481 C For diagnostics only!!!
1482 c           chi1=0.0D0
1483 c           chi2=0.0D0
1484 c           chi12=0.0D0
1485 c           chip1=0.0D0
1486 c           chip2=0.0D0
1487 c           chip12=0.0D0
1488 c           alf1=0.0D0
1489 c           alf2=0.0D0
1490 c           alf12=0.0D0
1491             xj=c(1,nres+j)-xi
1492             yj=c(2,nres+j)-yi
1493             zj=c(3,nres+j)-zi
1494             dxj=dc_norm(1,nres+j)
1495             dyj=dc_norm(2,nres+j)
1496             dzj=dc_norm(3,nres+j)
1497             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1498 cd          if (icall.eq.0) then
1499 cd            rrsave(ind)=rrij
1500 cd          else
1501 cd            rrij=rrsave(ind)
1502 cd          endif
1503             rij=dsqrt(rrij)
1504 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1505             call sc_angular
1506 C Calculate whole angle-dependent part of epsilon and contributions
1507 C to its derivatives
1508 C have you changed here?
1509             fac=(rrij*sigsq)**expon2
1510             e1=fac*fac*aa
1511             e2=fac*bb
1512             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1513             eps2der=evdwij*eps3rt
1514             eps3der=evdwij*eps2rt
1515             evdwij=evdwij*eps2rt*eps3rt
1516             evdw=evdw+evdwij
1517             if (lprn) then
1518             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1519             epsi=bb**2/aa
1520 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1521 cd     &        restyp(itypi),i,restyp(itypj),j,
1522 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1523 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1524 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1525 cd     &        evdwij
1526             endif
1527 C Calculate gradient components.
1528             e1=e1*eps1*eps2rt**2*eps3rt**2
1529             fac=-expon*(e1+evdwij)
1530             sigder=fac/sigsq
1531             fac=rrij*fac
1532 C Calculate radial part of the gradient
1533             gg(1)=xj*fac
1534             gg(2)=yj*fac
1535             gg(3)=zj*fac
1536 C Calculate the angular part of the gradient and sum add the contributions
1537 C to the appropriate components of the Cartesian gradient.
1538             call sc_grad
1539           enddo      ! j
1540         enddo        ! iint
1541       enddo          ! i
1542 c     stop
1543       return
1544       end
1545 C-----------------------------------------------------------------------------
1546       subroutine egb(evdw)
1547 C
1548 C This subroutine calculates the interaction energy of nonbonded side chains
1549 C assuming the Gay-Berne potential of interaction.
1550 C
1551       implicit real*8 (a-h,o-z)
1552       include 'DIMENSIONS'
1553       include 'COMMON.GEO'
1554       include 'COMMON.VAR'
1555       include 'COMMON.LOCAL'
1556       include 'COMMON.CHAIN'
1557       include 'COMMON.DERIV'
1558       include 'COMMON.NAMES'
1559       include 'COMMON.INTERACT'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.CALC'
1562       include 'COMMON.CONTROL'
1563       include 'COMMON.SPLITELE'
1564       include 'COMMON.SBRIDGE'
1565       logical lprn
1566       integer xshift,yshift,zshift
1567
1568       evdw=0.0D0
1569 ccccc      energy_dec=.false.
1570 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1571       evdw=0.0D0
1572       lprn=.false.
1573 c     if (icall.eq.0) lprn=.false.
1574       ind=0
1575 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1576 C we have the original box)
1577 C      do xshift=-1,1
1578 C      do yshift=-1,1
1579 C      do zshift=-1,1
1580       do i=iatsc_s,iatsc_e
1581         itypi=iabs(itype(i))
1582         if (itypi.eq.ntyp1) cycle
1583         itypi1=iabs(itype(i+1))
1584         xi=c(1,nres+i)
1585         yi=c(2,nres+i)
1586         zi=c(3,nres+i)
1587 C Return atom into box, boxxsize is size of box in x dimension
1588 c  134   continue
1589 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1590 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1591 C Condition for being inside the proper box
1592 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1593 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1594 c        go to 134
1595 c        endif
1596 c  135   continue
1597 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1598 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1599 C Condition for being inside the proper box
1600 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1601 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1602 c        go to 135
1603 c        endif
1604 c  136   continue
1605 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1606 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1607 C Condition for being inside the proper box
1608 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1609 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1610 c        go to 136
1611 c        endif
1612           xi=mod(xi,boxxsize)
1613           if (xi.lt.0) xi=xi+boxxsize
1614           yi=mod(yi,boxysize)
1615           if (yi.lt.0) yi=yi+boxysize
1616           zi=mod(zi,boxzsize)
1617           if (zi.lt.0) zi=zi+boxzsize
1618 C define scaling factor for lipids
1619
1620 C        if (positi.le.0) positi=positi+boxzsize
1621 C        print *,i
1622 C first for peptide groups
1623 c for each residue check if it is in lipid or lipid water border area
1624        if ((zi.gt.bordlipbot)
1625      &.and.(zi.lt.bordliptop)) then
1626 C the energy transfer exist
1627         if (zi.lt.buflipbot) then
1628 C what fraction I am in
1629          fracinbuf=1.0d0-
1630      &        ((zi-bordlipbot)/lipbufthick)
1631 C lipbufthick is thickenes of lipid buffore
1632          sslipi=sscalelip(fracinbuf)
1633          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1634         elseif (zi.gt.bufliptop) then
1635          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1636          sslipi=sscalelip(fracinbuf)
1637          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1638         else
1639          sslipi=1.0d0
1640          ssgradlipi=0.0
1641         endif
1642        else
1643          sslipi=0.0d0
1644          ssgradlipi=0.0
1645        endif
1646
1647 C          xi=xi+xshift*boxxsize
1648 C          yi=yi+yshift*boxysize
1649 C          zi=zi+zshift*boxzsize
1650
1651         dxi=dc_norm(1,nres+i)
1652         dyi=dc_norm(2,nres+i)
1653         dzi=dc_norm(3,nres+i)
1654 c        dsci_inv=dsc_inv(itypi)
1655         dsci_inv=vbld_inv(i+nres)
1656 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1657 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1658 C
1659 C Calculate SC interaction energy.
1660 C
1661         do iint=1,nint_gr(i)
1662           do j=istart(i,iint),iend(i,iint)
1663             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1664
1665 c              write(iout,*) "PRZED ZWYKLE", evdwij
1666               call dyn_ssbond_ene(i,j,evdwij)
1667 c              write(iout,*) "PO ZWYKLE", evdwij
1668
1669               evdw=evdw+evdwij
1670               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1671      &                        'evdw',i,j,evdwij,' ss'
1672 C triple bond artifac removal
1673              do k=j+1,iend(i,iint)
1674 C search over all next residues
1675               if (dyn_ss_mask(k)) then
1676 C check if they are cysteins
1677 C              write(iout,*) 'k=',k
1678
1679 c              write(iout,*) "PRZED TRI", evdwij
1680                evdwij_przed_tri=evdwij
1681               call triple_ssbond_ene(i,j,k,evdwij)
1682 c               if(evdwij_przed_tri.ne.evdwij) then
1683 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1684 c               endif
1685
1686 c              write(iout,*) "PO TRI", evdwij
1687 C call the energy function that removes the artifical triple disulfide
1688 C bond the soubroutine is located in ssMD.F
1689               evdw=evdw+evdwij
1690               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1691      &                        'evdw',i,j,evdwij,'tss'
1692               endif!dyn_ss_mask(k)
1693              enddo! k
1694             ELSE
1695             ind=ind+1
1696             itypj=iabs(itype(j))
1697             if (itypj.eq.ntyp1) cycle
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1701 c     &       1.0d0/vbld(j+nres)
1702 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1703             sig0ij=sigma(itypi,itypj)
1704             chi1=chi(itypi,itypj)
1705             chi2=chi(itypj,itypi)
1706             chi12=chi1*chi2
1707             chip1=chip(itypi)
1708             chip2=chip(itypj)
1709             chip12=chip1*chip2
1710             alf1=alp(itypi)
1711             alf2=alp(itypj)
1712             alf12=0.5D0*(alf1+alf2)
1713 C For diagnostics only!!!
1714 c           chi1=0.0D0
1715 c           chi2=0.0D0
1716 c           chi12=0.0D0
1717 c           chip1=0.0D0
1718 c           chip2=0.0D0
1719 c           chip12=0.0D0
1720 c           alf1=0.0D0
1721 c           alf2=0.0D0
1722 c           alf12=0.0D0
1723             xj=c(1,nres+j)
1724             yj=c(2,nres+j)
1725             zj=c(3,nres+j)
1726 C Return atom J into box the original box
1727 c  137   continue
1728 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1729 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1730 C Condition for being inside the proper box
1731 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1732 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1733 c        go to 137
1734 c        endif
1735 c  138   continue
1736 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1737 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1738 C Condition for being inside the proper box
1739 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1740 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1741 c        go to 138
1742 c        endif
1743 c  139   continue
1744 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1745 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1746 C Condition for being inside the proper box
1747 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1748 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1749 c        go to 139
1750 c        endif
1751           xj=mod(xj,boxxsize)
1752           if (xj.lt.0) xj=xj+boxxsize
1753           yj=mod(yj,boxysize)
1754           if (yj.lt.0) yj=yj+boxysize
1755           zj=mod(zj,boxzsize)
1756           if (zj.lt.0) zj=zj+boxzsize
1757        if ((zj.gt.bordlipbot)
1758      &.and.(zj.lt.bordliptop)) then
1759 C the energy transfer exist
1760         if (zj.lt.buflipbot) then
1761 C what fraction I am in
1762          fracinbuf=1.0d0-
1763      &        ((zj-bordlipbot)/lipbufthick)
1764 C lipbufthick is thickenes of lipid buffore
1765          sslipj=sscalelip(fracinbuf)
1766          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1767         elseif (zj.gt.bufliptop) then
1768          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1769          sslipj=sscalelip(fracinbuf)
1770          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1771         else
1772          sslipj=1.0d0
1773          ssgradlipj=0.0
1774         endif
1775        else
1776          sslipj=0.0d0
1777          ssgradlipj=0.0
1778        endif
1779       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1780      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1781       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1782      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1783 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1784 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1785 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1786 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1787       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1788       xj_safe=xj
1789       yj_safe=yj
1790       zj_safe=zj
1791       subchap=0
1792       do xshift=-1,1
1793       do yshift=-1,1
1794       do zshift=-1,1
1795           xj=xj_safe+xshift*boxxsize
1796           yj=yj_safe+yshift*boxysize
1797           zj=zj_safe+zshift*boxzsize
1798           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1799           if(dist_temp.lt.dist_init) then
1800             dist_init=dist_temp
1801             xj_temp=xj
1802             yj_temp=yj
1803             zj_temp=zj
1804             subchap=1
1805           endif
1806        enddo
1807        enddo
1808        enddo
1809        if (subchap.eq.1) then
1810           xj=xj_temp-xi
1811           yj=yj_temp-yi
1812           zj=zj_temp-zi
1813        else
1814           xj=xj_safe-xi
1815           yj=yj_safe-yi
1816           zj=zj_safe-zi
1817        endif
1818             dxj=dc_norm(1,nres+j)
1819             dyj=dc_norm(2,nres+j)
1820             dzj=dc_norm(3,nres+j)
1821 C            xj=xj-xi
1822 C            yj=yj-yi
1823 C            zj=zj-zi
1824 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1825 c            write (iout,*) "j",j," dc_norm",
1826 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1827             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1828             rij=dsqrt(rrij)
1829             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1830             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1831
1832 c            write (iout,'(a7,4f8.3)')
1833 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1834             if (sss.gt.0.0d0) then
1835 C Calculate angle-dependent terms of energy and contributions to their
1836 C derivatives.
1837             call sc_angular
1838             sigsq=1.0D0/sigsq
1839             sig=sig0ij*dsqrt(sigsq)
1840             rij_shift=1.0D0/rij-sig+sig0ij
1841 c for diagnostics; uncomment
1842 c            rij_shift=1.2*sig0ij
1843 C I hate to put IF's in the loops, but here don't have another choice!!!!
1844             if (rij_shift.le.0.0D0) then
1845               evdw=1.0D20
1846 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1847 cd     &        restyp(itypi),i,restyp(itypj),j,
1848 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1849               return
1850             endif
1851             sigder=-sig*sigsq
1852 c---------------------------------------------------------------
1853             rij_shift=1.0D0/rij_shift
1854             fac=rij_shift**expon
1855 C here to start with
1856 C            if (c(i,3).gt.
1857             faclip=fac
1858             e1=fac*fac*aa
1859             e2=fac*bb
1860             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1861             eps2der=evdwij*eps3rt
1862             eps3der=evdwij*eps2rt
1863 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1864 C     &((sslipi+sslipj)/2.0d0+
1865 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1866 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1867 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1868             evdwij=evdwij*eps2rt*eps3rt
1869             evdw=evdw+evdwij*sss
1870             if (lprn) then
1871             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1872             epsi=bb**2/aa
1873             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1874      &        restyp(itypi),i,restyp(itypj),j,
1875      &        epsi,sigm,chi1,chi2,chip1,chip2,
1876      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1877      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1878      &        evdwij
1879             endif
1880
1881             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1882      &                        'evdw',i,j,evdwij
1883
1884 C Calculate gradient components.
1885             e1=e1*eps1*eps2rt**2*eps3rt**2
1886             fac=-expon*(e1+evdwij)*rij_shift
1887             sigder=fac*sigder
1888             fac=rij*fac
1889 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1890 c     &      evdwij,fac,sigma(itypi,itypj),expon
1891             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1892 c            fac=0.0d0
1893 C Calculate the radial part of the gradient
1894             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1895      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1896      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1897      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1898             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1899             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1900 C            gg_lipi(3)=0.0d0
1901 C            gg_lipj(3)=0.0d0
1902             gg(1)=xj*fac
1903             gg(2)=yj*fac
1904             gg(3)=zj*fac
1905 C Calculate angular part of the gradient.
1906             call sc_grad
1907             endif
1908             ENDIF    ! dyn_ss
1909           enddo      ! j
1910         enddo        ! iint
1911       enddo          ! i
1912 C      enddo          ! zshift
1913 C      enddo          ! yshift
1914 C      enddo          ! xshift
1915 c      write (iout,*) "Number of loop steps in EGB:",ind
1916 cccc      energy_dec=.false.
1917       return
1918       end
1919 C-----------------------------------------------------------------------------
1920       subroutine egbv(evdw)
1921 C
1922 C This subroutine calculates the interaction energy of nonbonded side chains
1923 C assuming the Gay-Berne-Vorobjev potential of interaction.
1924 C
1925       implicit real*8 (a-h,o-z)
1926       include 'DIMENSIONS'
1927       include 'COMMON.GEO'
1928       include 'COMMON.VAR'
1929       include 'COMMON.LOCAL'
1930       include 'COMMON.CHAIN'
1931       include 'COMMON.DERIV'
1932       include 'COMMON.NAMES'
1933       include 'COMMON.INTERACT'
1934       include 'COMMON.IOUNITS'
1935       include 'COMMON.CALC'
1936       common /srutu/ icall
1937       logical lprn
1938       evdw=0.0D0
1939 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1940       evdw=0.0D0
1941       lprn=.false.
1942 c     if (icall.eq.0) lprn=.true.
1943       ind=0
1944       do i=iatsc_s,iatsc_e
1945         itypi=iabs(itype(i))
1946         if (itypi.eq.ntyp1) cycle
1947         itypi1=iabs(itype(i+1))
1948         xi=c(1,nres+i)
1949         yi=c(2,nres+i)
1950         zi=c(3,nres+i)
1951           xi=mod(xi,boxxsize)
1952           if (xi.lt.0) xi=xi+boxxsize
1953           yi=mod(yi,boxysize)
1954           if (yi.lt.0) yi=yi+boxysize
1955           zi=mod(zi,boxzsize)
1956           if (zi.lt.0) zi=zi+boxzsize
1957 C define scaling factor for lipids
1958
1959 C        if (positi.le.0) positi=positi+boxzsize
1960 C        print *,i
1961 C first for peptide groups
1962 c for each residue check if it is in lipid or lipid water border area
1963        if ((zi.gt.bordlipbot)
1964      &.and.(zi.lt.bordliptop)) then
1965 C the energy transfer exist
1966         if (zi.lt.buflipbot) then
1967 C what fraction I am in
1968          fracinbuf=1.0d0-
1969      &        ((zi-bordlipbot)/lipbufthick)
1970 C lipbufthick is thickenes of lipid buffore
1971          sslipi=sscalelip(fracinbuf)
1972          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1973         elseif (zi.gt.bufliptop) then
1974          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1975          sslipi=sscalelip(fracinbuf)
1976          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1977         else
1978          sslipi=1.0d0
1979          ssgradlipi=0.0
1980         endif
1981        else
1982          sslipi=0.0d0
1983          ssgradlipi=0.0
1984        endif
1985
1986         dxi=dc_norm(1,nres+i)
1987         dyi=dc_norm(2,nres+i)
1988         dzi=dc_norm(3,nres+i)
1989 c        dsci_inv=dsc_inv(itypi)
1990         dsci_inv=vbld_inv(i+nres)
1991 C
1992 C Calculate SC interaction energy.
1993 C
1994         do iint=1,nint_gr(i)
1995           do j=istart(i,iint),iend(i,iint)
1996             ind=ind+1
1997             itypj=iabs(itype(j))
1998             if (itypj.eq.ntyp1) cycle
1999 c            dscj_inv=dsc_inv(itypj)
2000             dscj_inv=vbld_inv(j+nres)
2001             sig0ij=sigma(itypi,itypj)
2002             r0ij=r0(itypi,itypj)
2003             chi1=chi(itypi,itypj)
2004             chi2=chi(itypj,itypi)
2005             chi12=chi1*chi2
2006             chip1=chip(itypi)
2007             chip2=chip(itypj)
2008             chip12=chip1*chip2
2009             alf1=alp(itypi)
2010             alf2=alp(itypj)
2011             alf12=0.5D0*(alf1+alf2)
2012 C For diagnostics only!!!
2013 c           chi1=0.0D0
2014 c           chi2=0.0D0
2015 c           chi12=0.0D0
2016 c           chip1=0.0D0
2017 c           chip2=0.0D0
2018 c           chip12=0.0D0
2019 c           alf1=0.0D0
2020 c           alf2=0.0D0
2021 c           alf12=0.0D0
2022 C            xj=c(1,nres+j)-xi
2023 C            yj=c(2,nres+j)-yi
2024 C            zj=c(3,nres+j)-zi
2025           xj=mod(xj,boxxsize)
2026           if (xj.lt.0) xj=xj+boxxsize
2027           yj=mod(yj,boxysize)
2028           if (yj.lt.0) yj=yj+boxysize
2029           zj=mod(zj,boxzsize)
2030           if (zj.lt.0) zj=zj+boxzsize
2031        if ((zj.gt.bordlipbot)
2032      &.and.(zj.lt.bordliptop)) then
2033 C the energy transfer exist
2034         if (zj.lt.buflipbot) then
2035 C what fraction I am in
2036          fracinbuf=1.0d0-
2037      &        ((zj-bordlipbot)/lipbufthick)
2038 C lipbufthick is thickenes of lipid buffore
2039          sslipj=sscalelip(fracinbuf)
2040          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2041         elseif (zj.gt.bufliptop) then
2042          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2043          sslipj=sscalelip(fracinbuf)
2044          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2045         else
2046          sslipj=1.0d0
2047          ssgradlipj=0.0
2048         endif
2049        else
2050          sslipj=0.0d0
2051          ssgradlipj=0.0
2052        endif
2053       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2054      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2055       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2056      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2057 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2058 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2059       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2060       xj_safe=xj
2061       yj_safe=yj
2062       zj_safe=zj
2063       subchap=0
2064       do xshift=-1,1
2065       do yshift=-1,1
2066       do zshift=-1,1
2067           xj=xj_safe+xshift*boxxsize
2068           yj=yj_safe+yshift*boxysize
2069           zj=zj_safe+zshift*boxzsize
2070           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2071           if(dist_temp.lt.dist_init) then
2072             dist_init=dist_temp
2073             xj_temp=xj
2074             yj_temp=yj
2075             zj_temp=zj
2076             subchap=1
2077           endif
2078        enddo
2079        enddo
2080        enddo
2081        if (subchap.eq.1) then
2082           xj=xj_temp-xi
2083           yj=yj_temp-yi
2084           zj=zj_temp-zi
2085        else
2086           xj=xj_safe-xi
2087           yj=yj_safe-yi
2088           zj=zj_safe-zi
2089        endif
2090             dxj=dc_norm(1,nres+j)
2091             dyj=dc_norm(2,nres+j)
2092             dzj=dc_norm(3,nres+j)
2093             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2094             rij=dsqrt(rrij)
2095 C Calculate angle-dependent terms of energy and contributions to their
2096 C derivatives.
2097             call sc_angular
2098             sigsq=1.0D0/sigsq
2099             sig=sig0ij*dsqrt(sigsq)
2100             rij_shift=1.0D0/rij-sig+r0ij
2101 C I hate to put IF's in the loops, but here don't have another choice!!!!
2102             if (rij_shift.le.0.0D0) then
2103               evdw=1.0D20
2104               return
2105             endif
2106             sigder=-sig*sigsq
2107 c---------------------------------------------------------------
2108             rij_shift=1.0D0/rij_shift
2109             fac=rij_shift**expon
2110             e1=fac*fac*aa
2111             e2=fac*bb
2112             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2113             eps2der=evdwij*eps3rt
2114             eps3der=evdwij*eps2rt
2115             fac_augm=rrij**expon
2116             e_augm=augm(itypi,itypj)*fac_augm
2117             evdwij=evdwij*eps2rt*eps3rt
2118             evdw=evdw+evdwij+e_augm
2119             if (lprn) then
2120             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2121             epsi=bb**2/aa
2122             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2123      &        restyp(itypi),i,restyp(itypj),j,
2124      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2125      &        chi1,chi2,chip1,chip2,
2126      &        eps1,eps2rt**2,eps3rt**2,
2127      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2128      &        evdwij+e_augm
2129             endif
2130 C Calculate gradient components.
2131             e1=e1*eps1*eps2rt**2*eps3rt**2
2132             fac=-expon*(e1+evdwij)*rij_shift
2133             sigder=fac*sigder
2134             fac=rij*fac-2*expon*rrij*e_augm
2135             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2136 C Calculate the radial part of the gradient
2137             gg(1)=xj*fac
2138             gg(2)=yj*fac
2139             gg(3)=zj*fac
2140 C Calculate angular part of the gradient.
2141             call sc_grad
2142           enddo      ! j
2143         enddo        ! iint
2144       enddo          ! i
2145       end
2146 C-----------------------------------------------------------------------------
2147       subroutine sc_angular
2148 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2149 C om12. Called by ebp, egb, and egbv.
2150       implicit none
2151       include 'COMMON.CALC'
2152       include 'COMMON.IOUNITS'
2153       erij(1)=xj*rij
2154       erij(2)=yj*rij
2155       erij(3)=zj*rij
2156       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2157       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2158       om12=dxi*dxj+dyi*dyj+dzi*dzj
2159       chiom12=chi12*om12
2160 C Calculate eps1(om12) and its derivative in om12
2161       faceps1=1.0D0-om12*chiom12
2162       faceps1_inv=1.0D0/faceps1
2163       eps1=dsqrt(faceps1_inv)
2164 C Following variable is eps1*deps1/dom12
2165       eps1_om12=faceps1_inv*chiom12
2166 c diagnostics only
2167 c      faceps1_inv=om12
2168 c      eps1=om12
2169 c      eps1_om12=1.0d0
2170 c      write (iout,*) "om12",om12," eps1",eps1
2171 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2172 C and om12.
2173       om1om2=om1*om2
2174       chiom1=chi1*om1
2175       chiom2=chi2*om2
2176       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2177       sigsq=1.0D0-facsig*faceps1_inv
2178       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2179       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2180       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2181 c diagnostics only
2182 c      sigsq=1.0d0
2183 c      sigsq_om1=0.0d0
2184 c      sigsq_om2=0.0d0
2185 c      sigsq_om12=0.0d0
2186 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2187 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2188 c     &    " eps1",eps1
2189 C Calculate eps2 and its derivatives in om1, om2, and om12.
2190       chipom1=chip1*om1
2191       chipom2=chip2*om2
2192       chipom12=chip12*om12
2193       facp=1.0D0-om12*chipom12
2194       facp_inv=1.0D0/facp
2195       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2196 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2197 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2198 C Following variable is the square root of eps2
2199       eps2rt=1.0D0-facp1*facp_inv
2200 C Following three variables are the derivatives of the square root of eps
2201 C in om1, om2, and om12.
2202       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2203       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2204       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2205 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2206       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2207 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2208 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2209 c     &  " eps2rt_om12",eps2rt_om12
2210 C Calculate whole angle-dependent part of epsilon and contributions
2211 C to its derivatives
2212       return
2213       end
2214 C----------------------------------------------------------------------------
2215       subroutine sc_grad
2216       implicit real*8 (a-h,o-z)
2217       include 'DIMENSIONS'
2218       include 'COMMON.CHAIN'
2219       include 'COMMON.DERIV'
2220       include 'COMMON.CALC'
2221       include 'COMMON.IOUNITS'
2222       double precision dcosom1(3),dcosom2(3)
2223 cc      print *,'sss=',sss
2224       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2225       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2226       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2227      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2228 c diagnostics only
2229 c      eom1=0.0d0
2230 c      eom2=0.0d0
2231 c      eom12=evdwij*eps1_om12
2232 c end diagnostics
2233 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2234 c     &  " sigder",sigder
2235 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2236 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2237       do k=1,3
2238         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2239         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2240       enddo
2241       do k=1,3
2242         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2243       enddo
2244 c      write (iout,*) "gg",(gg(k),k=1,3)
2245       do k=1,3
2246         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2247      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2248      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2249         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2250      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2251      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2252 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2253 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2254 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2255 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2256       enddo
2257 C
2258 C Calculate the components of the gradient in DC and X
2259 C
2260 cgrad      do k=i,j-1
2261 cgrad        do l=1,3
2262 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2263 cgrad        enddo
2264 cgrad      enddo
2265       do l=1,3
2266         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2267         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2268       enddo
2269       return
2270       end
2271 C-----------------------------------------------------------------------
2272       subroutine e_softsphere(evdw)
2273 C
2274 C This subroutine calculates the interaction energy of nonbonded side chains
2275 C assuming the LJ potential of interaction.
2276 C
2277       implicit real*8 (a-h,o-z)
2278       include 'DIMENSIONS'
2279       parameter (accur=1.0d-10)
2280       include 'COMMON.GEO'
2281       include 'COMMON.VAR'
2282       include 'COMMON.LOCAL'
2283       include 'COMMON.CHAIN'
2284       include 'COMMON.DERIV'
2285       include 'COMMON.INTERACT'
2286       include 'COMMON.TORSION'
2287       include 'COMMON.SBRIDGE'
2288       include 'COMMON.NAMES'
2289       include 'COMMON.IOUNITS'
2290       include 'COMMON.CONTACTS'
2291       dimension gg(3)
2292 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2293       evdw=0.0D0
2294       do i=iatsc_s,iatsc_e
2295         itypi=iabs(itype(i))
2296         if (itypi.eq.ntyp1) cycle
2297         itypi1=iabs(itype(i+1))
2298         xi=c(1,nres+i)
2299         yi=c(2,nres+i)
2300         zi=c(3,nres+i)
2301 C
2302 C Calculate SC interaction energy.
2303 C
2304         do iint=1,nint_gr(i)
2305 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2306 cd   &                  'iend=',iend(i,iint)
2307           do j=istart(i,iint),iend(i,iint)
2308             itypj=iabs(itype(j))
2309             if (itypj.eq.ntyp1) cycle
2310             xj=c(1,nres+j)-xi
2311             yj=c(2,nres+j)-yi
2312             zj=c(3,nres+j)-zi
2313             rij=xj*xj+yj*yj+zj*zj
2314 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2315             r0ij=r0(itypi,itypj)
2316             r0ijsq=r0ij*r0ij
2317 c            print *,i,j,r0ij,dsqrt(rij)
2318             if (rij.lt.r0ijsq) then
2319               evdwij=0.25d0*(rij-r0ijsq)**2
2320               fac=rij-r0ijsq
2321             else
2322               evdwij=0.0d0
2323               fac=0.0d0
2324             endif
2325             evdw=evdw+evdwij
2326 C
2327 C Calculate the components of the gradient in DC and X
2328 C
2329             gg(1)=xj*fac
2330             gg(2)=yj*fac
2331             gg(3)=zj*fac
2332             do k=1,3
2333               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2334               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2335               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2336               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2337             enddo
2338 cgrad            do k=i,j-1
2339 cgrad              do l=1,3
2340 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2341 cgrad              enddo
2342 cgrad            enddo
2343           enddo ! j
2344         enddo ! iint
2345       enddo ! i
2346       return
2347       end
2348 C--------------------------------------------------------------------------
2349       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2350      &              eello_turn4)
2351 C
2352 C Soft-sphere potential of p-p interaction
2353 C
2354       implicit real*8 (a-h,o-z)
2355       include 'DIMENSIONS'
2356       include 'COMMON.CONTROL'
2357       include 'COMMON.IOUNITS'
2358       include 'COMMON.GEO'
2359       include 'COMMON.VAR'
2360       include 'COMMON.LOCAL'
2361       include 'COMMON.CHAIN'
2362       include 'COMMON.DERIV'
2363       include 'COMMON.INTERACT'
2364       include 'COMMON.CONTACTS'
2365       include 'COMMON.TORSION'
2366       include 'COMMON.VECTORS'
2367       include 'COMMON.FFIELD'
2368       dimension ggg(3)
2369 C      write(iout,*) 'In EELEC_soft_sphere'
2370       ees=0.0D0
2371       evdw1=0.0D0
2372       eel_loc=0.0d0
2373       eello_turn3=0.0d0
2374       eello_turn4=0.0d0
2375       ind=0
2376       do i=iatel_s,iatel_e
2377         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2378         dxi=dc(1,i)
2379         dyi=dc(2,i)
2380         dzi=dc(3,i)
2381         xmedi=c(1,i)+0.5d0*dxi
2382         ymedi=c(2,i)+0.5d0*dyi
2383         zmedi=c(3,i)+0.5d0*dzi
2384           xmedi=mod(xmedi,boxxsize)
2385           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2386           ymedi=mod(ymedi,boxysize)
2387           if (ymedi.lt.0) ymedi=ymedi+boxysize
2388           zmedi=mod(zmedi,boxzsize)
2389           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2390         num_conti=0
2391 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2392         do j=ielstart(i),ielend(i)
2393           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2394           ind=ind+1
2395           iteli=itel(i)
2396           itelj=itel(j)
2397           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2398           r0ij=rpp(iteli,itelj)
2399           r0ijsq=r0ij*r0ij
2400           dxj=dc(1,j)
2401           dyj=dc(2,j)
2402           dzj=dc(3,j)
2403           xj=c(1,j)+0.5D0*dxj
2404           yj=c(2,j)+0.5D0*dyj
2405           zj=c(3,j)+0.5D0*dzj
2406           xj=mod(xj,boxxsize)
2407           if (xj.lt.0) xj=xj+boxxsize
2408           yj=mod(yj,boxysize)
2409           if (yj.lt.0) yj=yj+boxysize
2410           zj=mod(zj,boxzsize)
2411           if (zj.lt.0) zj=zj+boxzsize
2412       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2413       xj_safe=xj
2414       yj_safe=yj
2415       zj_safe=zj
2416       isubchap=0
2417       do xshift=-1,1
2418       do yshift=-1,1
2419       do zshift=-1,1
2420           xj=xj_safe+xshift*boxxsize
2421           yj=yj_safe+yshift*boxysize
2422           zj=zj_safe+zshift*boxzsize
2423           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2424           if(dist_temp.lt.dist_init) then
2425             dist_init=dist_temp
2426             xj_temp=xj
2427             yj_temp=yj
2428             zj_temp=zj
2429             isubchap=1
2430           endif
2431        enddo
2432        enddo
2433        enddo
2434        if (isubchap.eq.1) then
2435           xj=xj_temp-xmedi
2436           yj=yj_temp-ymedi
2437           zj=zj_temp-zmedi
2438        else
2439           xj=xj_safe-xmedi
2440           yj=yj_safe-ymedi
2441           zj=zj_safe-zmedi
2442        endif
2443           rij=xj*xj+yj*yj+zj*zj
2444             sss=sscale(sqrt(rij))
2445             sssgrad=sscagrad(sqrt(rij))
2446           if (rij.lt.r0ijsq) then
2447             evdw1ij=0.25d0*(rij-r0ijsq)**2
2448             fac=rij-r0ijsq
2449           else
2450             evdw1ij=0.0d0
2451             fac=0.0d0
2452           endif
2453           evdw1=evdw1+evdw1ij*sss
2454 C
2455 C Calculate contributions to the Cartesian gradient.
2456 C
2457           ggg(1)=fac*xj*sssgrad
2458           ggg(2)=fac*yj*sssgrad
2459           ggg(3)=fac*zj*sssgrad
2460           do k=1,3
2461             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2462             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2463           enddo
2464 *
2465 * Loop over residues i+1 thru j-1.
2466 *
2467 cgrad          do k=i+1,j-1
2468 cgrad            do l=1,3
2469 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2470 cgrad            enddo
2471 cgrad          enddo
2472         enddo ! j
2473       enddo   ! i
2474 cgrad      do i=nnt,nct-1
2475 cgrad        do k=1,3
2476 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2477 cgrad        enddo
2478 cgrad        do j=i+1,nct-1
2479 cgrad          do k=1,3
2480 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2481 cgrad          enddo
2482 cgrad        enddo
2483 cgrad      enddo
2484       return
2485       end
2486 c------------------------------------------------------------------------------
2487       subroutine vec_and_deriv
2488       implicit real*8 (a-h,o-z)
2489       include 'DIMENSIONS'
2490 #ifdef MPI
2491       include 'mpif.h'
2492 #endif
2493       include 'COMMON.IOUNITS'
2494       include 'COMMON.GEO'
2495       include 'COMMON.VAR'
2496       include 'COMMON.LOCAL'
2497       include 'COMMON.CHAIN'
2498       include 'COMMON.VECTORS'
2499       include 'COMMON.SETUP'
2500       include 'COMMON.TIME1'
2501       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2502 C Compute the local reference systems. For reference system (i), the
2503 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2504 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2505 #ifdef PARVEC
2506       do i=ivec_start,ivec_end
2507 #else
2508       do i=1,nres-1
2509 #endif
2510           if (i.eq.nres-1) then
2511 C Case of the last full residue
2512 C Compute the Z-axis
2513             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2514             costh=dcos(pi-theta(nres))
2515             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2516             do k=1,3
2517               uz(k,i)=fac*uz(k,i)
2518             enddo
2519 C Compute the derivatives of uz
2520             uzder(1,1,1)= 0.0d0
2521             uzder(2,1,1)=-dc_norm(3,i-1)
2522             uzder(3,1,1)= dc_norm(2,i-1)
2523             uzder(1,2,1)= dc_norm(3,i-1)
2524             uzder(2,2,1)= 0.0d0
2525             uzder(3,2,1)=-dc_norm(1,i-1)
2526             uzder(1,3,1)=-dc_norm(2,i-1)
2527             uzder(2,3,1)= dc_norm(1,i-1)
2528             uzder(3,3,1)= 0.0d0
2529             uzder(1,1,2)= 0.0d0
2530             uzder(2,1,2)= dc_norm(3,i)
2531             uzder(3,1,2)=-dc_norm(2,i)
2532             uzder(1,2,2)=-dc_norm(3,i)
2533             uzder(2,2,2)= 0.0d0
2534             uzder(3,2,2)= dc_norm(1,i)
2535             uzder(1,3,2)= dc_norm(2,i)
2536             uzder(2,3,2)=-dc_norm(1,i)
2537             uzder(3,3,2)= 0.0d0
2538 C Compute the Y-axis
2539             facy=fac
2540             do k=1,3
2541               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2542             enddo
2543 C Compute the derivatives of uy
2544             do j=1,3
2545               do k=1,3
2546                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2547      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2548                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2549               enddo
2550               uyder(j,j,1)=uyder(j,j,1)-costh
2551               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2552             enddo
2553             do j=1,2
2554               do k=1,3
2555                 do l=1,3
2556                   uygrad(l,k,j,i)=uyder(l,k,j)
2557                   uzgrad(l,k,j,i)=uzder(l,k,j)
2558                 enddo
2559               enddo
2560             enddo
2561             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2562             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2563             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2564             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2565           else
2566 C Other residues
2567 C Compute the Z-axis
2568             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2569             costh=dcos(pi-theta(i+2))
2570             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2571             do k=1,3
2572               uz(k,i)=fac*uz(k,i)
2573             enddo
2574 C Compute the derivatives of uz
2575             uzder(1,1,1)= 0.0d0
2576             uzder(2,1,1)=-dc_norm(3,i+1)
2577             uzder(3,1,1)= dc_norm(2,i+1)
2578             uzder(1,2,1)= dc_norm(3,i+1)
2579             uzder(2,2,1)= 0.0d0
2580             uzder(3,2,1)=-dc_norm(1,i+1)
2581             uzder(1,3,1)=-dc_norm(2,i+1)
2582             uzder(2,3,1)= dc_norm(1,i+1)
2583             uzder(3,3,1)= 0.0d0
2584             uzder(1,1,2)= 0.0d0
2585             uzder(2,1,2)= dc_norm(3,i)
2586             uzder(3,1,2)=-dc_norm(2,i)
2587             uzder(1,2,2)=-dc_norm(3,i)
2588             uzder(2,2,2)= 0.0d0
2589             uzder(3,2,2)= dc_norm(1,i)
2590             uzder(1,3,2)= dc_norm(2,i)
2591             uzder(2,3,2)=-dc_norm(1,i)
2592             uzder(3,3,2)= 0.0d0
2593 C Compute the Y-axis
2594             facy=fac
2595             do k=1,3
2596               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2597             enddo
2598 C Compute the derivatives of uy
2599             do j=1,3
2600               do k=1,3
2601                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2602      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2603                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2604               enddo
2605               uyder(j,j,1)=uyder(j,j,1)-costh
2606               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2607             enddo
2608             do j=1,2
2609               do k=1,3
2610                 do l=1,3
2611                   uygrad(l,k,j,i)=uyder(l,k,j)
2612                   uzgrad(l,k,j,i)=uzder(l,k,j)
2613                 enddo
2614               enddo
2615             enddo
2616             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2617             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2618             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2619             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2620           endif
2621       enddo
2622       do i=1,nres-1
2623         vbld_inv_temp(1)=vbld_inv(i+1)
2624         if (i.lt.nres-1) then
2625           vbld_inv_temp(2)=vbld_inv(i+2)
2626           else
2627           vbld_inv_temp(2)=vbld_inv(i)
2628           endif
2629         do j=1,2
2630           do k=1,3
2631             do l=1,3
2632               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2633               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2634             enddo
2635           enddo
2636         enddo
2637       enddo
2638 #if defined(PARVEC) && defined(MPI)
2639       if (nfgtasks1.gt.1) then
2640         time00=MPI_Wtime()
2641 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2642 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2643 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2644         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2645      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2646      &   FG_COMM1,IERR)
2647         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2648      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2651      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2652      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2653         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2654      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2655      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2656         time_gather=time_gather+MPI_Wtime()-time00
2657       endif
2658 c      if (fg_rank.eq.0) then
2659 c        write (iout,*) "Arrays UY and UZ"
2660 c        do i=1,nres-1
2661 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2662 c     &     (uz(k,i),k=1,3)
2663 c        enddo
2664 c      endif
2665 #endif
2666       return
2667       end
2668 C-----------------------------------------------------------------------------
2669       subroutine check_vecgrad
2670       implicit real*8 (a-h,o-z)
2671       include 'DIMENSIONS'
2672       include 'COMMON.IOUNITS'
2673       include 'COMMON.GEO'
2674       include 'COMMON.VAR'
2675       include 'COMMON.LOCAL'
2676       include 'COMMON.CHAIN'
2677       include 'COMMON.VECTORS'
2678       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2679       dimension uyt(3,maxres),uzt(3,maxres)
2680       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2681       double precision delta /1.0d-7/
2682       call vec_and_deriv
2683 cd      do i=1,nres
2684 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2685 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2686 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2687 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2688 cd     &     (dc_norm(if90,i),if90=1,3)
2689 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2690 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2691 cd          write(iout,'(a)')
2692 cd      enddo
2693       do i=1,nres
2694         do j=1,2
2695           do k=1,3
2696             do l=1,3
2697               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2698               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2699             enddo
2700           enddo
2701         enddo
2702       enddo
2703       call vec_and_deriv
2704       do i=1,nres
2705         do j=1,3
2706           uyt(j,i)=uy(j,i)
2707           uzt(j,i)=uz(j,i)
2708         enddo
2709       enddo
2710       do i=1,nres
2711 cd        write (iout,*) 'i=',i
2712         do k=1,3
2713           erij(k)=dc_norm(k,i)
2714         enddo
2715         do j=1,3
2716           do k=1,3
2717             dc_norm(k,i)=erij(k)
2718           enddo
2719           dc_norm(j,i)=dc_norm(j,i)+delta
2720 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2721 c          do k=1,3
2722 c            dc_norm(k,i)=dc_norm(k,i)/fac
2723 c          enddo
2724 c          write (iout,*) (dc_norm(k,i),k=1,3)
2725 c          write (iout,*) (erij(k),k=1,3)
2726           call vec_and_deriv
2727           do k=1,3
2728             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2729             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2730             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2731             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2732           enddo
2733 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2734 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2735 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2736         enddo
2737         do k=1,3
2738           dc_norm(k,i)=erij(k)
2739         enddo
2740 cd        do k=1,3
2741 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2742 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2743 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2744 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2745 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2746 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2747 cd          write (iout,'(a)')
2748 cd        enddo
2749       enddo
2750       return
2751       end
2752 C--------------------------------------------------------------------------
2753       subroutine set_matrices
2754       implicit real*8 (a-h,o-z)
2755       include 'DIMENSIONS'
2756 #ifdef MPI
2757       include "mpif.h"
2758       include "COMMON.SETUP"
2759       integer IERR
2760       integer status(MPI_STATUS_SIZE)
2761 #endif
2762       include 'COMMON.IOUNITS'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.CONTACTS'
2770       include 'COMMON.TORSION'
2771       include 'COMMON.VECTORS'
2772       include 'COMMON.FFIELD'
2773       double precision auxvec(2),auxmat(2,2)
2774 C
2775 C Compute the virtual-bond-torsional-angle dependent quantities needed
2776 C to calculate the el-loc multibody terms of various order.
2777 C
2778 c      write(iout,*) 'nphi=',nphi,nres
2779 #ifdef PARMAT
2780       do i=ivec_start+2,ivec_end+2
2781 #else
2782       do i=3,nres+1
2783 #endif
2784 #ifdef NEWCORR
2785         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2786           iti = itortyp(itype(i-2))
2787         else
2788           iti=ntortyp+1
2789         endif
2790 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2791         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2792           iti1 = itortyp(itype(i-1))
2793         else
2794           iti1=ntortyp+1
2795         endif
2796 c        write(iout,*),i
2797         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2798      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2799      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2800         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2801      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2802      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2803 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2804 c     &*(cos(theta(i)/2.0)
2805         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2806      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2807      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2808 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2809 c     &*(cos(theta(i)/2.0)
2810         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2811      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2812      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2813 c        if (ggb1(1,i).eq.0.0d0) then
2814 c        write(iout,*) 'i=',i,ggb1(1,i),
2815 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2816 c     &bnew1(2,1,iti)*cos(theta(i)),
2817 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2818 c        endif
2819         b1(2,i-2)=bnew1(1,2,iti)
2820         gtb1(2,i-2)=0.0
2821         b2(2,i-2)=bnew2(1,2,iti)
2822         gtb2(2,i-2)=0.0
2823         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2824         EE(1,2,i-2)=eeold(1,2,iti)
2825         EE(2,1,i-2)=eeold(2,1,iti)
2826         EE(2,2,i-2)=eeold(2,2,iti)
2827         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2828         gtEE(1,2,i-2)=0.0d0
2829         gtEE(2,2,i-2)=0.0d0
2830         gtEE(2,1,i-2)=0.0d0
2831 c        EE(2,2,iti)=0.0d0
2832 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2833 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2834 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2835 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2836        b1tilde(1,i-2)=b1(1,i-2)
2837        b1tilde(2,i-2)=-b1(2,i-2)
2838        b2tilde(1,i-2)=b2(1,i-2)
2839        b2tilde(2,i-2)=-b2(2,i-2)
2840 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2841 c       write(iout,*)  'b1=',b1(1,i-2)
2842 c       write (iout,*) 'theta=', theta(i-1)
2843        enddo
2844 #else
2845         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2846           iti = itortyp(itype(i-2))
2847         else
2848           iti=ntortyp+1
2849         endif
2850 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2851         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2852           iti1 = itortyp(itype(i-1))
2853         else
2854           iti1=ntortyp+1
2855         endif
2856         b1(1,i-2)=b(3,iti)
2857         b1(2,i-2)=b(5,iti)
2858         b2(1,i-2)=b(2,iti)
2859         b2(2,i-2)=b(4,iti)
2860        b1tilde(1,i-2)=b1(1,i-2)
2861        b1tilde(2,i-2)=-b1(2,i-2)
2862        b2tilde(1,i-2)=b2(1,i-2)
2863        b2tilde(2,i-2)=-b2(2,i-2)
2864         EE(1,2,i-2)=eeold(1,2,iti)
2865         EE(2,1,i-2)=eeold(2,1,iti)
2866         EE(2,2,i-2)=eeold(2,2,iti)
2867         EE(1,1,i-2)=eeold(1,1,iti)
2868       enddo
2869 #endif
2870 #ifdef PARMAT
2871       do i=ivec_start+2,ivec_end+2
2872 #else
2873       do i=3,nres+1
2874 #endif
2875         if (i .lt. nres+1) then
2876           sin1=dsin(phi(i))
2877           cos1=dcos(phi(i))
2878           sintab(i-2)=sin1
2879           costab(i-2)=cos1
2880           obrot(1,i-2)=cos1
2881           obrot(2,i-2)=sin1
2882           sin2=dsin(2*phi(i))
2883           cos2=dcos(2*phi(i))
2884           sintab2(i-2)=sin2
2885           costab2(i-2)=cos2
2886           obrot2(1,i-2)=cos2
2887           obrot2(2,i-2)=sin2
2888           Ug(1,1,i-2)=-cos1
2889           Ug(1,2,i-2)=-sin1
2890           Ug(2,1,i-2)=-sin1
2891           Ug(2,2,i-2)= cos1
2892           Ug2(1,1,i-2)=-cos2
2893           Ug2(1,2,i-2)=-sin2
2894           Ug2(2,1,i-2)=-sin2
2895           Ug2(2,2,i-2)= cos2
2896         else
2897           costab(i-2)=1.0d0
2898           sintab(i-2)=0.0d0
2899           obrot(1,i-2)=1.0d0
2900           obrot(2,i-2)=0.0d0
2901           obrot2(1,i-2)=0.0d0
2902           obrot2(2,i-2)=0.0d0
2903           Ug(1,1,i-2)=1.0d0
2904           Ug(1,2,i-2)=0.0d0
2905           Ug(2,1,i-2)=0.0d0
2906           Ug(2,2,i-2)=1.0d0
2907           Ug2(1,1,i-2)=0.0d0
2908           Ug2(1,2,i-2)=0.0d0
2909           Ug2(2,1,i-2)=0.0d0
2910           Ug2(2,2,i-2)=0.0d0
2911         endif
2912         if (i .gt. 3 .and. i .lt. nres+1) then
2913           obrot_der(1,i-2)=-sin1
2914           obrot_der(2,i-2)= cos1
2915           Ugder(1,1,i-2)= sin1
2916           Ugder(1,2,i-2)=-cos1
2917           Ugder(2,1,i-2)=-cos1
2918           Ugder(2,2,i-2)=-sin1
2919           dwacos2=cos2+cos2
2920           dwasin2=sin2+sin2
2921           obrot2_der(1,i-2)=-dwasin2
2922           obrot2_der(2,i-2)= dwacos2
2923           Ug2der(1,1,i-2)= dwasin2
2924           Ug2der(1,2,i-2)=-dwacos2
2925           Ug2der(2,1,i-2)=-dwacos2
2926           Ug2der(2,2,i-2)=-dwasin2
2927         else
2928           obrot_der(1,i-2)=0.0d0
2929           obrot_der(2,i-2)=0.0d0
2930           Ugder(1,1,i-2)=0.0d0
2931           Ugder(1,2,i-2)=0.0d0
2932           Ugder(2,1,i-2)=0.0d0
2933           Ugder(2,2,i-2)=0.0d0
2934           obrot2_der(1,i-2)=0.0d0
2935           obrot2_der(2,i-2)=0.0d0
2936           Ug2der(1,1,i-2)=0.0d0
2937           Ug2der(1,2,i-2)=0.0d0
2938           Ug2der(2,1,i-2)=0.0d0
2939           Ug2der(2,2,i-2)=0.0d0
2940         endif
2941 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2942         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2943           iti = itortyp(itype(i-2))
2944         else
2945           iti=ntortyp
2946         endif
2947 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2948         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2949           iti1 = itortyp(itype(i-1))
2950         else
2951           iti1=ntortyp
2952         endif
2953 cd        write (iout,*) '*******i',i,' iti1',iti
2954 cd        write (iout,*) 'b1',b1(:,iti)
2955 cd        write (iout,*) 'b2',b2(:,iti)
2956 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2957 c        if (i .gt. iatel_s+2) then
2958         if (i .gt. nnt+2) then
2959           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2960 #ifdef NEWCORR
2961           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2962 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2963 #endif
2964 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2965 c     &    EE(1,2,iti),EE(2,2,iti)
2966           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2967           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2968 c          write(iout,*) "Macierz EUG",
2969 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2970 c     &    eug(2,2,i-2)
2971           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2972      &    then
2973           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2974           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2975           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2976           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2977           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2978           endif
2979         else
2980           do k=1,2
2981             Ub2(k,i-2)=0.0d0
2982             Ctobr(k,i-2)=0.0d0
2983             Dtobr2(k,i-2)=0.0d0
2984             do l=1,2
2985               EUg(l,k,i-2)=0.0d0
2986               CUg(l,k,i-2)=0.0d0
2987               DUg(l,k,i-2)=0.0d0
2988               DtUg2(l,k,i-2)=0.0d0
2989             enddo
2990           enddo
2991         endif
2992         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2993         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2994         do k=1,2
2995           muder(k,i-2)=Ub2der(k,i-2)
2996         enddo
2997 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2998         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2999           if (itype(i-1).le.ntyp) then
3000             iti1 = itortyp(itype(i-1))
3001           else
3002             iti1=ntortyp
3003           endif
3004         else
3005           iti1=ntortyp
3006         endif
3007         do k=1,2
3008           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3009         enddo
3010 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
3011 c        write (iout,*) 'mu ',mu(:,i-2),i-2
3012 cd        write (iout,*) 'mu1',mu1(:,i-2)
3013 cd        write (iout,*) 'mu2',mu2(:,i-2)
3014         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3015      &  then
3016         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3017         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3018         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3019         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3020         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3021 C Vectors and matrices dependent on a single virtual-bond dihedral.
3022         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3023         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3024         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3025         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3026         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3027         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3028         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3029         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3030         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3031         endif
3032       enddo
3033 C Matrices dependent on two consecutive virtual-bond dihedrals.
3034 C The order of matrices is from left to right.
3035       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3036      &then
3037 c      do i=max0(ivec_start,2),ivec_end
3038       do i=2,nres-1
3039         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3040         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3041         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3042         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3043         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3044         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3045         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3046         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3047       enddo
3048       endif
3049 #if defined(MPI) && defined(PARMAT)
3050 #ifdef DEBUG
3051 c      if (fg_rank.eq.0) then
3052         write (iout,*) "Arrays UG and UGDER before GATHER"
3053         do i=1,nres-1
3054           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3055      &     ((ug(l,k,i),l=1,2),k=1,2),
3056      &     ((ugder(l,k,i),l=1,2),k=1,2)
3057         enddo
3058         write (iout,*) "Arrays UG2 and UG2DER"
3059         do i=1,nres-1
3060           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3061      &     ((ug2(l,k,i),l=1,2),k=1,2),
3062      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3063         enddo
3064         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3065         do i=1,nres-1
3066           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3067      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3068      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3069         enddo
3070         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3071         do i=1,nres-1
3072           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3073      &     costab(i),sintab(i),costab2(i),sintab2(i)
3074         enddo
3075         write (iout,*) "Array MUDER"
3076         do i=1,nres-1
3077           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3078         enddo
3079 c      endif
3080 #endif
3081       if (nfgtasks.gt.1) then
3082         time00=MPI_Wtime()
3083 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3084 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3085 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3086 #ifdef MATGATHER
3087         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3088      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3089      &   FG_COMM1,IERR)
3090         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3091      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3092      &   FG_COMM1,IERR)
3093         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3094      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3095      &   FG_COMM1,IERR)
3096         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3097      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3098      &   FG_COMM1,IERR)
3099         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3100      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3101      &   FG_COMM1,IERR)
3102         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3103      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3104      &   FG_COMM1,IERR)
3105         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3106      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3107      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3108         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3109      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3110      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3111         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3112      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3113      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3114         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3115      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3116      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3117         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3118      &  then
3119         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3121      &   FG_COMM1,IERR)
3122         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3123      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3124      &   FG_COMM1,IERR)
3125         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3126      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3127      &   FG_COMM1,IERR)
3128        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3129      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3130      &   FG_COMM1,IERR)
3131         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3132      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3133      &   FG_COMM1,IERR)
3134         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3135      &   ivec_count(fg_rank1),
3136      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3137      &   FG_COMM1,IERR)
3138         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3139      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3140      &   FG_COMM1,IERR)
3141         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3142      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3143      &   FG_COMM1,IERR)
3144         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3145      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3146      &   FG_COMM1,IERR)
3147         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3148      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3149      &   FG_COMM1,IERR)
3150         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3151      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3152      &   FG_COMM1,IERR)
3153         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3154      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3155      &   FG_COMM1,IERR)
3156         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3157      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3158      &   FG_COMM1,IERR)
3159         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3160      &   ivec_count(fg_rank1),
3161      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3162      &   FG_COMM1,IERR)
3163         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3164      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3165      &   FG_COMM1,IERR)
3166        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3167      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3168      &   FG_COMM1,IERR)
3169         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3170      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3171      &   FG_COMM1,IERR)
3172        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3173      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3174      &   FG_COMM1,IERR)
3175         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3176      &   ivec_count(fg_rank1),
3177      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3178      &   FG_COMM1,IERR)
3179         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3180      &   ivec_count(fg_rank1),
3181      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3182      &   FG_COMM1,IERR)
3183         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3184      &   ivec_count(fg_rank1),
3185      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3186      &   MPI_MAT2,FG_COMM1,IERR)
3187         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3188      &   ivec_count(fg_rank1),
3189      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3190      &   MPI_MAT2,FG_COMM1,IERR)
3191         endif
3192 #else
3193 c Passes matrix info through the ring
3194       isend=fg_rank1
3195       irecv=fg_rank1-1
3196       if (irecv.lt.0) irecv=nfgtasks1-1
3197       iprev=irecv
3198       inext=fg_rank1+1
3199       if (inext.ge.nfgtasks1) inext=0
3200       do i=1,nfgtasks1-1
3201 c        write (iout,*) "isend",isend," irecv",irecv
3202 c        call flush(iout)
3203         lensend=lentyp(isend)
3204         lenrecv=lentyp(irecv)
3205 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3206 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3207 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3208 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3209 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3210 c        write (iout,*) "Gather ROTAT1"
3211 c        call flush(iout)
3212 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3213 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3214 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3215 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3216 c        write (iout,*) "Gather ROTAT2"
3217 c        call flush(iout)
3218         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3219      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3220      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3221      &   iprev,4400+irecv,FG_COMM,status,IERR)
3222 c        write (iout,*) "Gather ROTAT_OLD"
3223 c        call flush(iout)
3224         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3225      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3226      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3227      &   iprev,5500+irecv,FG_COMM,status,IERR)
3228 c        write (iout,*) "Gather PRECOMP11"
3229 c        call flush(iout)
3230         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3231      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3232      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3233      &   iprev,6600+irecv,FG_COMM,status,IERR)
3234 c        write (iout,*) "Gather PRECOMP12"
3235 c        call flush(iout)
3236         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3237      &  then
3238         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3239      &   MPI_ROTAT2(lensend),inext,7700+isend,
3240      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3241      &   iprev,7700+irecv,FG_COMM,status,IERR)
3242 c        write (iout,*) "Gather PRECOMP21"
3243 c        call flush(iout)
3244         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3245      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3246      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3247      &   iprev,8800+irecv,FG_COMM,status,IERR)
3248 c        write (iout,*) "Gather PRECOMP22"
3249 c        call flush(iout)
3250         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3251      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3252      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3253      &   MPI_PRECOMP23(lenrecv),
3254      &   iprev,9900+irecv,FG_COMM,status,IERR)
3255 c        write (iout,*) "Gather PRECOMP23"
3256 c        call flush(iout)
3257         endif
3258         isend=irecv
3259         irecv=irecv-1
3260         if (irecv.lt.0) irecv=nfgtasks1-1
3261       enddo
3262 #endif
3263         time_gather=time_gather+MPI_Wtime()-time00
3264       endif
3265 #ifdef DEBUG
3266 c      if (fg_rank.eq.0) then
3267         write (iout,*) "Arrays UG and UGDER"
3268         do i=1,nres-1
3269           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3270      &     ((ug(l,k,i),l=1,2),k=1,2),
3271      &     ((ugder(l,k,i),l=1,2),k=1,2)
3272         enddo
3273         write (iout,*) "Arrays UG2 and UG2DER"
3274         do i=1,nres-1
3275           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3276      &     ((ug2(l,k,i),l=1,2),k=1,2),
3277      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3278         enddo
3279         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3280         do i=1,nres-1
3281           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3282      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3283      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3284         enddo
3285         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3288      &     costab(i),sintab(i),costab2(i),sintab2(i)
3289         enddo
3290         write (iout,*) "Array MUDER"
3291         do i=1,nres-1
3292           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3293         enddo
3294 c      endif
3295 #endif
3296 #endif
3297 cd      do i=1,nres
3298 cd        iti = itortyp(itype(i))
3299 cd        write (iout,*) i
3300 cd        do j=1,2
3301 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3302 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3303 cd        enddo
3304 cd      enddo
3305       return
3306       end
3307 C--------------------------------------------------------------------------
3308       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3309 C
3310 C This subroutine calculates the average interaction energy and its gradient
3311 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3312 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3313 C The potential depends both on the distance of peptide-group centers and on
3314 C the orientation of the CA-CA virtual bonds.
3315 C
3316       implicit real*8 (a-h,o-z)
3317 #ifdef MPI
3318       include 'mpif.h'
3319 #endif
3320       include 'DIMENSIONS'
3321       include 'COMMON.CONTROL'
3322       include 'COMMON.SETUP'
3323       include 'COMMON.IOUNITS'
3324       include 'COMMON.GEO'
3325       include 'COMMON.VAR'
3326       include 'COMMON.LOCAL'
3327       include 'COMMON.CHAIN'
3328       include 'COMMON.DERIV'
3329       include 'COMMON.INTERACT'
3330       include 'COMMON.CONTACTS'
3331       include 'COMMON.TORSION'
3332       include 'COMMON.VECTORS'
3333       include 'COMMON.FFIELD'
3334       include 'COMMON.TIME1'
3335       include 'COMMON.SPLITELE'
3336       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3337      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3338       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3339      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3340       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3341      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3342      &    num_conti,j1,j2
3343 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3344 #ifdef MOMENT
3345       double precision scal_el /1.0d0/
3346 #else
3347       double precision scal_el /0.5d0/
3348 #endif
3349 C 12/13/98
3350 C 13-go grudnia roku pamietnego...
3351       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3352      &                   0.0d0,1.0d0,0.0d0,
3353      &                   0.0d0,0.0d0,1.0d0/
3354 cd      write(iout,*) 'In EELEC'
3355 cd      do i=1,nloctyp
3356 cd        write(iout,*) 'Type',i
3357 cd        write(iout,*) 'B1',B1(:,i)
3358 cd        write(iout,*) 'B2',B2(:,i)
3359 cd        write(iout,*) 'CC',CC(:,:,i)
3360 cd        write(iout,*) 'DD',DD(:,:,i)
3361 cd        write(iout,*) 'EE',EE(:,:,i)
3362 cd      enddo
3363 cd      call check_vecgrad
3364 cd      stop
3365       if (icheckgrad.eq.1) then
3366         do i=1,nres-1
3367           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3368           do k=1,3
3369             dc_norm(k,i)=dc(k,i)*fac
3370           enddo
3371 c          write (iout,*) 'i',i,' fac',fac
3372         enddo
3373       endif
3374       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3375      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3376      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3377 c        call vec_and_deriv
3378 #ifdef TIMING
3379         time01=MPI_Wtime()
3380 #endif
3381         call set_matrices
3382 #ifdef TIMING
3383         time_mat=time_mat+MPI_Wtime()-time01
3384 #endif
3385       endif
3386 cd      do i=1,nres-1
3387 cd        write (iout,*) 'i=',i
3388 cd        do k=1,3
3389 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3390 cd        enddo
3391 cd        do k=1,3
3392 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3393 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3394 cd        enddo
3395 cd      enddo
3396       t_eelecij=0.0d0
3397       ees=0.0D0
3398       evdw1=0.0D0
3399       eel_loc=0.0d0
3400       eello_turn3=0.0d0
3401       eello_turn4=0.0d0
3402       ind=0
3403       do i=1,nres
3404         num_cont_hb(i)=0
3405       enddo
3406 cd      print '(a)','Enter EELEC'
3407 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3408       do i=1,nres
3409         gel_loc_loc(i)=0.0d0
3410         gcorr_loc(i)=0.0d0
3411       enddo
3412 c
3413 c
3414 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3415 C
3416 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3417 C
3418 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3419       do i=iturn3_start,iturn3_end
3420         if (i.le.1) cycle
3421 C        write(iout,*) "tu jest i",i
3422         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3423 C changes suggested by Ana to avoid out of bounds
3424      & .or.((i+4).gt.nres)
3425      & .or.((i-1).le.0)
3426 C end of changes by Ana
3427      &  .or. itype(i+2).eq.ntyp1
3428      &  .or. itype(i+3).eq.ntyp1) cycle
3429         if(i.gt.1)then
3430           if(itype(i-1).eq.ntyp1)cycle
3431         end if
3432         if(i.LT.nres-3)then
3433           if (itype(i+4).eq.ntyp1) cycle
3434         end if
3435         dxi=dc(1,i)
3436         dyi=dc(2,i)
3437         dzi=dc(3,i)
3438         dx_normi=dc_norm(1,i)
3439         dy_normi=dc_norm(2,i)
3440         dz_normi=dc_norm(3,i)
3441         xmedi=c(1,i)+0.5d0*dxi
3442         ymedi=c(2,i)+0.5d0*dyi
3443         zmedi=c(3,i)+0.5d0*dzi
3444           xmedi=mod(xmedi,boxxsize)
3445           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3446           ymedi=mod(ymedi,boxysize)
3447           if (ymedi.lt.0) ymedi=ymedi+boxysize
3448           zmedi=mod(zmedi,boxzsize)
3449           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3450         num_conti=0
3451         call eelecij(i,i+2,ees,evdw1,eel_loc)
3452         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3453         num_cont_hb(i)=num_conti
3454       enddo
3455       do i=iturn4_start,iturn4_end
3456         if (i.le.1) cycle
3457         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3458 C changes suggested by Ana to avoid out of bounds
3459      & .or.((i+5).gt.nres)
3460      & .or.((i-1).le.0)
3461 C end of changes suggested by Ana
3462      &    .or. itype(i+3).eq.ntyp1
3463      &    .or. itype(i+4).eq.ntyp1
3464      &    .or. itype(i+5).eq.ntyp1
3465      &    .or. itype(i).eq.ntyp1
3466      &    .or. itype(i-1).eq.ntyp1
3467      &                             ) cycle
3468         dxi=dc(1,i)
3469         dyi=dc(2,i)
3470         dzi=dc(3,i)
3471         dx_normi=dc_norm(1,i)
3472         dy_normi=dc_norm(2,i)
3473         dz_normi=dc_norm(3,i)
3474         xmedi=c(1,i)+0.5d0*dxi
3475         ymedi=c(2,i)+0.5d0*dyi
3476         zmedi=c(3,i)+0.5d0*dzi
3477 C Return atom into box, boxxsize is size of box in x dimension
3478 c  194   continue
3479 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3480 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3481 C Condition for being inside the proper box
3482 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3483 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3484 c        go to 194
3485 c        endif
3486 c  195   continue
3487 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3488 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3489 C Condition for being inside the proper box
3490 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3491 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3492 c        go to 195
3493 c        endif
3494 c  196   continue
3495 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3496 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3497 C Condition for being inside the proper box
3498 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3499 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3500 c        go to 196
3501 c        endif
3502           xmedi=mod(xmedi,boxxsize)
3503           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3504           ymedi=mod(ymedi,boxysize)
3505           if (ymedi.lt.0) ymedi=ymedi+boxysize
3506           zmedi=mod(zmedi,boxzsize)
3507           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3508
3509         num_conti=num_cont_hb(i)
3510 c        write(iout,*) "JESTEM W PETLI"
3511         call eelecij(i,i+3,ees,evdw1,eel_loc)
3512         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3513      &   call eturn4(i,eello_turn4)
3514         num_cont_hb(i)=num_conti
3515       enddo   ! i
3516 C Loop over all neighbouring boxes
3517 C      do xshift=-1,1
3518 C      do yshift=-1,1
3519 C      do zshift=-1,1
3520 c
3521 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3522 c
3523 CTU KURWA
3524       do i=iatel_s,iatel_e
3525 C        do i=75,75
3526         if (i.le.1) cycle
3527         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3528 C changes suggested by Ana to avoid out of bounds
3529      & .or.((i+2).gt.nres)
3530      & .or.((i-1).le.0)
3531 C end of changes by Ana
3532      &  .or. itype(i+2).eq.ntyp1
3533      &  .or. itype(i-1).eq.ntyp1
3534      &                ) cycle
3535         dxi=dc(1,i)
3536         dyi=dc(2,i)
3537         dzi=dc(3,i)
3538         dx_normi=dc_norm(1,i)
3539         dy_normi=dc_norm(2,i)
3540         dz_normi=dc_norm(3,i)
3541         xmedi=c(1,i)+0.5d0*dxi
3542         ymedi=c(2,i)+0.5d0*dyi
3543         zmedi=c(3,i)+0.5d0*dzi
3544           xmedi=mod(xmedi,boxxsize)
3545           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3546           ymedi=mod(ymedi,boxysize)
3547           if (ymedi.lt.0) ymedi=ymedi+boxysize
3548           zmedi=mod(zmedi,boxzsize)
3549           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3550 C          xmedi=xmedi+xshift*boxxsize
3551 C          ymedi=ymedi+yshift*boxysize
3552 C          zmedi=zmedi+zshift*boxzsize
3553
3554 C Return tom into box, boxxsize is size of box in x dimension
3555 c  164   continue
3556 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3557 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3558 C Condition for being inside the proper box
3559 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3560 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3561 c        go to 164
3562 c        endif
3563 c  165   continue
3564 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3565 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3566 C Condition for being inside the proper box
3567 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3568 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3569 c        go to 165
3570 c        endif
3571 c  166   continue
3572 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3573 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3574 cC Condition for being inside the proper box
3575 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3576 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3577 c        go to 166
3578 c        endif
3579
3580 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3581         num_conti=num_cont_hb(i)
3582 C I TU KURWA
3583         do j=ielstart(i),ielend(i)
3584 C          do j=16,17
3585 C          write (iout,*) i,j
3586          if (j.le.1) cycle
3587           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3588 C changes suggested by Ana to avoid out of bounds
3589      & .or.((j+2).gt.nres)
3590      & .or.((j-1).le.0)
3591 C end of changes by Ana
3592      & .or.itype(j+2).eq.ntyp1
3593      & .or.itype(j-1).eq.ntyp1
3594      &) cycle
3595           call eelecij(i,j,ees,evdw1,eel_loc)
3596         enddo ! j
3597         num_cont_hb(i)=num_conti
3598       enddo   ! i
3599 C     enddo   ! zshift
3600 C      enddo   ! yshift
3601 C      enddo   ! xshift
3602
3603 c      write (iout,*) "Number of loop steps in EELEC:",ind
3604 cd      do i=1,nres
3605 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3606 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3607 cd      enddo
3608 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3609 ccc      eel_loc=eel_loc+eello_turn3
3610 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3611       return
3612       end
3613 C-------------------------------------------------------------------------------
3614       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3615       implicit real*8 (a-h,o-z)
3616       include 'DIMENSIONS'
3617 #ifdef MPI
3618       include "mpif.h"
3619 #endif
3620       include 'COMMON.CONTROL'
3621       include 'COMMON.IOUNITS'
3622       include 'COMMON.GEO'
3623       include 'COMMON.VAR'
3624       include 'COMMON.LOCAL'
3625       include 'COMMON.CHAIN'
3626       include 'COMMON.DERIV'
3627       include 'COMMON.INTERACT'
3628       include 'COMMON.CONTACTS'
3629       include 'COMMON.TORSION'
3630       include 'COMMON.VECTORS'
3631       include 'COMMON.FFIELD'
3632       include 'COMMON.TIME1'
3633       include 'COMMON.SPLITELE'
3634       include 'COMMON.SHIELD'
3635       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3636      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3637       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3638      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3639      &    gmuij2(4),gmuji2(4)
3640       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3641      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3642      &    num_conti,j1,j2
3643 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3644 #ifdef MOMENT
3645       double precision scal_el /1.0d0/
3646 #else
3647       double precision scal_el /0.5d0/
3648 #endif
3649 C 12/13/98
3650 C 13-go grudnia roku pamietnego...
3651       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3652      &                   0.0d0,1.0d0,0.0d0,
3653      &                   0.0d0,0.0d0,1.0d0/
3654 c          time00=MPI_Wtime()
3655 cd      write (iout,*) "eelecij",i,j
3656 c          ind=ind+1
3657           iteli=itel(i)
3658           itelj=itel(j)
3659           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3660           aaa=app(iteli,itelj)
3661           bbb=bpp(iteli,itelj)
3662           ael6i=ael6(iteli,itelj)
3663           ael3i=ael3(iteli,itelj)
3664           dxj=dc(1,j)
3665           dyj=dc(2,j)
3666           dzj=dc(3,j)
3667           dx_normj=dc_norm(1,j)
3668           dy_normj=dc_norm(2,j)
3669           dz_normj=dc_norm(3,j)
3670 C          xj=c(1,j)+0.5D0*dxj-xmedi
3671 C          yj=c(2,j)+0.5D0*dyj-ymedi
3672 C          zj=c(3,j)+0.5D0*dzj-zmedi
3673           xj=c(1,j)+0.5D0*dxj
3674           yj=c(2,j)+0.5D0*dyj
3675           zj=c(3,j)+0.5D0*dzj
3676           xj=mod(xj,boxxsize)
3677           if (xj.lt.0) xj=xj+boxxsize
3678           yj=mod(yj,boxysize)
3679           if (yj.lt.0) yj=yj+boxysize
3680           zj=mod(zj,boxzsize)
3681           if (zj.lt.0) zj=zj+boxzsize
3682           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3683       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3684       xj_safe=xj
3685       yj_safe=yj
3686       zj_safe=zj
3687       isubchap=0
3688       do xshift=-1,1
3689       do yshift=-1,1
3690       do zshift=-1,1
3691           xj=xj_safe+xshift*boxxsize
3692           yj=yj_safe+yshift*boxysize
3693           zj=zj_safe+zshift*boxzsize
3694           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3695           if(dist_temp.lt.dist_init) then
3696             dist_init=dist_temp
3697             xj_temp=xj
3698             yj_temp=yj
3699             zj_temp=zj
3700             isubchap=1
3701           endif
3702        enddo
3703        enddo
3704        enddo
3705        if (isubchap.eq.1) then
3706           xj=xj_temp-xmedi
3707           yj=yj_temp-ymedi
3708           zj=zj_temp-zmedi
3709        else
3710           xj=xj_safe-xmedi
3711           yj=yj_safe-ymedi
3712           zj=zj_safe-zmedi
3713        endif
3714 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3715 c  174   continue
3716 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3717 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3718 C Condition for being inside the proper box
3719 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3720 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3721 c        go to 174
3722 c        endif
3723 c  175   continue
3724 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3725 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3726 C Condition for being inside the proper box
3727 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3728 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3729 c        go to 175
3730 c        endif
3731 c  176   continue
3732 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3733 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3734 C Condition for being inside the proper box
3735 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3736 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3737 c        go to 176
3738 c        endif
3739 C        endif !endPBC condintion
3740 C        xj=xj-xmedi
3741 C        yj=yj-ymedi
3742 C        zj=zj-zmedi
3743           rij=xj*xj+yj*yj+zj*zj
3744
3745             sss=sscale(sqrt(rij))
3746             sssgrad=sscagrad(sqrt(rij))
3747 c            if (sss.gt.0.0d0) then
3748           rrmij=1.0D0/rij
3749           rij=dsqrt(rij)
3750           rmij=1.0D0/rij
3751           r3ij=rrmij*rmij
3752           r6ij=r3ij*r3ij
3753           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3754           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3755           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3756           fac=cosa-3.0D0*cosb*cosg
3757           ev1=aaa*r6ij*r6ij
3758 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3759           if (j.eq.i+2) ev1=scal_el*ev1
3760           ev2=bbb*r6ij
3761           fac3=ael6i*r6ij
3762           fac4=ael3i*r3ij
3763           evdwij=(ev1+ev2)
3764           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3765           el2=fac4*fac
3766 C MARYSIA
3767 C          eesij=(el1+el2)
3768 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3769           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3770           if (shield_mode.gt.0) then
3771 C          fac_shield(i)=0.4
3772 C          fac_shield(j)=0.6
3773           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3774           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3775           eesij=(el1+el2)
3776           ees=ees+eesij
3777           else
3778           fac_shield(i)=1.0
3779           fac_shield(j)=1.0
3780           eesij=(el1+el2)
3781           ees=ees+eesij
3782           endif
3783           evdw1=evdw1+evdwij*sss
3784 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3785 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3786 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3787 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3788
3789           if (energy_dec) then
3790               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3791      &'evdw1',i,j,evdwij
3792      &,iteli,itelj,aaa,evdw1
3793               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3794      &fac_shield(i),fac_shield(j)
3795           endif
3796
3797 C
3798 C Calculate contributions to the Cartesian gradient.
3799 C
3800 #ifdef SPLITELE
3801           facvdw=-6*rrmij*(ev1+evdwij)*sss
3802           facel=-3*rrmij*(el1+eesij)
3803           fac1=fac
3804           erij(1)=xj*rmij
3805           erij(2)=yj*rmij
3806           erij(3)=zj*rmij
3807
3808 *
3809 * Radial derivatives. First process both termini of the fragment (i,j)
3810 *
3811           ggg(1)=facel*xj
3812           ggg(2)=facel*yj
3813           ggg(3)=facel*zj
3814           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3815      &  (shield_mode.gt.0)) then
3816 C          print *,i,j
3817           do ilist=1,ishield_list(i)
3818            iresshield=shield_list(ilist,i)
3819            do k=1,3
3820            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3821      &      *2.0
3822            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3823      &              rlocshield
3824      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3825             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3826 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3827 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3828 C             if (iresshield.gt.i) then
3829 C               do ishi=i+1,iresshield-1
3830 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3831 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3832 C
3833 C              enddo
3834 C             else
3835 C               do ishi=iresshield,i
3836 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3837 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3838 C
3839 C               enddo
3840 C              endif
3841            enddo
3842           enddo
3843           do ilist=1,ishield_list(j)
3844            iresshield=shield_list(ilist,j)
3845            do k=1,3
3846            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3847      &     *2.0
3848            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3849      &              rlocshield
3850      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3851            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3852
3853 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3854 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3855 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3856 C             if (iresshield.gt.j) then
3857 C               do ishi=j+1,iresshield-1
3858 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3859 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3860 C
3861 C               enddo
3862 C            else
3863 C               do ishi=iresshield,j
3864 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3865 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3866 C               enddo
3867 C              endif
3868            enddo
3869           enddo
3870
3871           do k=1,3
3872             gshieldc(k,i)=gshieldc(k,i)+
3873      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3874             gshieldc(k,j)=gshieldc(k,j)+
3875      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3876             gshieldc(k,i-1)=gshieldc(k,i-1)+
3877      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3878             gshieldc(k,j-1)=gshieldc(k,j-1)+
3879      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3880
3881            enddo
3882            endif
3883 c          do k=1,3
3884 c            ghalf=0.5D0*ggg(k)
3885 c            gelc(k,i)=gelc(k,i)+ghalf
3886 c            gelc(k,j)=gelc(k,j)+ghalf
3887 c          enddo
3888 c 9/28/08 AL Gradient compotents will be summed only at the end
3889 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3890           do k=1,3
3891             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3892 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3893             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3894 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3895 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3896 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3897 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3898 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3899           enddo
3900 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3901
3902 *
3903 * Loop over residues i+1 thru j-1.
3904 *
3905 cgrad          do k=i+1,j-1
3906 cgrad            do l=1,3
3907 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3908 cgrad            enddo
3909 cgrad          enddo
3910           if (sss.gt.0.0) then
3911           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3912           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3913           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3914           else
3915           ggg(1)=0.0
3916           ggg(2)=0.0
3917           ggg(3)=0.0
3918           endif
3919 c          do k=1,3
3920 c            ghalf=0.5D0*ggg(k)
3921 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3922 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3923 c          enddo
3924 c 9/28/08 AL Gradient compotents will be summed only at the end
3925           do k=1,3
3926             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3927             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3928           enddo
3929 *
3930 * Loop over residues i+1 thru j-1.
3931 *
3932 cgrad          do k=i+1,j-1
3933 cgrad            do l=1,3
3934 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3935 cgrad            enddo
3936 cgrad          enddo
3937 #else
3938 C MARYSIA
3939           facvdw=(ev1+evdwij)*sss
3940           facel=(el1+eesij)
3941           fac1=fac
3942           fac=-3*rrmij*(facvdw+facvdw+facel)
3943           erij(1)=xj*rmij
3944           erij(2)=yj*rmij
3945           erij(3)=zj*rmij
3946 *
3947 * Radial derivatives. First process both termini of the fragment (i,j)
3948 *
3949           ggg(1)=fac*xj
3950 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3951           ggg(2)=fac*yj
3952 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3953           ggg(3)=fac*zj
3954 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3955 c          do k=1,3
3956 c            ghalf=0.5D0*ggg(k)
3957 c            gelc(k,i)=gelc(k,i)+ghalf
3958 c            gelc(k,j)=gelc(k,j)+ghalf
3959 c          enddo
3960 c 9/28/08 AL Gradient compotents will be summed only at the end
3961           do k=1,3
3962             gelc_long(k,j)=gelc(k,j)+ggg(k)
3963             gelc_long(k,i)=gelc(k,i)-ggg(k)
3964           enddo
3965 *
3966 * Loop over residues i+1 thru j-1.
3967 *
3968 cgrad          do k=i+1,j-1
3969 cgrad            do l=1,3
3970 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3971 cgrad            enddo
3972 cgrad          enddo
3973 c 9/28/08 AL Gradient compotents will be summed only at the end
3974           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3975           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3976           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3977           do k=1,3
3978             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3979             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3980           enddo
3981 #endif
3982 *
3983 * Angular part
3984 *
3985           ecosa=2.0D0*fac3*fac1+fac4
3986           fac4=-3.0D0*fac4
3987           fac3=-6.0D0*fac3
3988           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3989           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3990           do k=1,3
3991             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3992             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3993           enddo
3994 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3995 cd   &          (dcosg(k),k=1,3)
3996           do k=1,3
3997             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3998      &      fac_shield(i)**2*fac_shield(j)**2
3999           enddo
4000 c          do k=1,3
4001 c            ghalf=0.5D0*ggg(k)
4002 c            gelc(k,i)=gelc(k,i)+ghalf
4003 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4004 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4005 c            gelc(k,j)=gelc(k,j)+ghalf
4006 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4007 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4008 c          enddo
4009 cgrad          do k=i+1,j-1
4010 cgrad            do l=1,3
4011 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4012 cgrad            enddo
4013 cgrad          enddo
4014 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4015           do k=1,3
4016             gelc(k,i)=gelc(k,i)
4017      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4018      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4019      &           *fac_shield(i)**2*fac_shield(j)**2
4020             gelc(k,j)=gelc(k,j)
4021      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4022      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4023      &           *fac_shield(i)**2*fac_shield(j)**2
4024             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4025             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4026           enddo
4027 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4028
4029 C MARYSIA
4030 c          endif !sscale
4031           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4032      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4033      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4034 C
4035 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4036 C   energy of a peptide unit is assumed in the form of a second-order
4037 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4038 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4039 C   are computed for EVERY pair of non-contiguous peptide groups.
4040 C
4041
4042           if (j.lt.nres-1) then
4043             j1=j+1
4044             j2=j-1
4045           else
4046             j1=j-1
4047             j2=j-2
4048           endif
4049           kkk=0
4050           lll=0
4051           do k=1,2
4052             do l=1,2
4053               kkk=kkk+1
4054               muij(kkk)=mu(k,i)*mu(l,j)
4055 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4056 #ifdef NEWCORR
4057              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4058 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4059              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4060              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4061 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4062              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4063 #endif
4064             enddo
4065           enddo
4066 cd         write (iout,*) 'EELEC: i',i,' j',j
4067 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4068 cd          write(iout,*) 'muij',muij
4069           ury=scalar(uy(1,i),erij)
4070           urz=scalar(uz(1,i),erij)
4071           vry=scalar(uy(1,j),erij)
4072           vrz=scalar(uz(1,j),erij)
4073           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4074           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4075           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4076           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4077           fac=dsqrt(-ael6i)*r3ij
4078           a22=a22*fac
4079           a23=a23*fac
4080           a32=a32*fac
4081           a33=a33*fac
4082 cd          write (iout,'(4i5,4f10.5)')
4083 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4084 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4085 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4086 cd     &      uy(:,j),uz(:,j)
4087 cd          write (iout,'(4f10.5)')
4088 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4089 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4090 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4091 cd           write (iout,'(9f10.5/)')
4092 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4093 C Derivatives of the elements of A in virtual-bond vectors
4094           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4095           do k=1,3
4096             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4097             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4098             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4099             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4100             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4101             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4102             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4103             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4104             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4105             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4106             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4107             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4108           enddo
4109 C Compute radial contributions to the gradient
4110           facr=-3.0d0*rrmij
4111           a22der=a22*facr
4112           a23der=a23*facr
4113           a32der=a32*facr
4114           a33der=a33*facr
4115           agg(1,1)=a22der*xj
4116           agg(2,1)=a22der*yj
4117           agg(3,1)=a22der*zj
4118           agg(1,2)=a23der*xj
4119           agg(2,2)=a23der*yj
4120           agg(3,2)=a23der*zj
4121           agg(1,3)=a32der*xj
4122           agg(2,3)=a32der*yj
4123           agg(3,3)=a32der*zj
4124           agg(1,4)=a33der*xj
4125           agg(2,4)=a33der*yj
4126           agg(3,4)=a33der*zj
4127 C Add the contributions coming from er
4128           fac3=-3.0d0*fac
4129           do k=1,3
4130             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4131             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4132             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4133             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4134           enddo
4135           do k=1,3
4136 C Derivatives in DC(i)
4137 cgrad            ghalf1=0.5d0*agg(k,1)
4138 cgrad            ghalf2=0.5d0*agg(k,2)
4139 cgrad            ghalf3=0.5d0*agg(k,3)
4140 cgrad            ghalf4=0.5d0*agg(k,4)
4141             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4142      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4143             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4144      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4145             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4146      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4147             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4148      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4149 C Derivatives in DC(i+1)
4150             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4151      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4152             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4153      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4154             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4155      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4156             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4157      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4158 C Derivatives in DC(j)
4159             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4160      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4161             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4162      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4163             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4164      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4165             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4166      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4167 C Derivatives in DC(j+1) or DC(nres-1)
4168             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4169      &      -3.0d0*vryg(k,3)*ury)
4170             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4171      &      -3.0d0*vrzg(k,3)*ury)
4172             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4173      &      -3.0d0*vryg(k,3)*urz)
4174             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4175      &      -3.0d0*vrzg(k,3)*urz)
4176 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4177 cgrad              do l=1,4
4178 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4179 cgrad              enddo
4180 cgrad            endif
4181           enddo
4182           acipa(1,1)=a22
4183           acipa(1,2)=a23
4184           acipa(2,1)=a32
4185           acipa(2,2)=a33
4186           a22=-a22
4187           a23=-a23
4188           do l=1,2
4189             do k=1,3
4190               agg(k,l)=-agg(k,l)
4191               aggi(k,l)=-aggi(k,l)
4192               aggi1(k,l)=-aggi1(k,l)
4193               aggj(k,l)=-aggj(k,l)
4194               aggj1(k,l)=-aggj1(k,l)
4195             enddo
4196           enddo
4197           if (j.lt.nres-1) then
4198             a22=-a22
4199             a32=-a32
4200             do l=1,3,2
4201               do k=1,3
4202                 agg(k,l)=-agg(k,l)
4203                 aggi(k,l)=-aggi(k,l)
4204                 aggi1(k,l)=-aggi1(k,l)
4205                 aggj(k,l)=-aggj(k,l)
4206                 aggj1(k,l)=-aggj1(k,l)
4207               enddo
4208             enddo
4209           else
4210             a22=-a22
4211             a23=-a23
4212             a32=-a32
4213             a33=-a33
4214             do l=1,4
4215               do k=1,3
4216                 agg(k,l)=-agg(k,l)
4217                 aggi(k,l)=-aggi(k,l)
4218                 aggi1(k,l)=-aggi1(k,l)
4219                 aggj(k,l)=-aggj(k,l)
4220                 aggj1(k,l)=-aggj1(k,l)
4221               enddo
4222             enddo
4223           endif
4224           ENDIF ! WCORR
4225           IF (wel_loc.gt.0.0d0) THEN
4226 C Contribution to the local-electrostatic energy coming from the i-j pair
4227           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4228      &     +a33*muij(4)
4229           if (shield_mode.eq.0) then
4230            fac_shield(i)=1.0
4231            fac_shield(j)=1.0
4232 C          else
4233 C           fac_shield(i)=0.4
4234 C           fac_shield(j)=0.6
4235           endif
4236           eel_loc_ij=eel_loc_ij
4237      &    *fac_shield(i)*fac_shield(j)
4238 C Now derivative over eel_loc
4239           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4240      &  (shield_mode.gt.0)) then
4241 C          print *,i,j
4242
4243           do ilist=1,ishield_list(i)
4244            iresshield=shield_list(ilist,i)
4245            do k=1,3
4246            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4247      &                                          /fac_shield(i)
4248 C     &      *2.0
4249            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4250      &              rlocshield
4251      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4252             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4253      &      +rlocshield
4254            enddo
4255           enddo
4256           do ilist=1,ishield_list(j)
4257            iresshield=shield_list(ilist,j)
4258            do k=1,3
4259            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4260      &                                       /fac_shield(j)
4261 C     &     *2.0
4262            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4263      &              rlocshield
4264      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4265            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4266      &             +rlocshield
4267
4268            enddo
4269           enddo
4270
4271           do k=1,3
4272             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4273      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4274             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4275      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4276             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4277      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4278             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4279      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4280            enddo
4281            endif
4282
4283
4284 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4285 c     &                     ' eel_loc_ij',eel_loc_ij
4286 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4287 C Calculate patrial derivative for theta angle
4288 #ifdef NEWCORR
4289          geel_loc_ij=(a22*gmuij1(1)
4290      &     +a23*gmuij1(2)
4291      &     +a32*gmuij1(3)
4292      &     +a33*gmuij1(4))
4293      &    *fac_shield(i)*fac_shield(j)
4294 c         write(iout,*) "derivative over thatai"
4295 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4296 c     &   a33*gmuij1(4)
4297          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4298      &      geel_loc_ij*wel_loc
4299 c         write(iout,*) "derivative over thatai-1"
4300 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4301 c     &   a33*gmuij2(4)
4302          geel_loc_ij=
4303      &     a22*gmuij2(1)
4304      &     +a23*gmuij2(2)
4305      &     +a32*gmuij2(3)
4306      &     +a33*gmuij2(4)
4307          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4308      &      geel_loc_ij*wel_loc
4309      &    *fac_shield(i)*fac_shield(j)
4310
4311 c  Derivative over j residue
4312          geel_loc_ji=a22*gmuji1(1)
4313      &     +a23*gmuji1(2)
4314      &     +a32*gmuji1(3)
4315      &     +a33*gmuji1(4)
4316 c         write(iout,*) "derivative over thataj"
4317 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4318 c     &   a33*gmuji1(4)
4319
4320         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4321      &      geel_loc_ji*wel_loc
4322      &    *fac_shield(i)*fac_shield(j)
4323
4324          geel_loc_ji=
4325      &     +a22*gmuji2(1)
4326      &     +a23*gmuji2(2)
4327      &     +a32*gmuji2(3)
4328      &     +a33*gmuji2(4)
4329 c         write(iout,*) "derivative over thataj-1"
4330 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4331 c     &   a33*gmuji2(4)
4332          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4333      &      geel_loc_ji*wel_loc
4334      &    *fac_shield(i)*fac_shield(j)
4335 #endif
4336 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4337
4338           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4339      &            'eelloc',i,j,eel_loc_ij
4340 c           if (eel_loc_ij.ne.0)
4341 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4342 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4343
4344           eel_loc=eel_loc+eel_loc_ij
4345 C Partial derivatives in virtual-bond dihedral angles gamma
4346           if (i.gt.1)
4347      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4348      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4349      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4350      &    *fac_shield(i)*fac_shield(j)
4351
4352           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4353      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4354      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4355      &    *fac_shield(i)*fac_shield(j)
4356 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4357           do l=1,3
4358             ggg(l)=(agg(l,1)*muij(1)+
4359      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4360      &    *fac_shield(i)*fac_shield(j)
4361             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4362             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4363 cgrad            ghalf=0.5d0*ggg(l)
4364 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4365 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4366           enddo
4367 cgrad          do k=i+1,j2
4368 cgrad            do l=1,3
4369 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4370 cgrad            enddo
4371 cgrad          enddo
4372 C Remaining derivatives of eello
4373           do l=1,3
4374             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4375      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4376      &    *fac_shield(i)*fac_shield(j)
4377
4378             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4379      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4380      &    *fac_shield(i)*fac_shield(j)
4381
4382             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4383      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4384      &    *fac_shield(i)*fac_shield(j)
4385
4386             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4387      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4388      &    *fac_shield(i)*fac_shield(j)
4389
4390           enddo
4391           ENDIF
4392 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4393 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4394           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4395      &       .and. num_conti.le.maxconts) then
4396 c            write (iout,*) i,j," entered corr"
4397 C
4398 C Calculate the contact function. The ith column of the array JCONT will
4399 C contain the numbers of atoms that make contacts with the atom I (of numbers
4400 C greater than I). The arrays FACONT and GACONT will contain the values of
4401 C the contact function and its derivative.
4402 c           r0ij=1.02D0*rpp(iteli,itelj)
4403 c           r0ij=1.11D0*rpp(iteli,itelj)
4404             r0ij=2.20D0*rpp(iteli,itelj)
4405 c           r0ij=1.55D0*rpp(iteli,itelj)
4406             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4407             if (fcont.gt.0.0D0) then
4408               num_conti=num_conti+1
4409               if (num_conti.gt.maxconts) then
4410                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4411      &                         ' will skip next contacts for this conf.'
4412               else
4413                 jcont_hb(num_conti,i)=j
4414 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4415 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4416                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4417      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4418 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4419 C  terms.
4420                 d_cont(num_conti,i)=rij
4421 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4422 C     --- Electrostatic-interaction matrix ---
4423                 a_chuj(1,1,num_conti,i)=a22
4424                 a_chuj(1,2,num_conti,i)=a23
4425                 a_chuj(2,1,num_conti,i)=a32
4426                 a_chuj(2,2,num_conti,i)=a33
4427 C     --- Gradient of rij
4428                 do kkk=1,3
4429                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4430                 enddo
4431                 kkll=0
4432                 do k=1,2
4433                   do l=1,2
4434                     kkll=kkll+1
4435                     do m=1,3
4436                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4437                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4438                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4439                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4440                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4441                     enddo
4442                   enddo
4443                 enddo
4444                 ENDIF
4445                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4446 C Calculate contact energies
4447                 cosa4=4.0D0*cosa
4448                 wij=cosa-3.0D0*cosb*cosg
4449                 cosbg1=cosb+cosg
4450                 cosbg2=cosb-cosg
4451 c               fac3=dsqrt(-ael6i)/r0ij**3
4452                 fac3=dsqrt(-ael6i)*r3ij
4453 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4454                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4455                 if (ees0tmp.gt.0) then
4456                   ees0pij=dsqrt(ees0tmp)
4457                 else
4458                   ees0pij=0
4459                 endif
4460 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4461                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4462                 if (ees0tmp.gt.0) then
4463                   ees0mij=dsqrt(ees0tmp)
4464                 else
4465                   ees0mij=0
4466                 endif
4467 c               ees0mij=0.0D0
4468                 if (shield_mode.eq.0) then
4469                 fac_shield(i)=1.0d0
4470                 fac_shield(j)=1.0d0
4471                 else
4472                 ees0plist(num_conti,i)=j
4473 C                fac_shield(i)=0.4d0
4474 C                fac_shield(j)=0.6d0
4475                 endif
4476                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4477      &          *fac_shield(i)*fac_shield(j)
4478                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4479      &          *fac_shield(i)*fac_shield(j)
4480 C Diagnostics. Comment out or remove after debugging!
4481 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4482 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4483 c               ees0m(num_conti,i)=0.0D0
4484 C End diagnostics.
4485 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4486 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4487 C Angular derivatives of the contact function
4488                 ees0pij1=fac3/ees0pij
4489                 ees0mij1=fac3/ees0mij
4490                 fac3p=-3.0D0*fac3*rrmij
4491                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4492                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4493 c               ees0mij1=0.0D0
4494                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4495                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4496                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4497                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4498                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4499                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4500                 ecosap=ecosa1+ecosa2
4501                 ecosbp=ecosb1+ecosb2
4502                 ecosgp=ecosg1+ecosg2
4503                 ecosam=ecosa1-ecosa2
4504                 ecosbm=ecosb1-ecosb2
4505                 ecosgm=ecosg1-ecosg2
4506 C Diagnostics
4507 c               ecosap=ecosa1
4508 c               ecosbp=ecosb1
4509 c               ecosgp=ecosg1
4510 c               ecosam=0.0D0
4511 c               ecosbm=0.0D0
4512 c               ecosgm=0.0D0
4513 C End diagnostics
4514                 facont_hb(num_conti,i)=fcont
4515                 fprimcont=fprimcont/rij
4516 cd              facont_hb(num_conti,i)=1.0D0
4517 C Following line is for diagnostics.
4518 cd              fprimcont=0.0D0
4519                 do k=1,3
4520                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4521                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4522                 enddo
4523                 do k=1,3
4524                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4525                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4526                 enddo
4527                 gggp(1)=gggp(1)+ees0pijp*xj
4528                 gggp(2)=gggp(2)+ees0pijp*yj
4529                 gggp(3)=gggp(3)+ees0pijp*zj
4530                 gggm(1)=gggm(1)+ees0mijp*xj
4531                 gggm(2)=gggm(2)+ees0mijp*yj
4532                 gggm(3)=gggm(3)+ees0mijp*zj
4533 C Derivatives due to the contact function
4534                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4535                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4536                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4537                 do k=1,3
4538 c
4539 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4540 c          following the change of gradient-summation algorithm.
4541 c
4542 cgrad                  ghalfp=0.5D0*gggp(k)
4543 cgrad                  ghalfm=0.5D0*gggm(k)
4544                   gacontp_hb1(k,num_conti,i)=!ghalfp
4545      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4546      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4547      &          *fac_shield(i)*fac_shield(j)
4548
4549                   gacontp_hb2(k,num_conti,i)=!ghalfp
4550      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4551      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4552      &          *fac_shield(i)*fac_shield(j)
4553
4554                   gacontp_hb3(k,num_conti,i)=gggp(k)
4555      &          *fac_shield(i)*fac_shield(j)
4556
4557                   gacontm_hb1(k,num_conti,i)=!ghalfm
4558      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4559      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4560      &          *fac_shield(i)*fac_shield(j)
4561
4562                   gacontm_hb2(k,num_conti,i)=!ghalfm
4563      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4564      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4565      &          *fac_shield(i)*fac_shield(j)
4566
4567                   gacontm_hb3(k,num_conti,i)=gggm(k)
4568      &          *fac_shield(i)*fac_shield(j)
4569
4570                 enddo
4571 C Diagnostics. Comment out or remove after debugging!
4572 cdiag           do k=1,3
4573 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4574 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4575 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4576 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4577 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4578 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4579 cdiag           enddo
4580               ENDIF ! wcorr
4581               endif  ! num_conti.le.maxconts
4582             endif  ! fcont.gt.0
4583           endif    ! j.gt.i+1
4584           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4585             do k=1,4
4586               do l=1,3
4587                 ghalf=0.5d0*agg(l,k)
4588                 aggi(l,k)=aggi(l,k)+ghalf
4589                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4590                 aggj(l,k)=aggj(l,k)+ghalf
4591               enddo
4592             enddo
4593             if (j.eq.nres-1 .and. i.lt.j-2) then
4594               do k=1,4
4595                 do l=1,3
4596                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4597                 enddo
4598               enddo
4599             endif
4600           endif
4601 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4602       return
4603       end
4604 C-----------------------------------------------------------------------------
4605       subroutine eturn3(i,eello_turn3)
4606 C Third- and fourth-order contributions from turns
4607       implicit real*8 (a-h,o-z)
4608       include 'DIMENSIONS'
4609       include 'COMMON.IOUNITS'
4610       include 'COMMON.GEO'
4611       include 'COMMON.VAR'
4612       include 'COMMON.LOCAL'
4613       include 'COMMON.CHAIN'
4614       include 'COMMON.DERIV'
4615       include 'COMMON.INTERACT'
4616       include 'COMMON.CONTACTS'
4617       include 'COMMON.TORSION'
4618       include 'COMMON.VECTORS'
4619       include 'COMMON.FFIELD'
4620       include 'COMMON.CONTROL'
4621       include 'COMMON.SHIELD'
4622       dimension ggg(3)
4623       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4624      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4625      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4626      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4627      &  auxgmat2(2,2),auxgmatt2(2,2)
4628       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4629      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4630       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4631      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4632      &    num_conti,j1,j2
4633       j=i+2
4634 c      write (iout,*) "eturn3",i,j,j1,j2
4635       a_temp(1,1)=a22
4636       a_temp(1,2)=a23
4637       a_temp(2,1)=a32
4638       a_temp(2,2)=a33
4639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4640 C
4641 C               Third-order contributions
4642 C
4643 C                 (i+2)o----(i+3)
4644 C                      | |
4645 C                      | |
4646 C                 (i+1)o----i
4647 C
4648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4649 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4650         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4651 c auxalary matices for theta gradient
4652 c auxalary matrix for i+1 and constant i+2
4653         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4654 c auxalary matrix for i+2 and constant i+1
4655         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4656         call transpose2(auxmat(1,1),auxmat1(1,1))
4657         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4658         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4659         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4660         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4661         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4662         if (shield_mode.eq.0) then
4663         fac_shield(i)=1.0
4664         fac_shield(j)=1.0
4665 C        else
4666 C        fac_shield(i)=0.4
4667 C        fac_shield(j)=0.6
4668         endif
4669         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4670      &  *fac_shield(i)*fac_shield(j)
4671         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4672      &  *fac_shield(i)*fac_shield(j)
4673 C Derivatives in theta
4674         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4675      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4676      &   *fac_shield(i)*fac_shield(j)
4677         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4678      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4679      &   *fac_shield(i)*fac_shield(j)
4680
4681
4682 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4683 C Derivatives in shield mode
4684           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4685      &  (shield_mode.gt.0)) then
4686 C          print *,i,j
4687
4688           do ilist=1,ishield_list(i)
4689            iresshield=shield_list(ilist,i)
4690            do k=1,3
4691            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4692 C     &      *2.0
4693            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4694      &              rlocshield
4695      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4696             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4697      &      +rlocshield
4698            enddo
4699           enddo
4700           do ilist=1,ishield_list(j)
4701            iresshield=shield_list(ilist,j)
4702            do k=1,3
4703            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4704 C     &     *2.0
4705            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4706      &              rlocshield
4707      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4708            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4709      &             +rlocshield
4710
4711            enddo
4712           enddo
4713
4714           do k=1,3
4715             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4716      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4717             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4718      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4719             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4720      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4721             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4722      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4723            enddo
4724            endif
4725
4726 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4727 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4728 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4729 cd     &    ' eello_turn3_num',4*eello_turn3_num
4730 C Derivatives in gamma(i)
4731         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4732         call transpose2(auxmat2(1,1),auxmat3(1,1))
4733         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4734         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4735      &   *fac_shield(i)*fac_shield(j)
4736 C Derivatives in gamma(i+1)
4737         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4738         call transpose2(auxmat2(1,1),auxmat3(1,1))
4739         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4740         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4741      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4742      &   *fac_shield(i)*fac_shield(j)
4743 C Cartesian derivatives
4744         do l=1,3
4745 c            ghalf1=0.5d0*agg(l,1)
4746 c            ghalf2=0.5d0*agg(l,2)
4747 c            ghalf3=0.5d0*agg(l,3)
4748 c            ghalf4=0.5d0*agg(l,4)
4749           a_temp(1,1)=aggi(l,1)!+ghalf1
4750           a_temp(1,2)=aggi(l,2)!+ghalf2
4751           a_temp(2,1)=aggi(l,3)!+ghalf3
4752           a_temp(2,2)=aggi(l,4)!+ghalf4
4753           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4754           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4755      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4756      &   *fac_shield(i)*fac_shield(j)
4757
4758           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4759           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4760           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4761           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4762           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4763           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4764      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4765      &   *fac_shield(i)*fac_shield(j)
4766           a_temp(1,1)=aggj(l,1)!+ghalf1
4767           a_temp(1,2)=aggj(l,2)!+ghalf2
4768           a_temp(2,1)=aggj(l,3)!+ghalf3
4769           a_temp(2,2)=aggj(l,4)!+ghalf4
4770           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4771           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4772      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4773      &   *fac_shield(i)*fac_shield(j)
4774           a_temp(1,1)=aggj1(l,1)
4775           a_temp(1,2)=aggj1(l,2)
4776           a_temp(2,1)=aggj1(l,3)
4777           a_temp(2,2)=aggj1(l,4)
4778           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4779           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4780      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4781      &   *fac_shield(i)*fac_shield(j)
4782         enddo
4783       return
4784       end
4785 C-------------------------------------------------------------------------------
4786       subroutine eturn4(i,eello_turn4)
4787 C Third- and fourth-order contributions from turns
4788       implicit real*8 (a-h,o-z)
4789       include 'DIMENSIONS'
4790       include 'COMMON.IOUNITS'
4791       include 'COMMON.GEO'
4792       include 'COMMON.VAR'
4793       include 'COMMON.LOCAL'
4794       include 'COMMON.CHAIN'
4795       include 'COMMON.DERIV'
4796       include 'COMMON.INTERACT'
4797       include 'COMMON.CONTACTS'
4798       include 'COMMON.TORSION'
4799       include 'COMMON.VECTORS'
4800       include 'COMMON.FFIELD'
4801       include 'COMMON.CONTROL'
4802       include 'COMMON.SHIELD'
4803       dimension ggg(3)
4804       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4805      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4806      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4807      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4808      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4809      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4810      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4811       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4812      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4813       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4814      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4815      &    num_conti,j1,j2
4816       j=i+3
4817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4818 C
4819 C               Fourth-order contributions
4820 C
4821 C                 (i+3)o----(i+4)
4822 C                     /  |
4823 C               (i+2)o   |
4824 C                     \  |
4825 C                 (i+1)o----i
4826 C
4827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4828 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4829 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4830 c        write(iout,*)"WCHODZE W PROGRAM"
4831         a_temp(1,1)=a22
4832         a_temp(1,2)=a23
4833         a_temp(2,1)=a32
4834         a_temp(2,2)=a33
4835         iti1=itortyp(itype(i+1))
4836         iti2=itortyp(itype(i+2))
4837         iti3=itortyp(itype(i+3))
4838 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4839         call transpose2(EUg(1,1,i+1),e1t(1,1))
4840         call transpose2(Eug(1,1,i+2),e2t(1,1))
4841         call transpose2(Eug(1,1,i+3),e3t(1,1))
4842 C Ematrix derivative in theta
4843         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4844         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4845         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4846         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4847 c       eta1 in derivative theta
4848         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4849         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4850 c       auxgvec is derivative of Ub2 so i+3 theta
4851         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4852 c       auxalary matrix of E i+1
4853         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4854 c        s1=0.0
4855 c        gs1=0.0
4856         s1=scalar2(b1(1,i+2),auxvec(1))
4857 c derivative of theta i+2 with constant i+3
4858         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4859 c derivative of theta i+2 with constant i+2
4860         gs32=scalar2(b1(1,i+2),auxgvec(1))
4861 c derivative of E matix in theta of i+1
4862         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4863
4864         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4865 c       ea31 in derivative theta
4866         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4867         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4868 c auxilary matrix auxgvec of Ub2 with constant E matirx
4869         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4870 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4871         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4872
4873 c        s2=0.0
4874 c        gs2=0.0
4875         s2=scalar2(b1(1,i+1),auxvec(1))
4876 c derivative of theta i+1 with constant i+3
4877         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4878 c derivative of theta i+2 with constant i+1
4879         gs21=scalar2(b1(1,i+1),auxgvec(1))
4880 c derivative of theta i+3 with constant i+1
4881         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4882 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4883 c     &  gtb1(1,i+1)
4884         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4885 c two derivatives over diffetent matrices
4886 c gtae3e2 is derivative over i+3
4887         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4888 c ae3gte2 is derivative over i+2
4889         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4890         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4891 c three possible derivative over theta E matices
4892 c i+1
4893         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4894 c i+2
4895         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4896 c i+3
4897         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4898         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4899
4900         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4901         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4902         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4903         if (shield_mode.eq.0) then
4904         fac_shield(i)=1.0
4905         fac_shield(j)=1.0
4906 C        else
4907 C        fac_shield(i)=0.6
4908 C        fac_shield(j)=0.4
4909         endif
4910         eello_turn4=eello_turn4-(s1+s2+s3)
4911      &  *fac_shield(i)*fac_shield(j)
4912         eello_t4=-(s1+s2+s3)
4913      &  *fac_shield(i)*fac_shield(j)
4914 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4915         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4916      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4917 C Now derivative over shield:
4918           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4919      &  (shield_mode.gt.0)) then
4920 C          print *,i,j
4921
4922           do ilist=1,ishield_list(i)
4923            iresshield=shield_list(ilist,i)
4924            do k=1,3
4925            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4926 C     &      *2.0
4927            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4928      &              rlocshield
4929      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4930             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4931      &      +rlocshield
4932            enddo
4933           enddo
4934           do ilist=1,ishield_list(j)
4935            iresshield=shield_list(ilist,j)
4936            do k=1,3
4937            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4938 C     &     *2.0
4939            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4940      &              rlocshield
4941      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4942            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4943      &             +rlocshield
4944
4945            enddo
4946           enddo
4947
4948           do k=1,3
4949             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4950      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4951             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4952      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4953             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4954      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4955             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4956      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4957            enddo
4958            endif
4959
4960
4961
4962
4963
4964
4965 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4966 cd     &    ' eello_turn4_num',8*eello_turn4_num
4967 #ifdef NEWCORR
4968         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4969      &                  -(gs13+gsE13+gsEE1)*wturn4
4970      &  *fac_shield(i)*fac_shield(j)
4971         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4972      &                    -(gs23+gs21+gsEE2)*wturn4
4973      &  *fac_shield(i)*fac_shield(j)
4974
4975         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4976      &                    -(gs32+gsE31+gsEE3)*wturn4
4977      &  *fac_shield(i)*fac_shield(j)
4978
4979 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4980 c     &   gs2
4981 #endif
4982         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4983      &      'eturn4',i,j,-(s1+s2+s3)
4984 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4985 c     &    ' eello_turn4_num',8*eello_turn4_num
4986 C Derivatives in gamma(i)
4987         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4988         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4989         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4990         s1=scalar2(b1(1,i+2),auxvec(1))
4991         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4992         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4993         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4994      &  *fac_shield(i)*fac_shield(j)
4995 C Derivatives in gamma(i+1)
4996         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4997         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4998         s2=scalar2(b1(1,i+1),auxvec(1))
4999         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5000         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5001         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5002         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5003      &  *fac_shield(i)*fac_shield(j)
5004 C Derivatives in gamma(i+2)
5005         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5006         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5007         s1=scalar2(b1(1,i+2),auxvec(1))
5008         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5009         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5010         s2=scalar2(b1(1,i+1),auxvec(1))
5011         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5012         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5013         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5014         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5015      &  *fac_shield(i)*fac_shield(j)
5016 C Cartesian derivatives
5017 C Derivatives of this turn contributions in DC(i+2)
5018         if (j.lt.nres-1) then
5019           do l=1,3
5020             a_temp(1,1)=agg(l,1)
5021             a_temp(1,2)=agg(l,2)
5022             a_temp(2,1)=agg(l,3)
5023             a_temp(2,2)=agg(l,4)
5024             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5025             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5026             s1=scalar2(b1(1,i+2),auxvec(1))
5027             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5028             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5029             s2=scalar2(b1(1,i+1),auxvec(1))
5030             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5031             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5032             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5033             ggg(l)=-(s1+s2+s3)
5034             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5035      &  *fac_shield(i)*fac_shield(j)
5036           enddo
5037         endif
5038 C Remaining derivatives of this turn contribution
5039         do l=1,3
5040           a_temp(1,1)=aggi(l,1)
5041           a_temp(1,2)=aggi(l,2)
5042           a_temp(2,1)=aggi(l,3)
5043           a_temp(2,2)=aggi(l,4)
5044           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5045           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5046           s1=scalar2(b1(1,i+2),auxvec(1))
5047           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5048           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5049           s2=scalar2(b1(1,i+1),auxvec(1))
5050           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5051           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5052           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5053           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5054      &  *fac_shield(i)*fac_shield(j)
5055           a_temp(1,1)=aggi1(l,1)
5056           a_temp(1,2)=aggi1(l,2)
5057           a_temp(2,1)=aggi1(l,3)
5058           a_temp(2,2)=aggi1(l,4)
5059           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5060           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5061           s1=scalar2(b1(1,i+2),auxvec(1))
5062           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5063           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5064           s2=scalar2(b1(1,i+1),auxvec(1))
5065           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5066           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5067           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5068           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5069      &  *fac_shield(i)*fac_shield(j)
5070           a_temp(1,1)=aggj(l,1)
5071           a_temp(1,2)=aggj(l,2)
5072           a_temp(2,1)=aggj(l,3)
5073           a_temp(2,2)=aggj(l,4)
5074           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5075           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5076           s1=scalar2(b1(1,i+2),auxvec(1))
5077           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5078           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5079           s2=scalar2(b1(1,i+1),auxvec(1))
5080           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5081           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5082           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5083           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5084      &  *fac_shield(i)*fac_shield(j)
5085           a_temp(1,1)=aggj1(l,1)
5086           a_temp(1,2)=aggj1(l,2)
5087           a_temp(2,1)=aggj1(l,3)
5088           a_temp(2,2)=aggj1(l,4)
5089           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5090           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5091           s1=scalar2(b1(1,i+2),auxvec(1))
5092           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5093           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5094           s2=scalar2(b1(1,i+1),auxvec(1))
5095           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5096           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5097           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5098 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5099           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5100      &  *fac_shield(i)*fac_shield(j)
5101         enddo
5102       return
5103       end
5104 C-----------------------------------------------------------------------------
5105       subroutine vecpr(u,v,w)
5106       implicit real*8(a-h,o-z)
5107       dimension u(3),v(3),w(3)
5108       w(1)=u(2)*v(3)-u(3)*v(2)
5109       w(2)=-u(1)*v(3)+u(3)*v(1)
5110       w(3)=u(1)*v(2)-u(2)*v(1)
5111       return
5112       end
5113 C-----------------------------------------------------------------------------
5114       subroutine unormderiv(u,ugrad,unorm,ungrad)
5115 C This subroutine computes the derivatives of a normalized vector u, given
5116 C the derivatives computed without normalization conditions, ugrad. Returns
5117 C ungrad.
5118       implicit none
5119       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5120       double precision vec(3)
5121       double precision scalar
5122       integer i,j
5123 c      write (2,*) 'ugrad',ugrad
5124 c      write (2,*) 'u',u
5125       do i=1,3
5126         vec(i)=scalar(ugrad(1,i),u(1))
5127       enddo
5128 c      write (2,*) 'vec',vec
5129       do i=1,3
5130         do j=1,3
5131           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5132         enddo
5133       enddo
5134 c      write (2,*) 'ungrad',ungrad
5135       return
5136       end
5137 C-----------------------------------------------------------------------------
5138       subroutine escp_soft_sphere(evdw2,evdw2_14)
5139 C
5140 C This subroutine calculates the excluded-volume interaction energy between
5141 C peptide-group centers and side chains and its gradient in virtual-bond and
5142 C side-chain vectors.
5143 C
5144       implicit real*8 (a-h,o-z)
5145       include 'DIMENSIONS'
5146       include 'COMMON.GEO'
5147       include 'COMMON.VAR'
5148       include 'COMMON.LOCAL'
5149       include 'COMMON.CHAIN'
5150       include 'COMMON.DERIV'
5151       include 'COMMON.INTERACT'
5152       include 'COMMON.FFIELD'
5153       include 'COMMON.IOUNITS'
5154       include 'COMMON.CONTROL'
5155       dimension ggg(3)
5156       evdw2=0.0D0
5157       evdw2_14=0.0d0
5158       r0_scp=4.5d0
5159 cd    print '(a)','Enter ESCP'
5160 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5161 C      do xshift=-1,1
5162 C      do yshift=-1,1
5163 C      do zshift=-1,1
5164       do i=iatscp_s,iatscp_e
5165         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5166         iteli=itel(i)
5167         xi=0.5D0*(c(1,i)+c(1,i+1))
5168         yi=0.5D0*(c(2,i)+c(2,i+1))
5169         zi=0.5D0*(c(3,i)+c(3,i+1))
5170 C Return atom into box, boxxsize is size of box in x dimension
5171 c  134   continue
5172 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5173 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5174 C Condition for being inside the proper box
5175 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5176 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5177 c        go to 134
5178 c        endif
5179 c  135   continue
5180 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5181 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5182 C Condition for being inside the proper box
5183 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5184 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5185 c        go to 135
5186 c c       endif
5187 c  136   continue
5188 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5189 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5190 cC Condition for being inside the proper box
5191 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5192 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5193 c        go to 136
5194 c        endif
5195           xi=mod(xi,boxxsize)
5196           if (xi.lt.0) xi=xi+boxxsize
5197           yi=mod(yi,boxysize)
5198           if (yi.lt.0) yi=yi+boxysize
5199           zi=mod(zi,boxzsize)
5200           if (zi.lt.0) zi=zi+boxzsize
5201 C          xi=xi+xshift*boxxsize
5202 C          yi=yi+yshift*boxysize
5203 C          zi=zi+zshift*boxzsize
5204         do iint=1,nscp_gr(i)
5205
5206         do j=iscpstart(i,iint),iscpend(i,iint)
5207           if (itype(j).eq.ntyp1) cycle
5208           itypj=iabs(itype(j))
5209 C Uncomment following three lines for SC-p interactions
5210 c         xj=c(1,nres+j)-xi
5211 c         yj=c(2,nres+j)-yi
5212 c         zj=c(3,nres+j)-zi
5213 C Uncomment following three lines for Ca-p interactions
5214           xj=c(1,j)
5215           yj=c(2,j)
5216           zj=c(3,j)
5217 c  174   continue
5218 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5219 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5220 C Condition for being inside the proper box
5221 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5222 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5223 c        go to 174
5224 c        endif
5225 c  175   continue
5226 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5227 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5228 cC Condition for being inside the proper box
5229 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5230 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5231 c        go to 175
5232 c        endif
5233 c  176   continue
5234 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5235 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5236 C Condition for being inside the proper box
5237 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5238 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5239 c        go to 176
5240           xj=mod(xj,boxxsize)
5241           if (xj.lt.0) xj=xj+boxxsize
5242           yj=mod(yj,boxysize)
5243           if (yj.lt.0) yj=yj+boxysize
5244           zj=mod(zj,boxzsize)
5245           if (zj.lt.0) zj=zj+boxzsize
5246       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5247       xj_safe=xj
5248       yj_safe=yj
5249       zj_safe=zj
5250       subchap=0
5251       do xshift=-1,1
5252       do yshift=-1,1
5253       do zshift=-1,1
5254           xj=xj_safe+xshift*boxxsize
5255           yj=yj_safe+yshift*boxysize
5256           zj=zj_safe+zshift*boxzsize
5257           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5258           if(dist_temp.lt.dist_init) then
5259             dist_init=dist_temp
5260             xj_temp=xj
5261             yj_temp=yj
5262             zj_temp=zj
5263             subchap=1
5264           endif
5265        enddo
5266        enddo
5267        enddo
5268        if (subchap.eq.1) then
5269           xj=xj_temp-xi
5270           yj=yj_temp-yi
5271           zj=zj_temp-zi
5272        else
5273           xj=xj_safe-xi
5274           yj=yj_safe-yi
5275           zj=zj_safe-zi
5276        endif
5277 c c       endif
5278 C          xj=xj-xi
5279 C          yj=yj-yi
5280 C          zj=zj-zi
5281           rij=xj*xj+yj*yj+zj*zj
5282
5283           r0ij=r0_scp
5284           r0ijsq=r0ij*r0ij
5285           if (rij.lt.r0ijsq) then
5286             evdwij=0.25d0*(rij-r0ijsq)**2
5287             fac=rij-r0ijsq
5288           else
5289             evdwij=0.0d0
5290             fac=0.0d0
5291           endif
5292           evdw2=evdw2+evdwij
5293 C
5294 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5295 C
5296           ggg(1)=xj*fac
5297           ggg(2)=yj*fac
5298           ggg(3)=zj*fac
5299 cgrad          if (j.lt.i) then
5300 cd          write (iout,*) 'j<i'
5301 C Uncomment following three lines for SC-p interactions
5302 c           do k=1,3
5303 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5304 c           enddo
5305 cgrad          else
5306 cd          write (iout,*) 'j>i'
5307 cgrad            do k=1,3
5308 cgrad              ggg(k)=-ggg(k)
5309 C Uncomment following line for SC-p interactions
5310 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5311 cgrad            enddo
5312 cgrad          endif
5313 cgrad          do k=1,3
5314 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5315 cgrad          enddo
5316 cgrad          kstart=min0(i+1,j)
5317 cgrad          kend=max0(i-1,j-1)
5318 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5319 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5320 cgrad          do k=kstart,kend
5321 cgrad            do l=1,3
5322 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5323 cgrad            enddo
5324 cgrad          enddo
5325           do k=1,3
5326             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5327             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5328           enddo
5329         enddo
5330
5331         enddo ! iint
5332       enddo ! i
5333 C      enddo !zshift
5334 C      enddo !yshift
5335 C      enddo !xshift
5336       return
5337       end
5338 C-----------------------------------------------------------------------------
5339       subroutine escp(evdw2,evdw2_14)
5340 C
5341 C This subroutine calculates the excluded-volume interaction energy between
5342 C peptide-group centers and side chains and its gradient in virtual-bond and
5343 C side-chain vectors.
5344 C
5345       implicit real*8 (a-h,o-z)
5346       include 'DIMENSIONS'
5347       include 'COMMON.GEO'
5348       include 'COMMON.VAR'
5349       include 'COMMON.LOCAL'
5350       include 'COMMON.CHAIN'
5351       include 'COMMON.DERIV'
5352       include 'COMMON.INTERACT'
5353       include 'COMMON.FFIELD'
5354       include 'COMMON.IOUNITS'
5355       include 'COMMON.CONTROL'
5356       include 'COMMON.SPLITELE'
5357       dimension ggg(3)
5358       evdw2=0.0D0
5359       evdw2_14=0.0d0
5360 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5361 cd    print '(a)','Enter ESCP'
5362 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5363 C      do xshift=-1,1
5364 C      do yshift=-1,1
5365 C      do zshift=-1,1
5366       do i=iatscp_s,iatscp_e
5367         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5368         iteli=itel(i)
5369         xi=0.5D0*(c(1,i)+c(1,i+1))
5370         yi=0.5D0*(c(2,i)+c(2,i+1))
5371         zi=0.5D0*(c(3,i)+c(3,i+1))
5372           xi=mod(xi,boxxsize)
5373           if (xi.lt.0) xi=xi+boxxsize
5374           yi=mod(yi,boxysize)
5375           if (yi.lt.0) yi=yi+boxysize
5376           zi=mod(zi,boxzsize)
5377           if (zi.lt.0) zi=zi+boxzsize
5378 c          xi=xi+xshift*boxxsize
5379 c          yi=yi+yshift*boxysize
5380 c          zi=zi+zshift*boxzsize
5381 c        print *,xi,yi,zi,'polozenie i'
5382 C Return atom into box, boxxsize is size of box in x dimension
5383 c  134   continue
5384 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5385 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5386 C Condition for being inside the proper box
5387 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5388 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5389 c        go to 134
5390 c        endif
5391 c  135   continue
5392 c          print *,xi,boxxsize,"pierwszy"
5393
5394 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5395 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5396 C Condition for being inside the proper box
5397 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5398 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5399 c        go to 135
5400 c        endif
5401 c  136   continue
5402 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5403 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5404 C Condition for being inside the proper box
5405 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5406 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5407 c        go to 136
5408 c        endif
5409         do iint=1,nscp_gr(i)
5410
5411         do j=iscpstart(i,iint),iscpend(i,iint)
5412           itypj=iabs(itype(j))
5413           if (itypj.eq.ntyp1) cycle
5414 C Uncomment following three lines for SC-p interactions
5415 c         xj=c(1,nres+j)-xi
5416 c         yj=c(2,nres+j)-yi
5417 c         zj=c(3,nres+j)-zi
5418 C Uncomment following three lines for Ca-p interactions
5419           xj=c(1,j)
5420           yj=c(2,j)
5421           zj=c(3,j)
5422           xj=mod(xj,boxxsize)
5423           if (xj.lt.0) xj=xj+boxxsize
5424           yj=mod(yj,boxysize)
5425           if (yj.lt.0) yj=yj+boxysize
5426           zj=mod(zj,boxzsize)
5427           if (zj.lt.0) zj=zj+boxzsize
5428 c  174   continue
5429 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5430 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5431 C Condition for being inside the proper box
5432 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5433 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5434 c        go to 174
5435 c        endif
5436 c  175   continue
5437 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5438 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5439 cC Condition for being inside the proper box
5440 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5441 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5442 c        go to 175
5443 c        endif
5444 c  176   continue
5445 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5446 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5447 C Condition for being inside the proper box
5448 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5449 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5450 c        go to 176
5451 c        endif
5452 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5453       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5454       xj_safe=xj
5455       yj_safe=yj
5456       zj_safe=zj
5457       subchap=0
5458       do xshift=-1,1
5459       do yshift=-1,1
5460       do zshift=-1,1
5461           xj=xj_safe+xshift*boxxsize
5462           yj=yj_safe+yshift*boxysize
5463           zj=zj_safe+zshift*boxzsize
5464           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5465           if(dist_temp.lt.dist_init) then
5466             dist_init=dist_temp
5467             xj_temp=xj
5468             yj_temp=yj
5469             zj_temp=zj
5470             subchap=1
5471           endif
5472        enddo
5473        enddo
5474        enddo
5475        if (subchap.eq.1) then
5476           xj=xj_temp-xi
5477           yj=yj_temp-yi
5478           zj=zj_temp-zi
5479        else
5480           xj=xj_safe-xi
5481           yj=yj_safe-yi
5482           zj=zj_safe-zi
5483        endif
5484 c          print *,xj,yj,zj,'polozenie j'
5485           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5486 c          print *,rrij
5487           sss=sscale(1.0d0/(dsqrt(rrij)))
5488 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5489 c          if (sss.eq.0) print *,'czasem jest OK'
5490           if (sss.le.0.0d0) cycle
5491           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5492           fac=rrij**expon2
5493           e1=fac*fac*aad(itypj,iteli)
5494           e2=fac*bad(itypj,iteli)
5495           if (iabs(j-i) .le. 2) then
5496             e1=scal14*e1
5497             e2=scal14*e2
5498             evdw2_14=evdw2_14+(e1+e2)*sss
5499           endif
5500           evdwij=e1+e2
5501           evdw2=evdw2+evdwij*sss
5502           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5503      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5504      &       bad(itypj,iteli)
5505 C
5506 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5507 C
5508           fac=-(evdwij+e1)*rrij*sss
5509           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5510           ggg(1)=xj*fac
5511           ggg(2)=yj*fac
5512           ggg(3)=zj*fac
5513 cgrad          if (j.lt.i) then
5514 cd          write (iout,*) 'j<i'
5515 C Uncomment following three lines for SC-p interactions
5516 c           do k=1,3
5517 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5518 c           enddo
5519 cgrad          else
5520 cd          write (iout,*) 'j>i'
5521 cgrad            do k=1,3
5522 cgrad              ggg(k)=-ggg(k)
5523 C Uncomment following line for SC-p interactions
5524 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5525 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5526 cgrad            enddo
5527 cgrad          endif
5528 cgrad          do k=1,3
5529 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5530 cgrad          enddo
5531 cgrad          kstart=min0(i+1,j)
5532 cgrad          kend=max0(i-1,j-1)
5533 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5534 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5535 cgrad          do k=kstart,kend
5536 cgrad            do l=1,3
5537 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5538 cgrad            enddo
5539 cgrad          enddo
5540           do k=1,3
5541             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5542             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5543           enddo
5544 c        endif !endif for sscale cutoff
5545         enddo ! j
5546
5547         enddo ! iint
5548       enddo ! i
5549 c      enddo !zshift
5550 c      enddo !yshift
5551 c      enddo !xshift
5552       do i=1,nct
5553         do j=1,3
5554           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5555           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5556           gradx_scp(j,i)=expon*gradx_scp(j,i)
5557         enddo
5558       enddo
5559 C******************************************************************************
5560 C
5561 C                              N O T E !!!
5562 C
5563 C To save time the factor EXPON has been extracted from ALL components
5564 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5565 C use!
5566 C
5567 C******************************************************************************
5568       return
5569       end
5570 C--------------------------------------------------------------------------
5571       subroutine edis(ehpb)
5572 C
5573 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5574 C
5575       implicit real*8 (a-h,o-z)
5576       include 'DIMENSIONS'
5577       include 'COMMON.SBRIDGE'
5578       include 'COMMON.CHAIN'
5579       include 'COMMON.DERIV'
5580       include 'COMMON.VAR'
5581       include 'COMMON.INTERACT'
5582       include 'COMMON.IOUNITS'
5583       include 'COMMON.CONTROL'
5584       dimension ggg(3)
5585       ehpb=0.0D0
5586       do i=1,3
5587        ggg(i)=0.0d0
5588       enddo
5589 C      write (iout,*) ,"link_end",link_end,constr_dist
5590 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5591 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5592       if (link_end.eq.0) return
5593       do i=link_start,link_end
5594 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5595 C CA-CA distance used in regularization of structure.
5596         ii=ihpb(i)
5597         jj=jhpb(i)
5598 C iii and jjj point to the residues for which the distance is assigned.
5599         if (ii.gt.nres) then
5600           iii=ii-nres
5601           jjj=jj-nres
5602         else
5603           iii=ii
5604           jjj=jj
5605         endif
5606 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5607 c     &    dhpb(i),dhpb1(i),forcon(i)
5608 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5609 C    distance and angle dependent SS bond potential.
5610 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5611 C     & iabs(itype(jjj)).eq.1) then
5612 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5613 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5614         if (.not.dyn_ss .and. i.le.nss) then
5615 C 15/02/13 CC dynamic SSbond - additional check
5616          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5617      & iabs(itype(jjj)).eq.1) then
5618           call ssbond_ene(iii,jjj,eij)
5619           ehpb=ehpb+2*eij
5620          endif
5621 cd          write (iout,*) "eij",eij
5622 cd   &   ' waga=',waga,' fac=',fac
5623         else if (ii.gt.nres .and. jj.gt.nres) then
5624 c Restraints from contact prediction
5625           dd=dist(ii,jj)
5626           if (constr_dist.eq.11) then
5627             ehpb=ehpb+fordepth(i)**4.0d0
5628      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5629             fac=fordepth(i)**4.0d0
5630      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5631           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5632      &    ehpb,fordepth(i),dd
5633            else
5634           if (dhpb1(i).gt.0.0d0) then
5635             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5636             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5637 c            write (iout,*) "beta nmr",
5638 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5639           else
5640             dd=dist(ii,jj)
5641             rdis=dd-dhpb(i)
5642 C Get the force constant corresponding to this distance.
5643             waga=forcon(i)
5644 C Calculate the contribution to energy.
5645             ehpb=ehpb+waga*rdis*rdis
5646 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5647 C
5648 C Evaluate gradient.
5649 C
5650             fac=waga*rdis/dd
5651           endif
5652           endif
5653           do j=1,3
5654             ggg(j)=fac*(c(j,jj)-c(j,ii))
5655           enddo
5656           do j=1,3
5657             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5658             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5659           enddo
5660           do k=1,3
5661             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5662             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5663           enddo
5664         else
5665 C Calculate the distance between the two points and its difference from the
5666 C target distance.
5667           dd=dist(ii,jj)
5668           if (constr_dist.eq.11) then
5669             ehpb=ehpb+fordepth(i)**4.0d0
5670      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5671             fac=fordepth(i)**4.0d0
5672      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5673           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5674      &    ehpb,fordepth(i),dd
5675            else
5676           if (dhpb1(i).gt.0.0d0) then
5677             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5678             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5679 c            write (iout,*) "alph nmr",
5680 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5681           else
5682             rdis=dd-dhpb(i)
5683 C Get the force constant corresponding to this distance.
5684             waga=forcon(i)
5685 C Calculate the contribution to energy.
5686             ehpb=ehpb+waga*rdis*rdis
5687 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5688 C
5689 C Evaluate gradient.
5690 C
5691             fac=waga*rdis/dd
5692           endif
5693           endif
5694             do j=1,3
5695               ggg(j)=fac*(c(j,jj)-c(j,ii))
5696             enddo
5697 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5698 C If this is a SC-SC distance, we need to calculate the contributions to the
5699 C Cartesian gradient in the SC vectors (ghpbx).
5700           if (iii.lt.ii) then
5701           do j=1,3
5702             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5703             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5704           enddo
5705           endif
5706 cgrad        do j=iii,jjj-1
5707 cgrad          do k=1,3
5708 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5709 cgrad          enddo
5710 cgrad        enddo
5711           do k=1,3
5712             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5713             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5714           enddo
5715         endif
5716       enddo
5717       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5718       return
5719       end
5720 C--------------------------------------------------------------------------
5721       subroutine ssbond_ene(i,j,eij)
5722 C
5723 C Calculate the distance and angle dependent SS-bond potential energy
5724 C using a free-energy function derived based on RHF/6-31G** ab initio
5725 C calculations of diethyl disulfide.
5726 C
5727 C A. Liwo and U. Kozlowska, 11/24/03
5728 C
5729       implicit real*8 (a-h,o-z)
5730       include 'DIMENSIONS'
5731       include 'COMMON.SBRIDGE'
5732       include 'COMMON.CHAIN'
5733       include 'COMMON.DERIV'
5734       include 'COMMON.LOCAL'
5735       include 'COMMON.INTERACT'
5736       include 'COMMON.VAR'
5737       include 'COMMON.IOUNITS'
5738       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5739       itypi=iabs(itype(i))
5740       xi=c(1,nres+i)
5741       yi=c(2,nres+i)
5742       zi=c(3,nres+i)
5743       dxi=dc_norm(1,nres+i)
5744       dyi=dc_norm(2,nres+i)
5745       dzi=dc_norm(3,nres+i)
5746 c      dsci_inv=dsc_inv(itypi)
5747       dsci_inv=vbld_inv(nres+i)
5748       itypj=iabs(itype(j))
5749 c      dscj_inv=dsc_inv(itypj)
5750       dscj_inv=vbld_inv(nres+j)
5751       xj=c(1,nres+j)-xi
5752       yj=c(2,nres+j)-yi
5753       zj=c(3,nres+j)-zi
5754       dxj=dc_norm(1,nres+j)
5755       dyj=dc_norm(2,nres+j)
5756       dzj=dc_norm(3,nres+j)
5757       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5758       rij=dsqrt(rrij)
5759       erij(1)=xj*rij
5760       erij(2)=yj*rij
5761       erij(3)=zj*rij
5762       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5763       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5764       om12=dxi*dxj+dyi*dyj+dzi*dzj
5765       do k=1,3
5766         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5767         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5768       enddo
5769       rij=1.0d0/rij
5770       deltad=rij-d0cm
5771       deltat1=1.0d0-om1
5772       deltat2=1.0d0+om2
5773       deltat12=om2-om1+2.0d0
5774       cosphi=om12-om1*om2
5775       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5776      &  +akct*deltad*deltat12
5777      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5778 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5779 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5780 c     &  " deltat12",deltat12," eij",eij
5781       ed=2*akcm*deltad+akct*deltat12
5782       pom1=akct*deltad
5783       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5784       eom1=-2*akth*deltat1-pom1-om2*pom2
5785       eom2= 2*akth*deltat2+pom1-om1*pom2
5786       eom12=pom2
5787       do k=1,3
5788         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5789         ghpbx(k,i)=ghpbx(k,i)-ggk
5790      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5791      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5792         ghpbx(k,j)=ghpbx(k,j)+ggk
5793      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5794      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5795         ghpbc(k,i)=ghpbc(k,i)-ggk
5796         ghpbc(k,j)=ghpbc(k,j)+ggk
5797       enddo
5798 C
5799 C Calculate the components of the gradient in DC and X
5800 C
5801 cgrad      do k=i,j-1
5802 cgrad        do l=1,3
5803 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5804 cgrad        enddo
5805 cgrad      enddo
5806       return
5807       end
5808 C--------------------------------------------------------------------------
5809       subroutine ebond(estr)
5810 c
5811 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5812 c
5813       implicit real*8 (a-h,o-z)
5814       include 'DIMENSIONS'
5815       include 'COMMON.LOCAL'
5816       include 'COMMON.GEO'
5817       include 'COMMON.INTERACT'
5818       include 'COMMON.DERIV'
5819       include 'COMMON.VAR'
5820       include 'COMMON.CHAIN'
5821       include 'COMMON.IOUNITS'
5822       include 'COMMON.NAMES'
5823       include 'COMMON.FFIELD'
5824       include 'COMMON.CONTROL'
5825       include 'COMMON.SETUP'
5826       double precision u(3),ud(3)
5827       estr=0.0d0
5828       estr1=0.0d0
5829       do i=ibondp_start,ibondp_end
5830         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5831 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5832 c          do j=1,3
5833 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5834 c     &      *dc(j,i-1)/vbld(i)
5835 c          enddo
5836 c          if (energy_dec) write(iout,*)
5837 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5838 c        else
5839 C       Checking if it involves dummy (NH3+ or COO-) group
5840          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5841 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5842         diff = vbld(i)-vbldpDUM
5843          else
5844 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5845         diff = vbld(i)-vbldp0
5846          endif
5847         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5848      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5849         estr=estr+diff*diff
5850         do j=1,3
5851           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5852         enddo
5853 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5854 c        endif
5855       enddo
5856       estr=0.5d0*AKP*estr+estr1
5857 c
5858 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5859 c
5860       do i=ibond_start,ibond_end
5861         iti=iabs(itype(i))
5862         if (iti.ne.10 .and. iti.ne.ntyp1) then
5863           nbi=nbondterm(iti)
5864           if (nbi.eq.1) then
5865             diff=vbld(i+nres)-vbldsc0(1,iti)
5866             if (energy_dec)  write (iout,*)
5867      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5868      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5869             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5870             do j=1,3
5871               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5872             enddo
5873           else
5874             do j=1,nbi
5875               diff=vbld(i+nres)-vbldsc0(j,iti)
5876               ud(j)=aksc(j,iti)*diff
5877               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5878             enddo
5879             uprod=u(1)
5880             do j=2,nbi
5881               uprod=uprod*u(j)
5882             enddo
5883             usum=0.0d0
5884             usumsqder=0.0d0
5885             do j=1,nbi
5886               uprod1=1.0d0
5887               uprod2=1.0d0
5888               do k=1,nbi
5889                 if (k.ne.j) then
5890                   uprod1=uprod1*u(k)
5891                   uprod2=uprod2*u(k)*u(k)
5892                 endif
5893               enddo
5894               usum=usum+uprod1
5895               usumsqder=usumsqder+ud(j)*uprod2
5896             enddo
5897             estr=estr+uprod/usum
5898             do j=1,3
5899              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5900             enddo
5901           endif
5902         endif
5903       enddo
5904       return
5905       end
5906 #ifdef CRYST_THETA
5907 C--------------------------------------------------------------------------
5908       subroutine ebend(etheta,ethetacnstr)
5909 C
5910 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5911 C angles gamma and its derivatives in consecutive thetas and gammas.
5912 C
5913       implicit real*8 (a-h,o-z)
5914       include 'DIMENSIONS'
5915       include 'COMMON.LOCAL'
5916       include 'COMMON.GEO'
5917       include 'COMMON.INTERACT'
5918       include 'COMMON.DERIV'
5919       include 'COMMON.VAR'
5920       include 'COMMON.CHAIN'
5921       include 'COMMON.IOUNITS'
5922       include 'COMMON.NAMES'
5923       include 'COMMON.FFIELD'
5924       include 'COMMON.CONTROL'
5925       include 'COMMON.TORCNSTR'
5926       common /calcthet/ term1,term2,termm,diffak,ratak,
5927      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5928      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5929       double precision y(2),z(2)
5930       delta=0.02d0*pi
5931 c      time11=dexp(-2*time)
5932 c      time12=1.0d0
5933       etheta=0.0D0
5934 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5935       do i=ithet_start,ithet_end
5936         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5937      &  .or.itype(i).eq.ntyp1) cycle
5938 C Zero the energy function and its derivative at 0 or pi.
5939         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5940         it=itype(i-1)
5941         ichir1=isign(1,itype(i-2))
5942         ichir2=isign(1,itype(i))
5943          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5944          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5945          if (itype(i-1).eq.10) then
5946           itype1=isign(10,itype(i-2))
5947           ichir11=isign(1,itype(i-2))
5948           ichir12=isign(1,itype(i-2))
5949           itype2=isign(10,itype(i))
5950           ichir21=isign(1,itype(i))
5951           ichir22=isign(1,itype(i))
5952          endif
5953
5954         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5955 #ifdef OSF
5956           phii=phi(i)
5957           if (phii.ne.phii) phii=150.0
5958 #else
5959           phii=phi(i)
5960 #endif
5961           y(1)=dcos(phii)
5962           y(2)=dsin(phii)
5963         else
5964           y(1)=0.0D0
5965           y(2)=0.0D0
5966         endif
5967         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5968 #ifdef OSF
5969           phii1=phi(i+1)
5970           if (phii1.ne.phii1) phii1=150.0
5971           phii1=pinorm(phii1)
5972           z(1)=cos(phii1)
5973 #else
5974           phii1=phi(i+1)
5975 #endif
5976           z(1)=dcos(phii1)
5977           z(2)=dsin(phii1)
5978         else
5979           z(1)=0.0D0
5980           z(2)=0.0D0
5981         endif
5982 C Calculate the "mean" value of theta from the part of the distribution
5983 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5984 C In following comments this theta will be referred to as t_c.
5985         thet_pred_mean=0.0d0
5986         do k=1,2
5987             athetk=athet(k,it,ichir1,ichir2)
5988             bthetk=bthet(k,it,ichir1,ichir2)
5989           if (it.eq.10) then
5990              athetk=athet(k,itype1,ichir11,ichir12)
5991              bthetk=bthet(k,itype2,ichir21,ichir22)
5992           endif
5993          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5994 c         write(iout,*) 'chuj tu', y(k),z(k)
5995         enddo
5996         dthett=thet_pred_mean*ssd
5997         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5998 C Derivatives of the "mean" values in gamma1 and gamma2.
5999         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6000      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6001          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6002      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6003          if (it.eq.10) then
6004       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6005      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6006         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6007      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6008          endif
6009         if (theta(i).gt.pi-delta) then
6010           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6011      &         E_tc0)
6012           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6013           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6014           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6015      &        E_theta)
6016           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6017      &        E_tc)
6018         else if (theta(i).lt.delta) then
6019           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6020           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6021           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6022      &        E_theta)
6023           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6024           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6025      &        E_tc)
6026         else
6027           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6028      &        E_theta,E_tc)
6029         endif
6030         etheta=etheta+ethetai
6031         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6032      &      'ebend',i,ethetai,theta(i),itype(i)
6033         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6034         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6035         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6036       enddo
6037       ethetacnstr=0.0d0
6038 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6039       do i=ithetaconstr_start,ithetaconstr_end
6040         itheta=itheta_constr(i)
6041         thetiii=theta(itheta)
6042         difi=pinorm(thetiii-theta_constr0(i))
6043         if (difi.gt.theta_drange(i)) then
6044           difi=difi-theta_drange(i)
6045           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6046           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6047      &    +for_thet_constr(i)*difi**3
6048         else if (difi.lt.-drange(i)) then
6049           difi=difi+drange(i)
6050           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6051           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6052      &    +for_thet_constr(i)*difi**3
6053         else
6054           difi=0.0
6055         endif
6056        if (energy_dec) then
6057         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6058      &    i,itheta,rad2deg*thetiii,
6059      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6060      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6061      &    gloc(itheta+nphi-2,icg)
6062         endif
6063       enddo
6064
6065 C Ufff.... We've done all this!!!
6066       return
6067       end
6068 C---------------------------------------------------------------------------
6069       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6070      &     E_tc)
6071       implicit real*8 (a-h,o-z)
6072       include 'DIMENSIONS'
6073       include 'COMMON.LOCAL'
6074       include 'COMMON.IOUNITS'
6075       common /calcthet/ term1,term2,termm,diffak,ratak,
6076      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6077      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6078 C Calculate the contributions to both Gaussian lobes.
6079 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6080 C The "polynomial part" of the "standard deviation" of this part of
6081 C the distributioni.
6082 ccc        write (iout,*) thetai,thet_pred_mean
6083         sig=polthet(3,it)
6084         do j=2,0,-1
6085           sig=sig*thet_pred_mean+polthet(j,it)
6086         enddo
6087 C Derivative of the "interior part" of the "standard deviation of the"
6088 C gamma-dependent Gaussian lobe in t_c.
6089         sigtc=3*polthet(3,it)
6090         do j=2,1,-1
6091           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6092         enddo
6093         sigtc=sig*sigtc
6094 C Set the parameters of both Gaussian lobes of the distribution.
6095 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6096         fac=sig*sig+sigc0(it)
6097         sigcsq=fac+fac
6098         sigc=1.0D0/sigcsq
6099 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6100         sigsqtc=-4.0D0*sigcsq*sigtc
6101 c       print *,i,sig,sigtc,sigsqtc
6102 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6103         sigtc=-sigtc/(fac*fac)
6104 C Following variable is sigma(t_c)**(-2)
6105         sigcsq=sigcsq*sigcsq
6106         sig0i=sig0(it)
6107         sig0inv=1.0D0/sig0i**2
6108         delthec=thetai-thet_pred_mean
6109         delthe0=thetai-theta0i
6110         term1=-0.5D0*sigcsq*delthec*delthec
6111         term2=-0.5D0*sig0inv*delthe0*delthe0
6112 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6113 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6114 C NaNs in taking the logarithm. We extract the largest exponent which is added
6115 C to the energy (this being the log of the distribution) at the end of energy
6116 C term evaluation for this virtual-bond angle.
6117         if (term1.gt.term2) then
6118           termm=term1
6119           term2=dexp(term2-termm)
6120           term1=1.0d0
6121         else
6122           termm=term2
6123           term1=dexp(term1-termm)
6124           term2=1.0d0
6125         endif
6126 C The ratio between the gamma-independent and gamma-dependent lobes of
6127 C the distribution is a Gaussian function of thet_pred_mean too.
6128         diffak=gthet(2,it)-thet_pred_mean
6129         ratak=diffak/gthet(3,it)**2
6130         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6131 C Let's differentiate it in thet_pred_mean NOW.
6132         aktc=ak*ratak
6133 C Now put together the distribution terms to make complete distribution.
6134         termexp=term1+ak*term2
6135         termpre=sigc+ak*sig0i
6136 C Contribution of the bending energy from this theta is just the -log of
6137 C the sum of the contributions from the two lobes and the pre-exponential
6138 C factor. Simple enough, isn't it?
6139         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6140 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6141 C NOW the derivatives!!!
6142 C 6/6/97 Take into account the deformation.
6143         E_theta=(delthec*sigcsq*term1
6144      &       +ak*delthe0*sig0inv*term2)/termexp
6145         E_tc=((sigtc+aktc*sig0i)/termpre
6146      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6147      &       aktc*term2)/termexp)
6148       return
6149       end
6150 c-----------------------------------------------------------------------------
6151       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6152       implicit real*8 (a-h,o-z)
6153       include 'DIMENSIONS'
6154       include 'COMMON.LOCAL'
6155       include 'COMMON.IOUNITS'
6156       common /calcthet/ term1,term2,termm,diffak,ratak,
6157      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6158      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6159       delthec=thetai-thet_pred_mean
6160       delthe0=thetai-theta0i
6161 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6162       t3 = thetai-thet_pred_mean
6163       t6 = t3**2
6164       t9 = term1
6165       t12 = t3*sigcsq
6166       t14 = t12+t6*sigsqtc
6167       t16 = 1.0d0
6168       t21 = thetai-theta0i
6169       t23 = t21**2
6170       t26 = term2
6171       t27 = t21*t26
6172       t32 = termexp
6173       t40 = t32**2
6174       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6175      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6176      & *(-t12*t9-ak*sig0inv*t27)
6177       return
6178       end
6179 #else
6180 C--------------------------------------------------------------------------
6181       subroutine ebend(etheta,ethetacnstr)
6182 C
6183 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6184 C angles gamma and its derivatives in consecutive thetas and gammas.
6185 C ab initio-derived potentials from
6186 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6187 C
6188       implicit real*8 (a-h,o-z)
6189       include 'DIMENSIONS'
6190       include 'COMMON.LOCAL'
6191       include 'COMMON.GEO'
6192       include 'COMMON.INTERACT'
6193       include 'COMMON.DERIV'
6194       include 'COMMON.VAR'
6195       include 'COMMON.CHAIN'
6196       include 'COMMON.IOUNITS'
6197       include 'COMMON.NAMES'
6198       include 'COMMON.FFIELD'
6199       include 'COMMON.CONTROL'
6200       include 'COMMON.TORCNSTR'
6201       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6202      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6203      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6204      & sinph1ph2(maxdouble,maxdouble)
6205       logical lprn /.false./, lprn1 /.false./
6206       etheta=0.0D0
6207       do i=ithet_start,ithet_end
6208 c        print *,i,itype(i-1),itype(i),itype(i-2)
6209         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6210      &  .or.itype(i).eq.ntyp1) cycle
6211 C        print *,i,theta(i)
6212         if (iabs(itype(i+1)).eq.20) iblock=2
6213         if (iabs(itype(i+1)).ne.20) iblock=1
6214         dethetai=0.0d0
6215         dephii=0.0d0
6216         dephii1=0.0d0
6217         theti2=0.5d0*theta(i)
6218         ityp2=ithetyp((itype(i-1)))
6219         do k=1,nntheterm
6220           coskt(k)=dcos(k*theti2)
6221           sinkt(k)=dsin(k*theti2)
6222         enddo
6223 C        print *,ethetai
6224         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6225 #ifdef OSF
6226           phii=phi(i)
6227           if (phii.ne.phii) phii=150.0
6228 #else
6229           phii=phi(i)
6230 #endif
6231           ityp1=ithetyp((itype(i-2)))
6232 C propagation of chirality for glycine type
6233           do k=1,nsingle
6234             cosph1(k)=dcos(k*phii)
6235             sinph1(k)=dsin(k*phii)
6236           enddo
6237         else
6238           phii=0.0d0
6239           do k=1,nsingle
6240           ityp1=ithetyp((itype(i-2)))
6241             cosph1(k)=0.0d0
6242             sinph1(k)=0.0d0
6243           enddo
6244         endif
6245         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6246 #ifdef OSF
6247           phii1=phi(i+1)
6248           if (phii1.ne.phii1) phii1=150.0
6249           phii1=pinorm(phii1)
6250 #else
6251           phii1=phi(i+1)
6252 #endif
6253           ityp3=ithetyp((itype(i)))
6254           do k=1,nsingle
6255             cosph2(k)=dcos(k*phii1)
6256             sinph2(k)=dsin(k*phii1)
6257           enddo
6258         else
6259           phii1=0.0d0
6260           ityp3=ithetyp((itype(i)))
6261           do k=1,nsingle
6262             cosph2(k)=0.0d0
6263             sinph2(k)=0.0d0
6264           enddo
6265         endif
6266         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6267         do k=1,ndouble
6268           do l=1,k-1
6269             ccl=cosph1(l)*cosph2(k-l)
6270             ssl=sinph1(l)*sinph2(k-l)
6271             scl=sinph1(l)*cosph2(k-l)
6272             csl=cosph1(l)*sinph2(k-l)
6273             cosph1ph2(l,k)=ccl-ssl
6274             cosph1ph2(k,l)=ccl+ssl
6275             sinph1ph2(l,k)=scl+csl
6276             sinph1ph2(k,l)=scl-csl
6277           enddo
6278         enddo
6279         if (lprn) then
6280         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6281      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6282         write (iout,*) "coskt and sinkt"
6283         do k=1,nntheterm
6284           write (iout,*) k,coskt(k),sinkt(k)
6285         enddo
6286         endif
6287         do k=1,ntheterm
6288           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6289           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6290      &      *coskt(k)
6291           if (lprn)
6292      &    write (iout,*) "k",k,"
6293      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6294      &     " ethetai",ethetai
6295         enddo
6296         if (lprn) then
6297         write (iout,*) "cosph and sinph"
6298         do k=1,nsingle
6299           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6300         enddo
6301         write (iout,*) "cosph1ph2 and sinph2ph2"
6302         do k=2,ndouble
6303           do l=1,k-1
6304             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6305      &         sinph1ph2(l,k),sinph1ph2(k,l)
6306           enddo
6307         enddo
6308         write(iout,*) "ethetai",ethetai
6309         endif
6310 C       print *,ethetai
6311         do m=1,ntheterm2
6312           do k=1,nsingle
6313             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6314      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6315      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6316      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6317             ethetai=ethetai+sinkt(m)*aux
6318             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6319             dephii=dephii+k*sinkt(m)*(
6320      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6321      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6322             dephii1=dephii1+k*sinkt(m)*(
6323      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6324      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6325             if (lprn)
6326      &      write (iout,*) "m",m," k",k," bbthet",
6327      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6328      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6329      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6330      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6331 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6332           enddo
6333         enddo
6334 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6335 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6336 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6337 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6338         if (lprn)
6339      &  write(iout,*) "ethetai",ethetai
6340 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6341         do m=1,ntheterm3
6342           do k=2,ndouble
6343             do l=1,k-1
6344               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6345      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6346      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6347      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6348               ethetai=ethetai+sinkt(m)*aux
6349               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6350               dephii=dephii+l*sinkt(m)*(
6351      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6352      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6353      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6354      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6355               dephii1=dephii1+(k-l)*sinkt(m)*(
6356      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6357      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6358      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6359      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6360               if (lprn) then
6361               write (iout,*) "m",m," k",k," l",l," ffthet",
6362      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6363      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6364      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6365      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6366      &            " ethetai",ethetai
6367               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6368      &            cosph1ph2(k,l)*sinkt(m),
6369      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6370               endif
6371             enddo
6372           enddo
6373         enddo
6374 10      continue
6375 c        lprn1=.true.
6376 C        print *,ethetai
6377         if (lprn1)
6378      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6379      &   i,theta(i)*rad2deg,phii*rad2deg,
6380      &   phii1*rad2deg,ethetai
6381 c        lprn1=.false.
6382         etheta=etheta+ethetai
6383         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6384         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6385         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6386       enddo
6387 C now constrains
6388       ethetacnstr=0.0d0
6389 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6390       do i=ithetaconstr_start,ithetaconstr_end
6391         itheta=itheta_constr(i)
6392         thetiii=theta(itheta)
6393         difi=pinorm(thetiii-theta_constr0(i))
6394         if (difi.gt.theta_drange(i)) then
6395           difi=difi-theta_drange(i)
6396           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6397           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6398      &    +for_thet_constr(i)*difi**3
6399         else if (difi.lt.-drange(i)) then
6400           difi=difi+drange(i)
6401           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6402           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6403      &    +for_thet_constr(i)*difi**3
6404         else
6405           difi=0.0
6406         endif
6407        if (energy_dec) then
6408         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6409      &    i,itheta,rad2deg*thetiii,
6410      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6411      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6412      &    gloc(itheta+nphi-2,icg)
6413         endif
6414       enddo
6415
6416       return
6417       end
6418 #endif
6419 #ifdef CRYST_SC
6420 c-----------------------------------------------------------------------------
6421       subroutine esc(escloc)
6422 C Calculate the local energy of a side chain and its derivatives in the
6423 C corresponding virtual-bond valence angles THETA and the spherical angles
6424 C ALPHA and OMEGA.
6425       implicit real*8 (a-h,o-z)
6426       include 'DIMENSIONS'
6427       include 'COMMON.GEO'
6428       include 'COMMON.LOCAL'
6429       include 'COMMON.VAR'
6430       include 'COMMON.INTERACT'
6431       include 'COMMON.DERIV'
6432       include 'COMMON.CHAIN'
6433       include 'COMMON.IOUNITS'
6434       include 'COMMON.NAMES'
6435       include 'COMMON.FFIELD'
6436       include 'COMMON.CONTROL'
6437       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6438      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6439       common /sccalc/ time11,time12,time112,theti,it,nlobit
6440       delta=0.02d0*pi
6441       escloc=0.0D0
6442 c     write (iout,'(a)') 'ESC'
6443       do i=loc_start,loc_end
6444         it=itype(i)
6445         if (it.eq.ntyp1) cycle
6446         if (it.eq.10) goto 1
6447         nlobit=nlob(iabs(it))
6448 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6449 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6450         theti=theta(i+1)-pipol
6451         x(1)=dtan(theti)
6452         x(2)=alph(i)
6453         x(3)=omeg(i)
6454
6455         if (x(2).gt.pi-delta) then
6456           xtemp(1)=x(1)
6457           xtemp(2)=pi-delta
6458           xtemp(3)=x(3)
6459           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6460           xtemp(2)=pi
6461           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6462           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6463      &        escloci,dersc(2))
6464           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6465      &        ddersc0(1),dersc(1))
6466           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6467      &        ddersc0(3),dersc(3))
6468           xtemp(2)=pi-delta
6469           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6470           xtemp(2)=pi
6471           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6472           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6473      &            dersc0(2),esclocbi,dersc02)
6474           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6475      &            dersc12,dersc01)
6476           call splinthet(x(2),0.5d0*delta,ss,ssd)
6477           dersc0(1)=dersc01
6478           dersc0(2)=dersc02
6479           dersc0(3)=0.0d0
6480           do k=1,3
6481             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6482           enddo
6483           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6484 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6485 c    &             esclocbi,ss,ssd
6486           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6487 c         escloci=esclocbi
6488 c         write (iout,*) escloci
6489         else if (x(2).lt.delta) then
6490           xtemp(1)=x(1)
6491           xtemp(2)=delta
6492           xtemp(3)=x(3)
6493           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6494           xtemp(2)=0.0d0
6495           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6496           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6497      &        escloci,dersc(2))
6498           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6499      &        ddersc0(1),dersc(1))
6500           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6501      &        ddersc0(3),dersc(3))
6502           xtemp(2)=delta
6503           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6504           xtemp(2)=0.0d0
6505           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6506           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6507      &            dersc0(2),esclocbi,dersc02)
6508           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6509      &            dersc12,dersc01)
6510           dersc0(1)=dersc01
6511           dersc0(2)=dersc02
6512           dersc0(3)=0.0d0
6513           call splinthet(x(2),0.5d0*delta,ss,ssd)
6514           do k=1,3
6515             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6516           enddo
6517           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6518 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6519 c    &             esclocbi,ss,ssd
6520           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6521 c         write (iout,*) escloci
6522         else
6523           call enesc(x,escloci,dersc,ddummy,.false.)
6524         endif
6525
6526         escloc=escloc+escloci
6527         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6528      &     'escloc',i,escloci
6529 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6530
6531         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6532      &   wscloc*dersc(1)
6533         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6534         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6535     1   continue
6536       enddo
6537       return
6538       end
6539 C---------------------------------------------------------------------------
6540       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6541       implicit real*8 (a-h,o-z)
6542       include 'DIMENSIONS'
6543       include 'COMMON.GEO'
6544       include 'COMMON.LOCAL'
6545       include 'COMMON.IOUNITS'
6546       common /sccalc/ time11,time12,time112,theti,it,nlobit
6547       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6548       double precision contr(maxlob,-1:1)
6549       logical mixed
6550 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6551         escloc_i=0.0D0
6552         do j=1,3
6553           dersc(j)=0.0D0
6554           if (mixed) ddersc(j)=0.0d0
6555         enddo
6556         x3=x(3)
6557
6558 C Because of periodicity of the dependence of the SC energy in omega we have
6559 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6560 C To avoid underflows, first compute & store the exponents.
6561
6562         do iii=-1,1
6563
6564           x(3)=x3+iii*dwapi
6565
6566           do j=1,nlobit
6567             do k=1,3
6568               z(k)=x(k)-censc(k,j,it)
6569             enddo
6570             do k=1,3
6571               Axk=0.0D0
6572               do l=1,3
6573                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6574               enddo
6575               Ax(k,j,iii)=Axk
6576             enddo
6577             expfac=0.0D0
6578             do k=1,3
6579               expfac=expfac+Ax(k,j,iii)*z(k)
6580             enddo
6581             contr(j,iii)=expfac
6582           enddo ! j
6583
6584         enddo ! iii
6585
6586         x(3)=x3
6587 C As in the case of ebend, we want to avoid underflows in exponentiation and
6588 C subsequent NaNs and INFs in energy calculation.
6589 C Find the largest exponent
6590         emin=contr(1,-1)
6591         do iii=-1,1
6592           do j=1,nlobit
6593             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6594           enddo
6595         enddo
6596         emin=0.5D0*emin
6597 cd      print *,'it=',it,' emin=',emin
6598
6599 C Compute the contribution to SC energy and derivatives
6600         do iii=-1,1
6601
6602           do j=1,nlobit
6603 #ifdef OSF
6604             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6605             if(adexp.ne.adexp) adexp=1.0
6606             expfac=dexp(adexp)
6607 #else
6608             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6609 #endif
6610 cd          print *,'j=',j,' expfac=',expfac
6611             escloc_i=escloc_i+expfac
6612             do k=1,3
6613               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6614             enddo
6615             if (mixed) then
6616               do k=1,3,2
6617                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6618      &            +gaussc(k,2,j,it))*expfac
6619               enddo
6620             endif
6621           enddo
6622
6623         enddo ! iii
6624
6625         dersc(1)=dersc(1)/cos(theti)**2
6626         ddersc(1)=ddersc(1)/cos(theti)**2
6627         ddersc(3)=ddersc(3)
6628
6629         escloci=-(dlog(escloc_i)-emin)
6630         do j=1,3
6631           dersc(j)=dersc(j)/escloc_i
6632         enddo
6633         if (mixed) then
6634           do j=1,3,2
6635             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6636           enddo
6637         endif
6638       return
6639       end
6640 C------------------------------------------------------------------------------
6641       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6642       implicit real*8 (a-h,o-z)
6643       include 'DIMENSIONS'
6644       include 'COMMON.GEO'
6645       include 'COMMON.LOCAL'
6646       include 'COMMON.IOUNITS'
6647       common /sccalc/ time11,time12,time112,theti,it,nlobit
6648       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6649       double precision contr(maxlob)
6650       logical mixed
6651
6652       escloc_i=0.0D0
6653
6654       do j=1,3
6655         dersc(j)=0.0D0
6656       enddo
6657
6658       do j=1,nlobit
6659         do k=1,2
6660           z(k)=x(k)-censc(k,j,it)
6661         enddo
6662         z(3)=dwapi
6663         do k=1,3
6664           Axk=0.0D0
6665           do l=1,3
6666             Axk=Axk+gaussc(l,k,j,it)*z(l)
6667           enddo
6668           Ax(k,j)=Axk
6669         enddo
6670         expfac=0.0D0
6671         do k=1,3
6672           expfac=expfac+Ax(k,j)*z(k)
6673         enddo
6674         contr(j)=expfac
6675       enddo ! j
6676
6677 C As in the case of ebend, we want to avoid underflows in exponentiation and
6678 C subsequent NaNs and INFs in energy calculation.
6679 C Find the largest exponent
6680       emin=contr(1)
6681       do j=1,nlobit
6682         if (emin.gt.contr(j)) emin=contr(j)
6683       enddo
6684       emin=0.5D0*emin
6685
6686 C Compute the contribution to SC energy and derivatives
6687
6688       dersc12=0.0d0
6689       do j=1,nlobit
6690         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6691         escloc_i=escloc_i+expfac
6692         do k=1,2
6693           dersc(k)=dersc(k)+Ax(k,j)*expfac
6694         enddo
6695         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6696      &            +gaussc(1,2,j,it))*expfac
6697         dersc(3)=0.0d0
6698       enddo
6699
6700       dersc(1)=dersc(1)/cos(theti)**2
6701       dersc12=dersc12/cos(theti)**2
6702       escloci=-(dlog(escloc_i)-emin)
6703       do j=1,2
6704         dersc(j)=dersc(j)/escloc_i
6705       enddo
6706       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6707       return
6708       end
6709 #else
6710 c----------------------------------------------------------------------------------
6711       subroutine esc(escloc)
6712 C Calculate the local energy of a side chain and its derivatives in the
6713 C corresponding virtual-bond valence angles THETA and the spherical angles
6714 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6715 C added by Urszula Kozlowska. 07/11/2007
6716 C
6717       implicit real*8 (a-h,o-z)
6718       include 'DIMENSIONS'
6719       include 'COMMON.GEO'
6720       include 'COMMON.LOCAL'
6721       include 'COMMON.VAR'
6722       include 'COMMON.SCROT'
6723       include 'COMMON.INTERACT'
6724       include 'COMMON.DERIV'
6725       include 'COMMON.CHAIN'
6726       include 'COMMON.IOUNITS'
6727       include 'COMMON.NAMES'
6728       include 'COMMON.FFIELD'
6729       include 'COMMON.CONTROL'
6730       include 'COMMON.VECTORS'
6731       double precision x_prime(3),y_prime(3),z_prime(3)
6732      &    , sumene,dsc_i,dp2_i,x(65),
6733      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6734      &    de_dxx,de_dyy,de_dzz,de_dt
6735       double precision s1_t,s1_6_t,s2_t,s2_6_t
6736       double precision
6737      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6738      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6739      & dt_dCi(3),dt_dCi1(3)
6740       common /sccalc/ time11,time12,time112,theti,it,nlobit
6741       delta=0.02d0*pi
6742       escloc=0.0D0
6743       do i=loc_start,loc_end
6744         if (itype(i).eq.ntyp1) cycle
6745         costtab(i+1) =dcos(theta(i+1))
6746         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6747         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6748         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6749         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6750         cosfac=dsqrt(cosfac2)
6751         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6752         sinfac=dsqrt(sinfac2)
6753         it=iabs(itype(i))
6754         if (it.eq.10) goto 1
6755 c
6756 C  Compute the axes of tghe local cartesian coordinates system; store in
6757 c   x_prime, y_prime and z_prime
6758 c
6759         do j=1,3
6760           x_prime(j) = 0.00
6761           y_prime(j) = 0.00
6762           z_prime(j) = 0.00
6763         enddo
6764 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6765 C     &   dc_norm(3,i+nres)
6766         do j = 1,3
6767           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6768           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6769         enddo
6770         do j = 1,3
6771           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6772         enddo
6773 c       write (2,*) "i",i
6774 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6775 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6776 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6777 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6778 c      & " xy",scalar(x_prime(1),y_prime(1)),
6779 c      & " xz",scalar(x_prime(1),z_prime(1)),
6780 c      & " yy",scalar(y_prime(1),y_prime(1)),
6781 c      & " yz",scalar(y_prime(1),z_prime(1)),
6782 c      & " zz",scalar(z_prime(1),z_prime(1))
6783 c
6784 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6785 C to local coordinate system. Store in xx, yy, zz.
6786 c
6787         xx=0.0d0
6788         yy=0.0d0
6789         zz=0.0d0
6790         do j = 1,3
6791           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6792           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6793           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6794         enddo
6795
6796         xxtab(i)=xx
6797         yytab(i)=yy
6798         zztab(i)=zz
6799 C
6800 C Compute the energy of the ith side cbain
6801 C
6802 c        write (2,*) "xx",xx," yy",yy," zz",zz
6803         it=iabs(itype(i))
6804         do j = 1,65
6805           x(j) = sc_parmin(j,it)
6806         enddo
6807 #ifdef CHECK_COORD
6808 Cc diagnostics - remove later
6809         xx1 = dcos(alph(2))
6810         yy1 = dsin(alph(2))*dcos(omeg(2))
6811         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6812         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6813      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6814      &    xx1,yy1,zz1
6815 C,"  --- ", xx_w,yy_w,zz_w
6816 c end diagnostics
6817 #endif
6818         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6819      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6820      &   + x(10)*yy*zz
6821         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6822      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6823      & + x(20)*yy*zz
6824         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6825      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6826      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6827      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6828      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6829      &  +x(40)*xx*yy*zz
6830         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6831      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6832      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6833      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6834      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6835      &  +x(60)*xx*yy*zz
6836         dsc_i   = 0.743d0+x(61)
6837         dp2_i   = 1.9d0+x(62)
6838         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6839      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6840         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6841      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6842         s1=(1+x(63))/(0.1d0 + dscp1)
6843         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6844         s2=(1+x(65))/(0.1d0 + dscp2)
6845         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6846         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6847      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6848 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6849 c     &   sumene4,
6850 c     &   dscp1,dscp2,sumene
6851 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6852         escloc = escloc + sumene
6853 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6854 c     & ,zz,xx,yy
6855 c#define DEBUG
6856 #ifdef DEBUG
6857 C
6858 C This section to check the numerical derivatives of the energy of ith side
6859 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6860 C #define DEBUG in the code to turn it on.
6861 C
6862         write (2,*) "sumene               =",sumene
6863         aincr=1.0d-7
6864         xxsave=xx
6865         xx=xx+aincr
6866         write (2,*) xx,yy,zz
6867         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6868         de_dxx_num=(sumenep-sumene)/aincr
6869         xx=xxsave
6870         write (2,*) "xx+ sumene from enesc=",sumenep
6871         yysave=yy
6872         yy=yy+aincr
6873         write (2,*) xx,yy,zz
6874         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6875         de_dyy_num=(sumenep-sumene)/aincr
6876         yy=yysave
6877         write (2,*) "yy+ sumene from enesc=",sumenep
6878         zzsave=zz
6879         zz=zz+aincr
6880         write (2,*) xx,yy,zz
6881         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6882         de_dzz_num=(sumenep-sumene)/aincr
6883         zz=zzsave
6884         write (2,*) "zz+ sumene from enesc=",sumenep
6885         costsave=cost2tab(i+1)
6886         sintsave=sint2tab(i+1)
6887         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6888         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6889         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6890         de_dt_num=(sumenep-sumene)/aincr
6891         write (2,*) " t+ sumene from enesc=",sumenep
6892         cost2tab(i+1)=costsave
6893         sint2tab(i+1)=sintsave
6894 C End of diagnostics section.
6895 #endif
6896 C
6897 C Compute the gradient of esc
6898 C
6899 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6900         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6901         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6902         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6903         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6904         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6905         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6906         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6907         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6908         pom1=(sumene3*sint2tab(i+1)+sumene1)
6909      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6910         pom2=(sumene4*cost2tab(i+1)+sumene2)
6911      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6912         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6913         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6914      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6915      &  +x(40)*yy*zz
6916         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6917         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6918      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6919      &  +x(60)*yy*zz
6920         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6921      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6922      &        +(pom1+pom2)*pom_dx
6923 #ifdef DEBUG
6924         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6925 #endif
6926 C
6927         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6928         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6929      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6930      &  +x(40)*xx*zz
6931         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6932         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6933      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6934      &  +x(59)*zz**2 +x(60)*xx*zz
6935         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6936      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6937      &        +(pom1-pom2)*pom_dy
6938 #ifdef DEBUG
6939         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6940 #endif
6941 C
6942         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6943      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6944      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6945      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6946      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6947      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6948      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6949      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6950 #ifdef DEBUG
6951         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6952 #endif
6953 C
6954         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6955      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6956      &  +pom1*pom_dt1+pom2*pom_dt2
6957 #ifdef DEBUG
6958         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6959 #endif
6960 c#undef DEBUG
6961 c
6962 C
6963        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6964        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6965        cosfac2xx=cosfac2*xx
6966        sinfac2yy=sinfac2*yy
6967        do k = 1,3
6968          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6969      &      vbld_inv(i+1)
6970          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6971      &      vbld_inv(i)
6972          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6973          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6974 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6975 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6976 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6977 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6978          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6979          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6980          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6981          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6982          dZZ_Ci1(k)=0.0d0
6983          dZZ_Ci(k)=0.0d0
6984          do j=1,3
6985            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6986      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6987            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6988      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6989          enddo
6990
6991          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6992          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6993          dZZ_XYZ(k)=vbld_inv(i+nres)*
6994      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6995 c
6996          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6997          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6998        enddo
6999
7000        do k=1,3
7001          dXX_Ctab(k,i)=dXX_Ci(k)
7002          dXX_C1tab(k,i)=dXX_Ci1(k)
7003          dYY_Ctab(k,i)=dYY_Ci(k)
7004          dYY_C1tab(k,i)=dYY_Ci1(k)
7005          dZZ_Ctab(k,i)=dZZ_Ci(k)
7006          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7007          dXX_XYZtab(k,i)=dXX_XYZ(k)
7008          dYY_XYZtab(k,i)=dYY_XYZ(k)
7009          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7010        enddo
7011
7012        do k = 1,3
7013 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7014 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7015 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7016 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7017 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7018 c     &    dt_dci(k)
7019 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7020 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7021          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7022      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7023          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7024      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7025          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7026      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7027        enddo
7028 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7029 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7030
7031 C to check gradient call subroutine check_grad
7032
7033     1 continue
7034       enddo
7035       return
7036       end
7037 c------------------------------------------------------------------------------
7038       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7039       implicit none
7040       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7041      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7042       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7043      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7044      &   + x(10)*yy*zz
7045       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7046      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7047      & + x(20)*yy*zz
7048       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7049      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7050      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7051      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7052      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7053      &  +x(40)*xx*yy*zz
7054       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7055      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7056      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7057      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7058      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7059      &  +x(60)*xx*yy*zz
7060       dsc_i   = 0.743d0+x(61)
7061       dp2_i   = 1.9d0+x(62)
7062       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7063      &          *(xx*cost2+yy*sint2))
7064       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7065      &          *(xx*cost2-yy*sint2))
7066       s1=(1+x(63))/(0.1d0 + dscp1)
7067       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7068       s2=(1+x(65))/(0.1d0 + dscp2)
7069       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7070       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7071      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7072       enesc=sumene
7073       return
7074       end
7075 #endif
7076 c------------------------------------------------------------------------------
7077       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7078 C
7079 C This procedure calculates two-body contact function g(rij) and its derivative:
7080 C
7081 C           eps0ij                                     !       x < -1
7082 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7083 C            0                                         !       x > 1
7084 C
7085 C where x=(rij-r0ij)/delta
7086 C
7087 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7088 C
7089       implicit none
7090       double precision rij,r0ij,eps0ij,fcont,fprimcont
7091       double precision x,x2,x4,delta
7092 c     delta=0.02D0*r0ij
7093 c      delta=0.2D0*r0ij
7094       x=(rij-r0ij)/delta
7095       if (x.lt.-1.0D0) then
7096         fcont=eps0ij
7097         fprimcont=0.0D0
7098       else if (x.le.1.0D0) then
7099         x2=x*x
7100         x4=x2*x2
7101         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7102         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7103       else
7104         fcont=0.0D0
7105         fprimcont=0.0D0
7106       endif
7107       return
7108       end
7109 c------------------------------------------------------------------------------
7110       subroutine splinthet(theti,delta,ss,ssder)
7111       implicit real*8 (a-h,o-z)
7112       include 'DIMENSIONS'
7113       include 'COMMON.VAR'
7114       include 'COMMON.GEO'
7115       thetup=pi-delta
7116       thetlow=delta
7117       if (theti.gt.pipol) then
7118         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7119       else
7120         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7121         ssder=-ssder
7122       endif
7123       return
7124       end
7125 c------------------------------------------------------------------------------
7126       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7127       implicit none
7128       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7129       double precision ksi,ksi2,ksi3,a1,a2,a3
7130       a1=fprim0*delta/(f1-f0)
7131       a2=3.0d0-2.0d0*a1
7132       a3=a1-2.0d0
7133       ksi=(x-x0)/delta
7134       ksi2=ksi*ksi
7135       ksi3=ksi2*ksi
7136       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7137       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7138       return
7139       end
7140 c------------------------------------------------------------------------------
7141       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7142       implicit none
7143       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7144       double precision ksi,ksi2,ksi3,a1,a2,a3
7145       ksi=(x-x0)/delta
7146       ksi2=ksi*ksi
7147       ksi3=ksi2*ksi
7148       a1=fprim0x*delta
7149       a2=3*(f1x-f0x)-2*fprim0x*delta
7150       a3=fprim0x*delta-2*(f1x-f0x)
7151       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7152       return
7153       end
7154 C-----------------------------------------------------------------------------
7155 #ifdef CRYST_TOR
7156 C-----------------------------------------------------------------------------
7157       subroutine etor(etors,edihcnstr)
7158       implicit real*8 (a-h,o-z)
7159       include 'DIMENSIONS'
7160       include 'COMMON.VAR'
7161       include 'COMMON.GEO'
7162       include 'COMMON.LOCAL'
7163       include 'COMMON.TORSION'
7164       include 'COMMON.INTERACT'
7165       include 'COMMON.DERIV'
7166       include 'COMMON.CHAIN'
7167       include 'COMMON.NAMES'
7168       include 'COMMON.IOUNITS'
7169       include 'COMMON.FFIELD'
7170       include 'COMMON.TORCNSTR'
7171       include 'COMMON.CONTROL'
7172       logical lprn
7173 C Set lprn=.true. for debugging
7174       lprn=.false.
7175 c      lprn=.true.
7176       etors=0.0D0
7177       do i=iphi_start,iphi_end
7178       etors_ii=0.0D0
7179         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7180      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7181         itori=itortyp(itype(i-2))
7182         itori1=itortyp(itype(i-1))
7183         phii=phi(i)
7184         gloci=0.0D0
7185 C Proline-Proline pair is a special case...
7186         if (itori.eq.3 .and. itori1.eq.3) then
7187           if (phii.gt.-dwapi3) then
7188             cosphi=dcos(3*phii)
7189             fac=1.0D0/(1.0D0-cosphi)
7190             etorsi=v1(1,3,3)*fac
7191             etorsi=etorsi+etorsi
7192             etors=etors+etorsi-v1(1,3,3)
7193             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7194             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7195           endif
7196           do j=1,3
7197             v1ij=v1(j+1,itori,itori1)
7198             v2ij=v2(j+1,itori,itori1)
7199             cosphi=dcos(j*phii)
7200             sinphi=dsin(j*phii)
7201             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7202             if (energy_dec) etors_ii=etors_ii+
7203      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7204             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7205           enddo
7206         else
7207           do j=1,nterm_old
7208             v1ij=v1(j,itori,itori1)
7209             v2ij=v2(j,itori,itori1)
7210             cosphi=dcos(j*phii)
7211             sinphi=dsin(j*phii)
7212             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7213             if (energy_dec) etors_ii=etors_ii+
7214      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7215             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7216           enddo
7217         endif
7218         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7219              'etor',i,etors_ii
7220         if (lprn)
7221      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7222      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7223      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7224         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7225 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7226       enddo
7227 ! 6/20/98 - dihedral angle constraints
7228       edihcnstr=0.0d0
7229       do i=1,ndih_constr
7230         itori=idih_constr(i)
7231         phii=phi(itori)
7232         difi=phii-phi0(i)
7233         if (difi.gt.drange(i)) then
7234           difi=difi-drange(i)
7235           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7236           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7237         else if (difi.lt.-drange(i)) then
7238           difi=difi+drange(i)
7239           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7240           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7241         endif
7242 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7243 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7244       enddo
7245 !      write (iout,*) 'edihcnstr',edihcnstr
7246       return
7247       end
7248 c------------------------------------------------------------------------------
7249       subroutine etor_d(etors_d)
7250       etors_d=0.0d0
7251       return
7252       end
7253 c----------------------------------------------------------------------------
7254 #else
7255       subroutine etor(etors,edihcnstr)
7256       implicit real*8 (a-h,o-z)
7257       include 'DIMENSIONS'
7258       include 'COMMON.VAR'
7259       include 'COMMON.GEO'
7260       include 'COMMON.LOCAL'
7261       include 'COMMON.TORSION'
7262       include 'COMMON.INTERACT'
7263       include 'COMMON.DERIV'
7264       include 'COMMON.CHAIN'
7265       include 'COMMON.NAMES'
7266       include 'COMMON.IOUNITS'
7267       include 'COMMON.FFIELD'
7268       include 'COMMON.TORCNSTR'
7269       include 'COMMON.CONTROL'
7270       logical lprn
7271 C Set lprn=.true. for debugging
7272       lprn=.false.
7273 c     lprn=.true.
7274       etors=0.0D0
7275       do i=iphi_start,iphi_end
7276 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7277 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7278 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7279 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7280         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7281      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7282 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7283 C For introducing the NH3+ and COO- group please check the etor_d for reference
7284 C and guidance
7285         etors_ii=0.0D0
7286          if (iabs(itype(i)).eq.20) then
7287          iblock=2
7288          else
7289          iblock=1
7290          endif
7291         itori=itortyp(itype(i-2))
7292         itori1=itortyp(itype(i-1))
7293         phii=phi(i)
7294         gloci=0.0D0
7295 C Regular cosine and sine terms
7296         do j=1,nterm(itori,itori1,iblock)
7297           v1ij=v1(j,itori,itori1,iblock)
7298           v2ij=v2(j,itori,itori1,iblock)
7299           cosphi=dcos(j*phii)
7300           sinphi=dsin(j*phii)
7301           etors=etors+v1ij*cosphi+v2ij*sinphi
7302           if (energy_dec) etors_ii=etors_ii+
7303      &                v1ij*cosphi+v2ij*sinphi
7304           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7305         enddo
7306 C Lorentz terms
7307 C                         v1
7308 C  E = SUM ----------------------------------- - v1
7309 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7310 C
7311         cosphi=dcos(0.5d0*phii)
7312         sinphi=dsin(0.5d0*phii)
7313         do j=1,nlor(itori,itori1,iblock)
7314           vl1ij=vlor1(j,itori,itori1)
7315           vl2ij=vlor2(j,itori,itori1)
7316           vl3ij=vlor3(j,itori,itori1)
7317           pom=vl2ij*cosphi+vl3ij*sinphi
7318           pom1=1.0d0/(pom*pom+1.0d0)
7319           etors=etors+vl1ij*pom1
7320           if (energy_dec) etors_ii=etors_ii+
7321      &                vl1ij*pom1
7322           pom=-pom*pom1*pom1
7323           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7324         enddo
7325 C Subtract the constant term
7326         etors=etors-v0(itori,itori1,iblock)
7327           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7328      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7329         if (lprn)
7330      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7331      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7332      &  (v1(j,itori,itori1,iblock),j=1,6),
7333      &  (v2(j,itori,itori1,iblock),j=1,6)
7334         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7335 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7336       enddo
7337 ! 6/20/98 - dihedral angle constraints
7338       edihcnstr=0.0d0
7339 c      do i=1,ndih_constr
7340       do i=idihconstr_start,idihconstr_end
7341         itori=idih_constr(i)
7342         phii=phi(itori)
7343         difi=pinorm(phii-phi0(i))
7344         if (difi.gt.drange(i)) then
7345           difi=difi-drange(i)
7346           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7347           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7348         else if (difi.lt.-drange(i)) then
7349           difi=difi+drange(i)
7350           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7351           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7352         else
7353           difi=0.0
7354         endif
7355        if (energy_dec) then
7356         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7357      &    i,itori,rad2deg*phii,
7358      &    rad2deg*phi0(i),  rad2deg*drange(i),
7359      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7360         endif
7361       enddo
7362 cd       write (iout,*) 'edihcnstr',edihcnstr
7363       return
7364       end
7365 c----------------------------------------------------------------------------
7366       subroutine etor_d(etors_d)
7367 C 6/23/01 Compute double torsional energy
7368       implicit real*8 (a-h,o-z)
7369       include 'DIMENSIONS'
7370       include 'COMMON.VAR'
7371       include 'COMMON.GEO'
7372       include 'COMMON.LOCAL'
7373       include 'COMMON.TORSION'
7374       include 'COMMON.INTERACT'
7375       include 'COMMON.DERIV'
7376       include 'COMMON.CHAIN'
7377       include 'COMMON.NAMES'
7378       include 'COMMON.IOUNITS'
7379       include 'COMMON.FFIELD'
7380       include 'COMMON.TORCNSTR'
7381       logical lprn
7382 C Set lprn=.true. for debugging
7383       lprn=.false.
7384 c     lprn=.true.
7385       etors_d=0.0D0
7386 c      write(iout,*) "a tu??"
7387       do i=iphid_start,iphid_end
7388 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7389 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7390 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7391 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7392 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7393          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7394      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7395      &  (itype(i+1).eq.ntyp1)) cycle
7396 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7397         itori=itortyp(itype(i-2))
7398         itori1=itortyp(itype(i-1))
7399         itori2=itortyp(itype(i))
7400         phii=phi(i)
7401         phii1=phi(i+1)
7402         gloci1=0.0D0
7403         gloci2=0.0D0
7404         iblock=1
7405         if (iabs(itype(i+1)).eq.20) iblock=2
7406 C Iblock=2 Proline type
7407 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7408 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7409 C        if (itype(i+1).eq.ntyp1) iblock=3
7410 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7411 C IS or IS NOT need for this
7412 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7413 C        is (itype(i-3).eq.ntyp1) ntblock=2
7414 C        ntblock is N-terminal blocking group
7415
7416 C Regular cosine and sine terms
7417         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7418 C Example of changes for NH3+ blocking group
7419 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7420 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7421           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7422           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7423           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7424           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7425           cosphi1=dcos(j*phii)
7426           sinphi1=dsin(j*phii)
7427           cosphi2=dcos(j*phii1)
7428           sinphi2=dsin(j*phii1)
7429           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7430      &     v2cij*cosphi2+v2sij*sinphi2
7431           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7432           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7433         enddo
7434         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7435           do l=1,k-1
7436             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7437             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7438             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7439             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7440             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7441             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7442             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7443             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7444             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7445      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7446             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7447      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7448             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7449      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7450           enddo
7451         enddo
7452         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7453         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7454       enddo
7455       return
7456       end
7457 #endif
7458 C----------------------------------------------------------------------------------
7459 C The rigorous attempt to derive energy function
7460       subroutine etor_kcc(etors,edihcnstr)
7461       implicit real*8 (a-h,o-z)
7462       include 'DIMENSIONS'
7463       include 'COMMON.VAR'
7464       include 'COMMON.GEO'
7465       include 'COMMON.LOCAL'
7466       include 'COMMON.TORSION'
7467       include 'COMMON.INTERACT'
7468       include 'COMMON.DERIV'
7469       include 'COMMON.CHAIN'
7470       include 'COMMON.NAMES'
7471       include 'COMMON.IOUNITS'
7472       include 'COMMON.FFIELD'
7473       include 'COMMON.TORCNSTR'
7474       include 'COMMON.CONTROL'
7475       logical lprn
7476       double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7477 C Set lprn=.true. for debugging
7478       lprn=.false.
7479 c     lprn=.true.
7480 C      print *,"wchodze kcc"
7481       if (tor_mode.ne.2) then
7482       etors=0.0D0
7483       endif
7484       do i=iphi_start,iphi_end
7485 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7486 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7487 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7488 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7489         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7490      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7491         itori=itortyp_kcc(itype(i-2))
7492         itori1=itortyp_kcc(itype(i-1))
7493         phii=phi(i)
7494         glocig=0.0D0
7495         glocit1=0.0d0
7496         glocit2=0.0d0
7497         sumnonchebyshev=0.0d0
7498         sumchebyshev=0.0d0
7499 C to avoid multiple devision by 2
7500         theti22=0.5d0*theta(i)
7501 C theta 12 is the theta_1 /2
7502 C theta 22 is theta_2 /2
7503         theti12=0.5d0*theta(i-1)
7504 C and appropriate sinus function
7505         sinthet2=dsin(theta(i))
7506         sinthet1=dsin(theta(i-1))
7507         costhet1=dcos(theta(i-1))
7508         costhet2=dcos(theta(i))
7509 C to speed up lets store its mutliplication
7510          sint1t2=sinthet2*sinthet1
7511 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7512 C +d_n*sin(n*gamma)) *
7513 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7514 C we have two sum 1) Non-Chebyshev which is with n and gamma
7515         do j=1,nterm_kcc(itori,itori1)
7516
7517           v1ij=v1_kcc(j,itori,itori1)
7518           v2ij=v2_kcc(j,itori,itori1)
7519 C v1ij is c_n and d_n in euation above
7520           cosphi=dcos(j*phii)
7521           sinphi=dsin(j*phii)
7522           sint1t2n=sint1t2**j
7523           sumnonchebyshev=
7524      &                    sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7525           actval=sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7526 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7527 C          if (energy_dec) etors_ii=etors_ii+
7528 C     &                v1ij*cosphi+v2ij*sinphi
7529 C glocig is the gradient local i site in gamma
7530           glocig=j*(v2ij*cosphi-v1ij*sinphi)*sint1t2n
7531 C now gradient over theta_1
7532           glocit1=actval/sinthet1*j*costhet1
7533           glocit2=actval/sinthet2*j*costhet2
7534
7535 C now the Czebyshev polinominal sum
7536         do k=1,nterm_kcc_Tb(itori,itori1)
7537          thybt1(k)=v1_chyb(k,j,itori,itori1)
7538          thybt2(k)=v2_chyb(k,j,itori,itori1)
7539 C         thybt1(k)=0.0
7540 C         thybt2(k)=0.0
7541         enddo
7542         sumth1thyb=tschebyshev
7543      &         (1,nterm_kcc_Tb(itori,itori1),thybt1(1),dcos(theti12)**2)
7544         gradthybt1=gradtschebyshev
7545      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt1(1),
7546      &        dcos(theti12)**2)
7547      & *dcos(theti12)*(-dsin(theti12))
7548         sumth2thyb=tschebyshev
7549      &         (1,nterm_kcc_Tb(itori,itori1),thybt2(1),dcos(theti22)**2)
7550         gradthybt2=gradtschebyshev
7551      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7552      &         dcos(theti22)**2)
7553      & *dcos(theti22)*(-dsin(theti22))
7554 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7555 C     &         gradtschebyshev
7556 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7557 C     &         dcos(theti22)**2),
7558 C     &         dsin(theti22)
7559
7560 C now overal sumation
7561          etors=etors+(1.0d0+sumth1thyb+sumth2thyb)*sumnonchebyshev
7562 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7563 C derivative over gamma
7564          gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7565      &   *(1.0d0+sumth1thyb+sumth2thyb)
7566 C derivative over theta1
7567         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*
7568      &  (glocit1*(1.0d0+sumth1thyb+sumth2thyb)+
7569      &   sumnonchebyshev*gradthybt1)
7570 C now derivative over theta2
7571         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*
7572      &  (glocit2*(1.0d0+sumth1thyb+sumth2thyb)+
7573      &   sumnonchebyshev*gradthybt2)
7574        enddo
7575       enddo
7576
7577 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7578 ! 6/20/98 - dihedral angle constraints
7579       if (tor_mode.ne.2) then
7580       edihcnstr=0.0d0
7581 c      do i=1,ndih_constr
7582       do i=idihconstr_start,idihconstr_end
7583         itori=idih_constr(i)
7584         phii=phi(itori)
7585         difi=pinorm(phii-phi0(i))
7586         if (difi.gt.drange(i)) then
7587           difi=difi-drange(i)
7588           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7589           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7590         else if (difi.lt.-drange(i)) then
7591           difi=difi+drange(i)
7592           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7594         else
7595           difi=0.0
7596         endif
7597        enddo
7598        endif
7599       return
7600       end
7601
7602 C The rigorous attempt to derive energy function
7603       subroutine ebend_kcc(etheta,ethetacnstr)
7604
7605       implicit real*8 (a-h,o-z)
7606       include 'DIMENSIONS'
7607       include 'COMMON.VAR'
7608       include 'COMMON.GEO'
7609       include 'COMMON.LOCAL'
7610       include 'COMMON.TORSION'
7611       include 'COMMON.INTERACT'
7612       include 'COMMON.DERIV'
7613       include 'COMMON.CHAIN'
7614       include 'COMMON.NAMES'
7615       include 'COMMON.IOUNITS'
7616       include 'COMMON.FFIELD'
7617       include 'COMMON.TORCNSTR'
7618       include 'COMMON.CONTROL'
7619       logical lprn
7620       double precision thybt1(maxtermkcc)
7621 C Set lprn=.true. for debugging
7622       lprn=.false.
7623 c     lprn=.true.
7624 C      print *,"wchodze kcc"
7625       if (tormode.ne.2) etheta=0.0D0
7626       do i=ithet_start,ithet_end
7627 c        print *,i,itype(i-1),itype(i),itype(i-2)
7628         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7629      &  .or.itype(i).eq.ntyp1) cycle
7630          iti=itortyp_kcc(itype(i-1))
7631         sinthet=dsin(theta(i)/2.0d0)
7632         costhet=dcos(theta(i)/2.0d0)
7633          do j=1,nbend_kcc_Tb(iti)
7634           thybt1(j)=v1bend_chyb(j,iti)
7635          enddo
7636          sumth1thyb=tschebyshev
7637      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7638         ihelp=nbend_kcc_Tb(iti)-1
7639         gradthybt1=gradtschebyshev
7640      &         (0,ihelp,thybt1(1),costhet)
7641         etheta=etheta+sumth1thyb
7642 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7643         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7644      &   gradthybt1*sinthet*(-0.5d0)
7645       enddo
7646       if (tormode.ne.2) then
7647       ethetacnstr=0.0d0
7648 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7649       do i=ithetaconstr_start,ithetaconstr_end
7650         itheta=itheta_constr(i)
7651         thetiii=theta(itheta)
7652         difi=pinorm(thetiii-theta_constr0(i))
7653         if (difi.gt.theta_drange(i)) then
7654           difi=difi-theta_drange(i)
7655           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7656           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7657      &    +for_thet_constr(i)*difi**3
7658         else if (difi.lt.-drange(i)) then
7659           difi=difi+drange(i)
7660           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7661           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7662      &    +for_thet_constr(i)*difi**3
7663         else
7664           difi=0.0
7665         endif
7666        if (energy_dec) then
7667         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7668      &    i,itheta,rad2deg*thetiii,
7669      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7670      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7671      &    gloc(itheta+nphi-2,icg)
7672         endif
7673       enddo
7674       endif
7675       return
7676       end
7677 c------------------------------------------------------------------------------
7678       subroutine eback_sc_corr(esccor)
7679 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7680 c        conformational states; temporarily implemented as differences
7681 c        between UNRES torsional potentials (dependent on three types of
7682 c        residues) and the torsional potentials dependent on all 20 types
7683 c        of residues computed from AM1  energy surfaces of terminally-blocked
7684 c        amino-acid residues.
7685       implicit real*8 (a-h,o-z)
7686       include 'DIMENSIONS'
7687       include 'COMMON.VAR'
7688       include 'COMMON.GEO'
7689       include 'COMMON.LOCAL'
7690       include 'COMMON.TORSION'
7691       include 'COMMON.SCCOR'
7692       include 'COMMON.INTERACT'
7693       include 'COMMON.DERIV'
7694       include 'COMMON.CHAIN'
7695       include 'COMMON.NAMES'
7696       include 'COMMON.IOUNITS'
7697       include 'COMMON.FFIELD'
7698       include 'COMMON.CONTROL'
7699       logical lprn
7700 C Set lprn=.true. for debugging
7701       lprn=.false.
7702 c      lprn=.true.
7703 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7704       esccor=0.0D0
7705       do i=itau_start,itau_end
7706         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7707         esccor_ii=0.0D0
7708         isccori=isccortyp(itype(i-2))
7709         isccori1=isccortyp(itype(i-1))
7710 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7711         phii=phi(i)
7712         do intertyp=1,3 !intertyp
7713 cc Added 09 May 2012 (Adasko)
7714 cc  Intertyp means interaction type of backbone mainchain correlation:
7715 c   1 = SC...Ca...Ca...Ca
7716 c   2 = Ca...Ca...Ca...SC
7717 c   3 = SC...Ca...Ca...SCi
7718         gloci=0.0D0
7719         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7720      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7721      &      (itype(i-1).eq.ntyp1)))
7722      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7723      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7724      &     .or.(itype(i).eq.ntyp1)))
7725      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7726      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7727      &      (itype(i-3).eq.ntyp1)))) cycle
7728         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7729         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7730      & cycle
7731        do j=1,nterm_sccor(isccori,isccori1)
7732           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7733           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7734           cosphi=dcos(j*tauangle(intertyp,i))
7735           sinphi=dsin(j*tauangle(intertyp,i))
7736           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7737           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7738         enddo
7739 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7740         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7741         if (lprn)
7742      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7743      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7744      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7745      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7746         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7747        enddo !intertyp
7748       enddo
7749
7750       return
7751       end
7752 c----------------------------------------------------------------------------
7753       subroutine multibody(ecorr)
7754 C This subroutine calculates multi-body contributions to energy following
7755 C the idea of Skolnick et al. If side chains I and J make a contact and
7756 C at the same time side chains I+1 and J+1 make a contact, an extra
7757 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7758       implicit real*8 (a-h,o-z)
7759       include 'DIMENSIONS'
7760       include 'COMMON.IOUNITS'
7761       include 'COMMON.DERIV'
7762       include 'COMMON.INTERACT'
7763       include 'COMMON.CONTACTS'
7764       double precision gx(3),gx1(3)
7765       logical lprn
7766
7767 C Set lprn=.true. for debugging
7768       lprn=.false.
7769
7770       if (lprn) then
7771         write (iout,'(a)') 'Contact function values:'
7772         do i=nnt,nct-2
7773           write (iout,'(i2,20(1x,i2,f10.5))')
7774      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7775         enddo
7776       endif
7777       ecorr=0.0D0
7778       do i=nnt,nct
7779         do j=1,3
7780           gradcorr(j,i)=0.0D0
7781           gradxorr(j,i)=0.0D0
7782         enddo
7783       enddo
7784       do i=nnt,nct-2
7785
7786         DO ISHIFT = 3,4
7787
7788         i1=i+ishift
7789         num_conti=num_cont(i)
7790         num_conti1=num_cont(i1)
7791         do jj=1,num_conti
7792           j=jcont(jj,i)
7793           do kk=1,num_conti1
7794             j1=jcont(kk,i1)
7795             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7796 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7797 cd   &                   ' ishift=',ishift
7798 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7799 C The system gains extra energy.
7800               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7801             endif   ! j1==j+-ishift
7802           enddo     ! kk
7803         enddo       ! jj
7804
7805         ENDDO ! ISHIFT
7806
7807       enddo         ! i
7808       return
7809       end
7810 c------------------------------------------------------------------------------
7811       double precision function esccorr(i,j,k,l,jj,kk)
7812       implicit real*8 (a-h,o-z)
7813       include 'DIMENSIONS'
7814       include 'COMMON.IOUNITS'
7815       include 'COMMON.DERIV'
7816       include 'COMMON.INTERACT'
7817       include 'COMMON.CONTACTS'
7818       include 'COMMON.SHIELD'
7819       double precision gx(3),gx1(3)
7820       logical lprn
7821       lprn=.false.
7822       eij=facont(jj,i)
7823       ekl=facont(kk,k)
7824 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7825 C Calculate the multi-body contribution to energy.
7826 C Calculate multi-body contributions to the gradient.
7827 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7828 cd   & k,l,(gacont(m,kk,k),m=1,3)
7829       do m=1,3
7830         gx(m) =ekl*gacont(m,jj,i)
7831         gx1(m)=eij*gacont(m,kk,k)
7832         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7833         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7834         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7835         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7836       enddo
7837       do m=i,j-1
7838         do ll=1,3
7839           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7840         enddo
7841       enddo
7842       do m=k,l-1
7843         do ll=1,3
7844           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7845         enddo
7846       enddo
7847       esccorr=-eij*ekl
7848       return
7849       end
7850 c------------------------------------------------------------------------------
7851       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7852 C This subroutine calculates multi-body contributions to hydrogen-bonding
7853       implicit real*8 (a-h,o-z)
7854       include 'DIMENSIONS'
7855       include 'COMMON.IOUNITS'
7856 #ifdef MPI
7857       include "mpif.h"
7858       parameter (max_cont=maxconts)
7859       parameter (max_dim=26)
7860       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7861       double precision zapas(max_dim,maxconts,max_fg_procs),
7862      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7863       common /przechowalnia/ zapas
7864       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7865      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7866 #endif
7867       include 'COMMON.SETUP'
7868       include 'COMMON.FFIELD'
7869       include 'COMMON.DERIV'
7870       include 'COMMON.INTERACT'
7871       include 'COMMON.CONTACTS'
7872       include 'COMMON.CONTROL'
7873       include 'COMMON.LOCAL'
7874       double precision gx(3),gx1(3),time00
7875       logical lprn,ldone
7876
7877 C Set lprn=.true. for debugging
7878       lprn=.false.
7879 #ifdef MPI
7880       n_corr=0
7881       n_corr1=0
7882       if (nfgtasks.le.1) goto 30
7883       if (lprn) then
7884         write (iout,'(a)') 'Contact function values before RECEIVE:'
7885         do i=nnt,nct-2
7886           write (iout,'(2i3,50(1x,i2,f5.2))')
7887      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7888      &    j=1,num_cont_hb(i))
7889         enddo
7890       endif
7891       call flush(iout)
7892       do i=1,ntask_cont_from
7893         ncont_recv(i)=0
7894       enddo
7895       do i=1,ntask_cont_to
7896         ncont_sent(i)=0
7897       enddo
7898 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7899 c     & ntask_cont_to
7900 C Make the list of contacts to send to send to other procesors
7901 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7902 c      call flush(iout)
7903       do i=iturn3_start,iturn3_end
7904 c        write (iout,*) "make contact list turn3",i," num_cont",
7905 c     &    num_cont_hb(i)
7906         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7907       enddo
7908       do i=iturn4_start,iturn4_end
7909 c        write (iout,*) "make contact list turn4",i," num_cont",
7910 c     &   num_cont_hb(i)
7911         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7912       enddo
7913       do ii=1,nat_sent
7914         i=iat_sent(ii)
7915 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7916 c     &    num_cont_hb(i)
7917         do j=1,num_cont_hb(i)
7918         do k=1,4
7919           jjc=jcont_hb(j,i)
7920           iproc=iint_sent_local(k,jjc,ii)
7921 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7922           if (iproc.gt.0) then
7923             ncont_sent(iproc)=ncont_sent(iproc)+1
7924             nn=ncont_sent(iproc)
7925             zapas(1,nn,iproc)=i
7926             zapas(2,nn,iproc)=jjc
7927             zapas(3,nn,iproc)=facont_hb(j,i)
7928             zapas(4,nn,iproc)=ees0p(j,i)
7929             zapas(5,nn,iproc)=ees0m(j,i)
7930             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7931             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7932             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7933             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7934             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7935             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7936             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7937             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7938             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7939             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7940             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7941             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7942             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7943             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7944             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7945             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7946             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7947             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7948             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7949             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7950             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7951           endif
7952         enddo
7953         enddo
7954       enddo
7955       if (lprn) then
7956       write (iout,*)
7957      &  "Numbers of contacts to be sent to other processors",
7958      &  (ncont_sent(i),i=1,ntask_cont_to)
7959       write (iout,*) "Contacts sent"
7960       do ii=1,ntask_cont_to
7961         nn=ncont_sent(ii)
7962         iproc=itask_cont_to(ii)
7963         write (iout,*) nn," contacts to processor",iproc,
7964      &   " of CONT_TO_COMM group"
7965         do i=1,nn
7966           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7967         enddo
7968       enddo
7969       call flush(iout)
7970       endif
7971       CorrelType=477
7972       CorrelID=fg_rank+1
7973       CorrelType1=478
7974       CorrelID1=nfgtasks+fg_rank+1
7975       ireq=0
7976 C Receive the numbers of needed contacts from other processors
7977       do ii=1,ntask_cont_from
7978         iproc=itask_cont_from(ii)
7979         ireq=ireq+1
7980         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7981      &    FG_COMM,req(ireq),IERR)
7982       enddo
7983 c      write (iout,*) "IRECV ended"
7984 c      call flush(iout)
7985 C Send the number of contacts needed by other processors
7986       do ii=1,ntask_cont_to
7987         iproc=itask_cont_to(ii)
7988         ireq=ireq+1
7989         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7990      &    FG_COMM,req(ireq),IERR)
7991       enddo
7992 c      write (iout,*) "ISEND ended"
7993 c      write (iout,*) "number of requests (nn)",ireq
7994       call flush(iout)
7995       if (ireq.gt.0)
7996      &  call MPI_Waitall(ireq,req,status_array,ierr)
7997 c      write (iout,*)
7998 c     &  "Numbers of contacts to be received from other processors",
7999 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8000 c      call flush(iout)
8001 C Receive contacts
8002       ireq=0
8003       do ii=1,ntask_cont_from
8004         iproc=itask_cont_from(ii)
8005         nn=ncont_recv(ii)
8006 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8007 c     &   " of CONT_TO_COMM group"
8008         call flush(iout)
8009         if (nn.gt.0) then
8010           ireq=ireq+1
8011           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8012      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8013 c          write (iout,*) "ireq,req",ireq,req(ireq)
8014         endif
8015       enddo
8016 C Send the contacts to processors that need them
8017       do ii=1,ntask_cont_to
8018         iproc=itask_cont_to(ii)
8019         nn=ncont_sent(ii)
8020 c        write (iout,*) nn," contacts to processor",iproc,
8021 c     &   " of CONT_TO_COMM group"
8022         if (nn.gt.0) then
8023           ireq=ireq+1
8024           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8025      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8026 c          write (iout,*) "ireq,req",ireq,req(ireq)
8027 c          do i=1,nn
8028 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8029 c          enddo
8030         endif
8031       enddo
8032 c      write (iout,*) "number of requests (contacts)",ireq
8033 c      write (iout,*) "req",(req(i),i=1,4)
8034 c      call flush(iout)
8035       if (ireq.gt.0)
8036      & call MPI_Waitall(ireq,req,status_array,ierr)
8037       do iii=1,ntask_cont_from
8038         iproc=itask_cont_from(iii)
8039         nn=ncont_recv(iii)
8040         if (lprn) then
8041         write (iout,*) "Received",nn," contacts from processor",iproc,
8042      &   " of CONT_FROM_COMM group"
8043         call flush(iout)
8044         do i=1,nn
8045           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8046         enddo
8047         call flush(iout)
8048         endif
8049         do i=1,nn
8050           ii=zapas_recv(1,i,iii)
8051 c Flag the received contacts to prevent double-counting
8052           jj=-zapas_recv(2,i,iii)
8053 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8054 c          call flush(iout)
8055           nnn=num_cont_hb(ii)+1
8056           num_cont_hb(ii)=nnn
8057           jcont_hb(nnn,ii)=jj
8058           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8059           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8060           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8061           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8062           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8063           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8064           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8065           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8066           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8067           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8068           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8069           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8070           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8071           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8072           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8073           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8074           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8075           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8076           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8077           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8078           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8079           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8080           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8081           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8082         enddo
8083       enddo
8084       call flush(iout)
8085       if (lprn) then
8086         write (iout,'(a)') 'Contact function values after receive:'
8087         do i=nnt,nct-2
8088           write (iout,'(2i3,50(1x,i3,f5.2))')
8089      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8090      &    j=1,num_cont_hb(i))
8091         enddo
8092         call flush(iout)
8093       endif
8094    30 continue
8095 #endif
8096       if (lprn) then
8097         write (iout,'(a)') 'Contact function values:'
8098         do i=nnt,nct-2
8099           write (iout,'(2i3,50(1x,i3,f5.2))')
8100      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8101      &    j=1,num_cont_hb(i))
8102         enddo
8103       endif
8104       ecorr=0.0D0
8105 C Remove the loop below after debugging !!!
8106       do i=nnt,nct
8107         do j=1,3
8108           gradcorr(j,i)=0.0D0
8109           gradxorr(j,i)=0.0D0
8110         enddo
8111       enddo
8112 C Calculate the local-electrostatic correlation terms
8113       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8114         i1=i+1
8115         num_conti=num_cont_hb(i)
8116         num_conti1=num_cont_hb(i+1)
8117         do jj=1,num_conti
8118           j=jcont_hb(jj,i)
8119           jp=iabs(j)
8120           do kk=1,num_conti1
8121             j1=jcont_hb(kk,i1)
8122             jp1=iabs(j1)
8123 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8124 c     &         ' jj=',jj,' kk=',kk
8125             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8126      &          .or. j.lt.0 .and. j1.gt.0) .and.
8127      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8128 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8129 C The system gains extra energy.
8130               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8131               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8132      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8133               n_corr=n_corr+1
8134             else if (j1.eq.j) then
8135 C Contacts I-J and I-(J+1) occur simultaneously.
8136 C The system loses extra energy.
8137 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8138             endif
8139           enddo ! kk
8140           do kk=1,num_conti
8141             j1=jcont_hb(kk,i)
8142 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8143 c    &         ' jj=',jj,' kk=',kk
8144             if (j1.eq.j+1) then
8145 C Contacts I-J and (I+1)-J occur simultaneously.
8146 C The system loses extra energy.
8147 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8148             endif ! j1==j+1
8149           enddo ! kk
8150         enddo ! jj
8151       enddo ! i
8152       return
8153       end
8154 c------------------------------------------------------------------------------
8155       subroutine add_hb_contact(ii,jj,itask)
8156       implicit real*8 (a-h,o-z)
8157       include "DIMENSIONS"
8158       include "COMMON.IOUNITS"
8159       integer max_cont
8160       integer max_dim
8161       parameter (max_cont=maxconts)
8162       parameter (max_dim=26)
8163       include "COMMON.CONTACTS"
8164       double precision zapas(max_dim,maxconts,max_fg_procs),
8165      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8166       common /przechowalnia/ zapas
8167       integer i,j,ii,jj,iproc,itask(4),nn
8168 c      write (iout,*) "itask",itask
8169       do i=1,2
8170         iproc=itask(i)
8171         if (iproc.gt.0) then
8172           do j=1,num_cont_hb(ii)
8173             jjc=jcont_hb(j,ii)
8174 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8175             if (jjc.eq.jj) then
8176               ncont_sent(iproc)=ncont_sent(iproc)+1
8177               nn=ncont_sent(iproc)
8178               zapas(1,nn,iproc)=ii
8179               zapas(2,nn,iproc)=jjc
8180               zapas(3,nn,iproc)=facont_hb(j,ii)
8181               zapas(4,nn,iproc)=ees0p(j,ii)
8182               zapas(5,nn,iproc)=ees0m(j,ii)
8183               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8184               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8185               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8186               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8187               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8188               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8189               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8190               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8191               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8192               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8193               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8194               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8195               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8196               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8197               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8198               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8199               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8200               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8201               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8202               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8203               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8204               exit
8205             endif
8206           enddo
8207         endif
8208       enddo
8209       return
8210       end
8211 c------------------------------------------------------------------------------
8212       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8213      &  n_corr1)
8214 C This subroutine calculates multi-body contributions to hydrogen-bonding
8215       implicit real*8 (a-h,o-z)
8216       include 'DIMENSIONS'
8217       include 'COMMON.IOUNITS'
8218 #ifdef MPI
8219       include "mpif.h"
8220       parameter (max_cont=maxconts)
8221       parameter (max_dim=70)
8222       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8223       double precision zapas(max_dim,maxconts,max_fg_procs),
8224      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8225       common /przechowalnia/ zapas
8226       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8227      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8228 #endif
8229       include 'COMMON.SETUP'
8230       include 'COMMON.FFIELD'
8231       include 'COMMON.DERIV'
8232       include 'COMMON.LOCAL'
8233       include 'COMMON.INTERACT'
8234       include 'COMMON.CONTACTS'
8235       include 'COMMON.CHAIN'
8236       include 'COMMON.CONTROL'
8237       include 'COMMON.SHIELD'
8238       double precision gx(3),gx1(3)
8239       integer num_cont_hb_old(maxres)
8240       logical lprn,ldone
8241       double precision eello4,eello5,eelo6,eello_turn6
8242       external eello4,eello5,eello6,eello_turn6
8243 C Set lprn=.true. for debugging
8244       lprn=.false.
8245       eturn6=0.0d0
8246 #ifdef MPI
8247       do i=1,nres
8248         num_cont_hb_old(i)=num_cont_hb(i)
8249       enddo
8250       n_corr=0
8251       n_corr1=0
8252       if (nfgtasks.le.1) goto 30
8253       if (lprn) then
8254         write (iout,'(a)') 'Contact function values before RECEIVE:'
8255         do i=nnt,nct-2
8256           write (iout,'(2i3,50(1x,i2,f5.2))')
8257      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8258      &    j=1,num_cont_hb(i))
8259         enddo
8260       endif
8261       call flush(iout)
8262       do i=1,ntask_cont_from
8263         ncont_recv(i)=0
8264       enddo
8265       do i=1,ntask_cont_to
8266         ncont_sent(i)=0
8267       enddo
8268 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8269 c     & ntask_cont_to
8270 C Make the list of contacts to send to send to other procesors
8271       do i=iturn3_start,iturn3_end
8272 c        write (iout,*) "make contact list turn3",i," num_cont",
8273 c     &    num_cont_hb(i)
8274         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8275       enddo
8276       do i=iturn4_start,iturn4_end
8277 c        write (iout,*) "make contact list turn4",i," num_cont",
8278 c     &   num_cont_hb(i)
8279         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8280       enddo
8281       do ii=1,nat_sent
8282         i=iat_sent(ii)
8283 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8284 c     &    num_cont_hb(i)
8285         do j=1,num_cont_hb(i)
8286         do k=1,4
8287           jjc=jcont_hb(j,i)
8288           iproc=iint_sent_local(k,jjc,ii)
8289 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8290           if (iproc.ne.0) then
8291             ncont_sent(iproc)=ncont_sent(iproc)+1
8292             nn=ncont_sent(iproc)
8293             zapas(1,nn,iproc)=i
8294             zapas(2,nn,iproc)=jjc
8295             zapas(3,nn,iproc)=d_cont(j,i)
8296             ind=3
8297             do kk=1,3
8298               ind=ind+1
8299               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8300             enddo
8301             do kk=1,2
8302               do ll=1,2
8303                 ind=ind+1
8304                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8305               enddo
8306             enddo
8307             do jj=1,5
8308               do kk=1,3
8309                 do ll=1,2
8310                   do mm=1,2
8311                     ind=ind+1
8312                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8313                   enddo
8314                 enddo
8315               enddo
8316             enddo
8317           endif
8318         enddo
8319         enddo
8320       enddo
8321       if (lprn) then
8322       write (iout,*)
8323      &  "Numbers of contacts to be sent to other processors",
8324      &  (ncont_sent(i),i=1,ntask_cont_to)
8325       write (iout,*) "Contacts sent"
8326       do ii=1,ntask_cont_to
8327         nn=ncont_sent(ii)
8328         iproc=itask_cont_to(ii)
8329         write (iout,*) nn," contacts to processor",iproc,
8330      &   " of CONT_TO_COMM group"
8331         do i=1,nn
8332           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8333         enddo
8334       enddo
8335       call flush(iout)
8336       endif
8337       CorrelType=477
8338       CorrelID=fg_rank+1
8339       CorrelType1=478
8340       CorrelID1=nfgtasks+fg_rank+1
8341       ireq=0
8342 C Receive the numbers of needed contacts from other processors
8343       do ii=1,ntask_cont_from
8344         iproc=itask_cont_from(ii)
8345         ireq=ireq+1
8346         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8347      &    FG_COMM,req(ireq),IERR)
8348       enddo
8349 c      write (iout,*) "IRECV ended"
8350 c      call flush(iout)
8351 C Send the number of contacts needed by other processors
8352       do ii=1,ntask_cont_to
8353         iproc=itask_cont_to(ii)
8354         ireq=ireq+1
8355         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8356      &    FG_COMM,req(ireq),IERR)
8357       enddo
8358 c      write (iout,*) "ISEND ended"
8359 c      write (iout,*) "number of requests (nn)",ireq
8360       call flush(iout)
8361       if (ireq.gt.0)
8362      &  call MPI_Waitall(ireq,req,status_array,ierr)
8363 c      write (iout,*)
8364 c     &  "Numbers of contacts to be received from other processors",
8365 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8366 c      call flush(iout)
8367 C Receive contacts
8368       ireq=0
8369       do ii=1,ntask_cont_from
8370         iproc=itask_cont_from(ii)
8371         nn=ncont_recv(ii)
8372 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8373 c     &   " of CONT_TO_COMM group"
8374         call flush(iout)
8375         if (nn.gt.0) then
8376           ireq=ireq+1
8377           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8378      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8379 c          write (iout,*) "ireq,req",ireq,req(ireq)
8380         endif
8381       enddo
8382 C Send the contacts to processors that need them
8383       do ii=1,ntask_cont_to
8384         iproc=itask_cont_to(ii)
8385         nn=ncont_sent(ii)
8386 c        write (iout,*) nn," contacts to processor",iproc,
8387 c     &   " of CONT_TO_COMM group"
8388         if (nn.gt.0) then
8389           ireq=ireq+1
8390           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8391      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8392 c          write (iout,*) "ireq,req",ireq,req(ireq)
8393 c          do i=1,nn
8394 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8395 c          enddo
8396         endif
8397       enddo
8398 c      write (iout,*) "number of requests (contacts)",ireq
8399 c      write (iout,*) "req",(req(i),i=1,4)
8400 c      call flush(iout)
8401       if (ireq.gt.0)
8402      & call MPI_Waitall(ireq,req,status_array,ierr)
8403       do iii=1,ntask_cont_from
8404         iproc=itask_cont_from(iii)
8405         nn=ncont_recv(iii)
8406         if (lprn) then
8407         write (iout,*) "Received",nn," contacts from processor",iproc,
8408      &   " of CONT_FROM_COMM group"
8409         call flush(iout)
8410         do i=1,nn
8411           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8412         enddo
8413         call flush(iout)
8414         endif
8415         do i=1,nn
8416           ii=zapas_recv(1,i,iii)
8417 c Flag the received contacts to prevent double-counting
8418           jj=-zapas_recv(2,i,iii)
8419 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8420 c          call flush(iout)
8421           nnn=num_cont_hb(ii)+1
8422           num_cont_hb(ii)=nnn
8423           jcont_hb(nnn,ii)=jj
8424           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8425           ind=3
8426           do kk=1,3
8427             ind=ind+1
8428             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8429           enddo
8430           do kk=1,2
8431             do ll=1,2
8432               ind=ind+1
8433               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8434             enddo
8435           enddo
8436           do jj=1,5
8437             do kk=1,3
8438               do ll=1,2
8439                 do mm=1,2
8440                   ind=ind+1
8441                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8442                 enddo
8443               enddo
8444             enddo
8445           enddo
8446         enddo
8447       enddo
8448       call flush(iout)
8449       if (lprn) then
8450         write (iout,'(a)') 'Contact function values after receive:'
8451         do i=nnt,nct-2
8452           write (iout,'(2i3,50(1x,i3,5f6.3))')
8453      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8454      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8455         enddo
8456         call flush(iout)
8457       endif
8458    30 continue
8459 #endif
8460       if (lprn) then
8461         write (iout,'(a)') 'Contact function values:'
8462         do i=nnt,nct-2
8463           write (iout,'(2i3,50(1x,i2,5f6.3))')
8464      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8465      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8466         enddo
8467       endif
8468       ecorr=0.0D0
8469       ecorr5=0.0d0
8470       ecorr6=0.0d0
8471 C Remove the loop below after debugging !!!
8472       do i=nnt,nct
8473         do j=1,3
8474           gradcorr(j,i)=0.0D0
8475           gradxorr(j,i)=0.0D0
8476         enddo
8477       enddo
8478 C Calculate the dipole-dipole interaction energies
8479       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8480       do i=iatel_s,iatel_e+1
8481         num_conti=num_cont_hb(i)
8482         do jj=1,num_conti
8483           j=jcont_hb(jj,i)
8484 #ifdef MOMENT
8485           call dipole(i,j,jj)
8486 #endif
8487         enddo
8488       enddo
8489       endif
8490 C Calculate the local-electrostatic correlation terms
8491 c                write (iout,*) "gradcorr5 in eello5 before loop"
8492 c                do iii=1,nres
8493 c                  write (iout,'(i5,3f10.5)')
8494 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8495 c                enddo
8496       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8497 c        write (iout,*) "corr loop i",i
8498         i1=i+1
8499         num_conti=num_cont_hb(i)
8500         num_conti1=num_cont_hb(i+1)
8501         do jj=1,num_conti
8502           j=jcont_hb(jj,i)
8503           jp=iabs(j)
8504           do kk=1,num_conti1
8505             j1=jcont_hb(kk,i1)
8506             jp1=iabs(j1)
8507 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8508 c     &         ' jj=',jj,' kk=',kk
8509 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8510             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8511      &          .or. j.lt.0 .and. j1.gt.0) .and.
8512      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8513 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8514 C The system gains extra energy.
8515               n_corr=n_corr+1
8516               sqd1=dsqrt(d_cont(jj,i))
8517               sqd2=dsqrt(d_cont(kk,i1))
8518               sred_geom = sqd1*sqd2
8519               IF (sred_geom.lt.cutoff_corr) THEN
8520                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8521      &            ekont,fprimcont)
8522 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8523 cd     &         ' jj=',jj,' kk=',kk
8524                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8525                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8526                 do l=1,3
8527                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8528                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8529                 enddo
8530                 n_corr1=n_corr1+1
8531 cd               write (iout,*) 'sred_geom=',sred_geom,
8532 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8533 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8534 cd               write (iout,*) "g_contij",g_contij
8535 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8536 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8537                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8538                 if (wcorr4.gt.0.0d0)
8539      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8540 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8541                   if (energy_dec.and.wcorr4.gt.0.0d0)
8542      1                 write (iout,'(a6,4i5,0pf7.3)')
8543      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8544 c                write (iout,*) "gradcorr5 before eello5"
8545 c                do iii=1,nres
8546 c                  write (iout,'(i5,3f10.5)')
8547 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8548 c                enddo
8549                 if (wcorr5.gt.0.0d0)
8550      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8551 c                write (iout,*) "gradcorr5 after eello5"
8552 c                do iii=1,nres
8553 c                  write (iout,'(i5,3f10.5)')
8554 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8555 c                enddo
8556                   if (energy_dec.and.wcorr5.gt.0.0d0)
8557      1                 write (iout,'(a6,4i5,0pf7.3)')
8558      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8559 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8560 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8561                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8562      &               .or. wturn6.eq.0.0d0))then
8563 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8564                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8565                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8566      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8567 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8568 cd     &            'ecorr6=',ecorr6
8569 cd                write (iout,'(4e15.5)') sred_geom,
8570 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8571 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8572 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8573                 else if (wturn6.gt.0.0d0
8574      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8575 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8576                   eturn6=eturn6+eello_turn6(i,jj,kk)
8577                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8578      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8579 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8580                 endif
8581               ENDIF
8582 1111          continue
8583             endif
8584           enddo ! kk
8585         enddo ! jj
8586       enddo ! i
8587       do i=1,nres
8588         num_cont_hb(i)=num_cont_hb_old(i)
8589       enddo
8590 c                write (iout,*) "gradcorr5 in eello5"
8591 c                do iii=1,nres
8592 c                  write (iout,'(i5,3f10.5)')
8593 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8594 c                enddo
8595       return
8596       end
8597 c------------------------------------------------------------------------------
8598       subroutine add_hb_contact_eello(ii,jj,itask)
8599       implicit real*8 (a-h,o-z)
8600       include "DIMENSIONS"
8601       include "COMMON.IOUNITS"
8602       integer max_cont
8603       integer max_dim
8604       parameter (max_cont=maxconts)
8605       parameter (max_dim=70)
8606       include "COMMON.CONTACTS"
8607       double precision zapas(max_dim,maxconts,max_fg_procs),
8608      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8609       common /przechowalnia/ zapas
8610       integer i,j,ii,jj,iproc,itask(4),nn
8611 c      write (iout,*) "itask",itask
8612       do i=1,2
8613         iproc=itask(i)
8614         if (iproc.gt.0) then
8615           do j=1,num_cont_hb(ii)
8616             jjc=jcont_hb(j,ii)
8617 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8618             if (jjc.eq.jj) then
8619               ncont_sent(iproc)=ncont_sent(iproc)+1
8620               nn=ncont_sent(iproc)
8621               zapas(1,nn,iproc)=ii
8622               zapas(2,nn,iproc)=jjc
8623               zapas(3,nn,iproc)=d_cont(j,ii)
8624               ind=3
8625               do kk=1,3
8626                 ind=ind+1
8627                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8628               enddo
8629               do kk=1,2
8630                 do ll=1,2
8631                   ind=ind+1
8632                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8633                 enddo
8634               enddo
8635               do jj=1,5
8636                 do kk=1,3
8637                   do ll=1,2
8638                     do mm=1,2
8639                       ind=ind+1
8640                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8641                     enddo
8642                   enddo
8643                 enddo
8644               enddo
8645               exit
8646             endif
8647           enddo
8648         endif
8649       enddo
8650       return
8651       end
8652 c------------------------------------------------------------------------------
8653       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8654       implicit real*8 (a-h,o-z)
8655       include 'DIMENSIONS'
8656       include 'COMMON.IOUNITS'
8657       include 'COMMON.DERIV'
8658       include 'COMMON.INTERACT'
8659       include 'COMMON.CONTACTS'
8660       include 'COMMON.SHIELD'
8661       include 'COMMON.CONTROL'
8662       double precision gx(3),gx1(3)
8663       logical lprn
8664       lprn=.false.
8665 C      print *,"wchodze",fac_shield(i),shield_mode
8666       eij=facont_hb(jj,i)
8667       ekl=facont_hb(kk,k)
8668       ees0pij=ees0p(jj,i)
8669       ees0pkl=ees0p(kk,k)
8670       ees0mij=ees0m(jj,i)
8671       ees0mkl=ees0m(kk,k)
8672       ekont=eij*ekl
8673       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8674 C*
8675 C     & fac_shield(i)**2*fac_shield(j)**2
8676 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8677 C Following 4 lines for diagnostics.
8678 cd    ees0pkl=0.0D0
8679 cd    ees0pij=1.0D0
8680 cd    ees0mkl=0.0D0
8681 cd    ees0mij=1.0D0
8682 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8683 c     & 'Contacts ',i,j,
8684 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8685 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8686 c     & 'gradcorr_long'
8687 C Calculate the multi-body contribution to energy.
8688 c      ecorr=ecorr+ekont*ees
8689 C Calculate multi-body contributions to the gradient.
8690       coeffpees0pij=coeffp*ees0pij
8691       coeffmees0mij=coeffm*ees0mij
8692       coeffpees0pkl=coeffp*ees0pkl
8693       coeffmees0mkl=coeffm*ees0mkl
8694       do ll=1,3
8695 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8696         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8697      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8698      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8699         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8700      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8701      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8702 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8703         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8704      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8705      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8706         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8707      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8708      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8709         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8710      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8711      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8712         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8713         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8714         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8715      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8716      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8717         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8718         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8719 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8720       enddo
8721 c      write (iout,*)
8722 cgrad      do m=i+1,j-1
8723 cgrad        do ll=1,3
8724 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8725 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8726 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8727 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8728 cgrad        enddo
8729 cgrad      enddo
8730 cgrad      do m=k+1,l-1
8731 cgrad        do ll=1,3
8732 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8733 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8734 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8735 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8736 cgrad        enddo
8737 cgrad      enddo
8738 c      write (iout,*) "ehbcorr",ekont*ees
8739 C      print *,ekont,ees,i,k
8740       ehbcorr=ekont*ees
8741 C now gradient over shielding
8742 C      return
8743       if (shield_mode.gt.0) then
8744        j=ees0plist(jj,i)
8745        l=ees0plist(kk,k)
8746 C        print *,i,j,fac_shield(i),fac_shield(j),
8747 C     &fac_shield(k),fac_shield(l)
8748         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8749      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8750           do ilist=1,ishield_list(i)
8751            iresshield=shield_list(ilist,i)
8752            do m=1,3
8753            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8754 C     &      *2.0
8755            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8756      &              rlocshield
8757      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8758             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8759      &+rlocshield
8760            enddo
8761           enddo
8762           do ilist=1,ishield_list(j)
8763            iresshield=shield_list(ilist,j)
8764            do m=1,3
8765            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8766 C     &     *2.0
8767            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8768      &              rlocshield
8769      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8770            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8771      &     +rlocshield
8772            enddo
8773           enddo
8774
8775           do ilist=1,ishield_list(k)
8776            iresshield=shield_list(ilist,k)
8777            do m=1,3
8778            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8779 C     &     *2.0
8780            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8781      &              rlocshield
8782      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8783            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8784      &     +rlocshield
8785            enddo
8786           enddo
8787           do ilist=1,ishield_list(l)
8788            iresshield=shield_list(ilist,l)
8789            do m=1,3
8790            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8791 C     &     *2.0
8792            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8793      &              rlocshield
8794      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8795            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8796      &     +rlocshield
8797            enddo
8798           enddo
8799 C          print *,gshieldx(m,iresshield)
8800           do m=1,3
8801             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8802      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8803             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8804      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8805             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8806      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8807             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8808      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8809
8810             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8811      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8812             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8813      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8814             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8815      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8816             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8817      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8818
8819            enddo
8820       endif
8821       endif
8822       return
8823       end
8824 #ifdef MOMENT
8825 C---------------------------------------------------------------------------
8826       subroutine dipole(i,j,jj)
8827       implicit real*8 (a-h,o-z)
8828       include 'DIMENSIONS'
8829       include 'COMMON.IOUNITS'
8830       include 'COMMON.CHAIN'
8831       include 'COMMON.FFIELD'
8832       include 'COMMON.DERIV'
8833       include 'COMMON.INTERACT'
8834       include 'COMMON.CONTACTS'
8835       include 'COMMON.TORSION'
8836       include 'COMMON.VAR'
8837       include 'COMMON.GEO'
8838       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8839      &  auxmat(2,2)
8840       iti1 = itortyp(itype(i+1))
8841       if (j.lt.nres-1) then
8842         itj1 = itortyp(itype(j+1))
8843       else
8844         itj1=ntortyp
8845       endif
8846       do iii=1,2
8847         dipi(iii,1)=Ub2(iii,i)
8848         dipderi(iii)=Ub2der(iii,i)
8849         dipi(iii,2)=b1(iii,i+1)
8850         dipj(iii,1)=Ub2(iii,j)
8851         dipderj(iii)=Ub2der(iii,j)
8852         dipj(iii,2)=b1(iii,j+1)
8853       enddo
8854       kkk=0
8855       do iii=1,2
8856         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8857         do jjj=1,2
8858           kkk=kkk+1
8859           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8860         enddo
8861       enddo
8862       do kkk=1,5
8863         do lll=1,3
8864           mmm=0
8865           do iii=1,2
8866             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8867      &        auxvec(1))
8868             do jjj=1,2
8869               mmm=mmm+1
8870               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8871             enddo
8872           enddo
8873         enddo
8874       enddo
8875       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8876       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8877       do iii=1,2
8878         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8879       enddo
8880       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8881       do iii=1,2
8882         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8883       enddo
8884       return
8885       end
8886 #endif
8887 C---------------------------------------------------------------------------
8888       subroutine calc_eello(i,j,k,l,jj,kk)
8889 C
8890 C This subroutine computes matrices and vectors needed to calculate
8891 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8892 C
8893       implicit real*8 (a-h,o-z)
8894       include 'DIMENSIONS'
8895       include 'COMMON.IOUNITS'
8896       include 'COMMON.CHAIN'
8897       include 'COMMON.DERIV'
8898       include 'COMMON.INTERACT'
8899       include 'COMMON.CONTACTS'
8900       include 'COMMON.TORSION'
8901       include 'COMMON.VAR'
8902       include 'COMMON.GEO'
8903       include 'COMMON.FFIELD'
8904       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8905      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8906       logical lprn
8907       common /kutas/ lprn
8908 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8909 cd     & ' jj=',jj,' kk=',kk
8910 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8911 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8912 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8913       do iii=1,2
8914         do jjj=1,2
8915           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8916           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8917         enddo
8918       enddo
8919       call transpose2(aa1(1,1),aa1t(1,1))
8920       call transpose2(aa2(1,1),aa2t(1,1))
8921       do kkk=1,5
8922         do lll=1,3
8923           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8924      &      aa1tder(1,1,lll,kkk))
8925           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8926      &      aa2tder(1,1,lll,kkk))
8927         enddo
8928       enddo
8929       if (l.eq.j+1) then
8930 C parallel orientation of the two CA-CA-CA frames.
8931         if (i.gt.1) then
8932           iti=itortyp(itype(i))
8933         else
8934           iti=ntortyp
8935         endif
8936         itk1=itortyp(itype(k+1))
8937         itj=itortyp(itype(j))
8938         if (l.lt.nres-1) then
8939           itl1=itortyp(itype(l+1))
8940         else
8941           itl1=ntortyp
8942         endif
8943 C A1 kernel(j+1) A2T
8944 cd        do iii=1,2
8945 cd          write (iout,'(3f10.5,5x,3f10.5)')
8946 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8947 cd        enddo
8948         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8949      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8950      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8951 C Following matrices are needed only for 6-th order cumulants
8952         IF (wcorr6.gt.0.0d0) THEN
8953         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8954      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8955      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8956         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8957      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8958      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8959      &   ADtEAderx(1,1,1,1,1,1))
8960         lprn=.false.
8961         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8962      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8963      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8964      &   ADtEA1derx(1,1,1,1,1,1))
8965         ENDIF
8966 C End 6-th order cumulants
8967 cd        lprn=.false.
8968 cd        if (lprn) then
8969 cd        write (2,*) 'In calc_eello6'
8970 cd        do iii=1,2
8971 cd          write (2,*) 'iii=',iii
8972 cd          do kkk=1,5
8973 cd            write (2,*) 'kkk=',kkk
8974 cd            do jjj=1,2
8975 cd              write (2,'(3(2f10.5),5x)')
8976 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8977 cd            enddo
8978 cd          enddo
8979 cd        enddo
8980 cd        endif
8981         call transpose2(EUgder(1,1,k),auxmat(1,1))
8982         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8983         call transpose2(EUg(1,1,k),auxmat(1,1))
8984         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8985         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8986         do iii=1,2
8987           do kkk=1,5
8988             do lll=1,3
8989               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8990      &          EAEAderx(1,1,lll,kkk,iii,1))
8991             enddo
8992           enddo
8993         enddo
8994 C A1T kernel(i+1) A2
8995         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8996      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8997      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8998 C Following matrices are needed only for 6-th order cumulants
8999         IF (wcorr6.gt.0.0d0) THEN
9000         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9001      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9002      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9003         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9004      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9005      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9006      &   ADtEAderx(1,1,1,1,1,2))
9007         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9008      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9009      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9010      &   ADtEA1derx(1,1,1,1,1,2))
9011         ENDIF
9012 C End 6-th order cumulants
9013         call transpose2(EUgder(1,1,l),auxmat(1,1))
9014         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9015         call transpose2(EUg(1,1,l),auxmat(1,1))
9016         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9017         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9018         do iii=1,2
9019           do kkk=1,5
9020             do lll=1,3
9021               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9022      &          EAEAderx(1,1,lll,kkk,iii,2))
9023             enddo
9024           enddo
9025         enddo
9026 C AEAb1 and AEAb2
9027 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9028 C They are needed only when the fifth- or the sixth-order cumulants are
9029 C indluded.
9030         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9031         call transpose2(AEA(1,1,1),auxmat(1,1))
9032         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9034         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9035         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9036         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9037         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9038         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9039         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9040         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9041         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9042         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9043         call transpose2(AEA(1,1,2),auxmat(1,1))
9044         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9045         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9046         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9047         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9048         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9049         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9050         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9051         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9052         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9053         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9054         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9055 C Calculate the Cartesian derivatives of the vectors.
9056         do iii=1,2
9057           do kkk=1,5
9058             do lll=1,3
9059               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9060               call matvec2(auxmat(1,1),b1(1,i),
9061      &          AEAb1derx(1,lll,kkk,iii,1,1))
9062               call matvec2(auxmat(1,1),Ub2(1,i),
9063      &          AEAb2derx(1,lll,kkk,iii,1,1))
9064               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9065      &          AEAb1derx(1,lll,kkk,iii,2,1))
9066               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9067      &          AEAb2derx(1,lll,kkk,iii,2,1))
9068               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9069               call matvec2(auxmat(1,1),b1(1,j),
9070      &          AEAb1derx(1,lll,kkk,iii,1,2))
9071               call matvec2(auxmat(1,1),Ub2(1,j),
9072      &          AEAb2derx(1,lll,kkk,iii,1,2))
9073               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9074      &          AEAb1derx(1,lll,kkk,iii,2,2))
9075               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9076      &          AEAb2derx(1,lll,kkk,iii,2,2))
9077             enddo
9078           enddo
9079         enddo
9080         ENDIF
9081 C End vectors
9082       else
9083 C Antiparallel orientation of the two CA-CA-CA frames.
9084         if (i.gt.1) then
9085           iti=itortyp(itype(i))
9086         else
9087           iti=ntortyp
9088         endif
9089         itk1=itortyp(itype(k+1))
9090         itl=itortyp(itype(l))
9091         itj=itortyp(itype(j))
9092         if (j.lt.nres-1) then
9093           itj1=itortyp(itype(j+1))
9094         else
9095           itj1=ntortyp
9096         endif
9097 C A2 kernel(j-1)T A1T
9098         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9099      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9100      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9101 C Following matrices are needed only for 6-th order cumulants
9102         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9103      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9105      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9106      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9107         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9108      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9109      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9110      &   ADtEAderx(1,1,1,1,1,1))
9111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9112      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9113      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9114      &   ADtEA1derx(1,1,1,1,1,1))
9115         ENDIF
9116 C End 6-th order cumulants
9117         call transpose2(EUgder(1,1,k),auxmat(1,1))
9118         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9119         call transpose2(EUg(1,1,k),auxmat(1,1))
9120         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9121         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9122         do iii=1,2
9123           do kkk=1,5
9124             do lll=1,3
9125               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9126      &          EAEAderx(1,1,lll,kkk,iii,1))
9127             enddo
9128           enddo
9129         enddo
9130 C A2T kernel(i+1)T A1
9131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9132      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9133      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9134 C Following matrices are needed only for 6-th order cumulants
9135         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9136      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9137         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9138      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9139      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9140         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9141      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9142      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9143      &   ADtEAderx(1,1,1,1,1,2))
9144         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9145      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9146      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9147      &   ADtEA1derx(1,1,1,1,1,2))
9148         ENDIF
9149 C End 6-th order cumulants
9150         call transpose2(EUgder(1,1,j),auxmat(1,1))
9151         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9152         call transpose2(EUg(1,1,j),auxmat(1,1))
9153         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9154         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9155         do iii=1,2
9156           do kkk=1,5
9157             do lll=1,3
9158               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9159      &          EAEAderx(1,1,lll,kkk,iii,2))
9160             enddo
9161           enddo
9162         enddo
9163 C AEAb1 and AEAb2
9164 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9165 C They are needed only when the fifth- or the sixth-order cumulants are
9166 C indluded.
9167         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9168      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9169         call transpose2(AEA(1,1,1),auxmat(1,1))
9170         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9172         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9173         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9174         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9175         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9176         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9177         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9178         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9179         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9180         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9181         call transpose2(AEA(1,1,2),auxmat(1,1))
9182         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9183         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9184         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9185         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9186         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9187         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9188         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9189         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9190         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9191         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9192         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9193 C Calculate the Cartesian derivatives of the vectors.
9194         do iii=1,2
9195           do kkk=1,5
9196             do lll=1,3
9197               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9198               call matvec2(auxmat(1,1),b1(1,i),
9199      &          AEAb1derx(1,lll,kkk,iii,1,1))
9200               call matvec2(auxmat(1,1),Ub2(1,i),
9201      &          AEAb2derx(1,lll,kkk,iii,1,1))
9202               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9203      &          AEAb1derx(1,lll,kkk,iii,2,1))
9204               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9205      &          AEAb2derx(1,lll,kkk,iii,2,1))
9206               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9207               call matvec2(auxmat(1,1),b1(1,l),
9208      &          AEAb1derx(1,lll,kkk,iii,1,2))
9209               call matvec2(auxmat(1,1),Ub2(1,l),
9210      &          AEAb2derx(1,lll,kkk,iii,1,2))
9211               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9212      &          AEAb1derx(1,lll,kkk,iii,2,2))
9213               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9214      &          AEAb2derx(1,lll,kkk,iii,2,2))
9215             enddo
9216           enddo
9217         enddo
9218         ENDIF
9219 C End vectors
9220       endif
9221       return
9222       end
9223 C---------------------------------------------------------------------------
9224       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9225      &  KK,KKderg,AKA,AKAderg,AKAderx)
9226       implicit none
9227       integer nderg
9228       logical transp
9229       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9230      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9231      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9232       integer iii,kkk,lll
9233       integer jjj,mmm
9234       logical lprn
9235       common /kutas/ lprn
9236       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9237       do iii=1,nderg
9238         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9239      &    AKAderg(1,1,iii))
9240       enddo
9241 cd      if (lprn) write (2,*) 'In kernel'
9242       do kkk=1,5
9243 cd        if (lprn) write (2,*) 'kkk=',kkk
9244         do lll=1,3
9245           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9246      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9247 cd          if (lprn) then
9248 cd            write (2,*) 'lll=',lll
9249 cd            write (2,*) 'iii=1'
9250 cd            do jjj=1,2
9251 cd              write (2,'(3(2f10.5),5x)')
9252 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9253 cd            enddo
9254 cd          endif
9255           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9256      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9257 cd          if (lprn) then
9258 cd            write (2,*) 'lll=',lll
9259 cd            write (2,*) 'iii=2'
9260 cd            do jjj=1,2
9261 cd              write (2,'(3(2f10.5),5x)')
9262 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9263 cd            enddo
9264 cd          endif
9265         enddo
9266       enddo
9267       return
9268       end
9269 C---------------------------------------------------------------------------
9270       double precision function eello4(i,j,k,l,jj,kk)
9271       implicit real*8 (a-h,o-z)
9272       include 'DIMENSIONS'
9273       include 'COMMON.IOUNITS'
9274       include 'COMMON.CHAIN'
9275       include 'COMMON.DERIV'
9276       include 'COMMON.INTERACT'
9277       include 'COMMON.CONTACTS'
9278       include 'COMMON.TORSION'
9279       include 'COMMON.VAR'
9280       include 'COMMON.GEO'
9281       double precision pizda(2,2),ggg1(3),ggg2(3)
9282 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9283 cd        eello4=0.0d0
9284 cd        return
9285 cd      endif
9286 cd      print *,'eello4:',i,j,k,l,jj,kk
9287 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9288 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9289 cold      eij=facont_hb(jj,i)
9290 cold      ekl=facont_hb(kk,k)
9291 cold      ekont=eij*ekl
9292       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9293 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9294       gcorr_loc(k-1)=gcorr_loc(k-1)
9295      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9296       if (l.eq.j+1) then
9297         gcorr_loc(l-1)=gcorr_loc(l-1)
9298      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9299       else
9300         gcorr_loc(j-1)=gcorr_loc(j-1)
9301      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9302       endif
9303       do iii=1,2
9304         do kkk=1,5
9305           do lll=1,3
9306             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9307      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9308 cd            derx(lll,kkk,iii)=0.0d0
9309           enddo
9310         enddo
9311       enddo
9312 cd      gcorr_loc(l-1)=0.0d0
9313 cd      gcorr_loc(j-1)=0.0d0
9314 cd      gcorr_loc(k-1)=0.0d0
9315 cd      eel4=1.0d0
9316 cd      write (iout,*)'Contacts have occurred for peptide groups',
9317 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9318 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9319       if (j.lt.nres-1) then
9320         j1=j+1
9321         j2=j-1
9322       else
9323         j1=j-1
9324         j2=j-2
9325       endif
9326       if (l.lt.nres-1) then
9327         l1=l+1
9328         l2=l-1
9329       else
9330         l1=l-1
9331         l2=l-2
9332       endif
9333       do ll=1,3
9334 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9335 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9336         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9337         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9338 cgrad        ghalf=0.5d0*ggg1(ll)
9339         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9340         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9341         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9342         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9343         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9344         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9345 cgrad        ghalf=0.5d0*ggg2(ll)
9346         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9347         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9348         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9349         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9350         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9351         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9352       enddo
9353 cgrad      do m=i+1,j-1
9354 cgrad        do ll=1,3
9355 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9356 cgrad        enddo
9357 cgrad      enddo
9358 cgrad      do m=k+1,l-1
9359 cgrad        do ll=1,3
9360 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9361 cgrad        enddo
9362 cgrad      enddo
9363 cgrad      do m=i+2,j2
9364 cgrad        do ll=1,3
9365 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9366 cgrad        enddo
9367 cgrad      enddo
9368 cgrad      do m=k+2,l2
9369 cgrad        do ll=1,3
9370 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9371 cgrad        enddo
9372 cgrad      enddo
9373 cd      do iii=1,nres-3
9374 cd        write (2,*) iii,gcorr_loc(iii)
9375 cd      enddo
9376       eello4=ekont*eel4
9377 cd      write (2,*) 'ekont',ekont
9378 cd      write (iout,*) 'eello4',ekont*eel4
9379       return
9380       end
9381 C---------------------------------------------------------------------------
9382       double precision function eello5(i,j,k,l,jj,kk)
9383       implicit real*8 (a-h,o-z)
9384       include 'DIMENSIONS'
9385       include 'COMMON.IOUNITS'
9386       include 'COMMON.CHAIN'
9387       include 'COMMON.DERIV'
9388       include 'COMMON.INTERACT'
9389       include 'COMMON.CONTACTS'
9390       include 'COMMON.TORSION'
9391       include 'COMMON.VAR'
9392       include 'COMMON.GEO'
9393       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9394       double precision ggg1(3),ggg2(3)
9395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9396 C                                                                              C
9397 C                            Parallel chains                                   C
9398 C                                                                              C
9399 C          o             o                   o             o                   C
9400 C         /l\           / \             \   / \           / \   /              C
9401 C        /   \         /   \             \ /   \         /   \ /               C
9402 C       j| o |l1       | o |              o| o |         | o |o                C
9403 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9404 C      \i/   \         /   \ /             /   \         /   \                 C
9405 C       o    k1             o                                                  C
9406 C         (I)          (II)                (III)          (IV)                 C
9407 C                                                                              C
9408 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9409 C                                                                              C
9410 C                            Antiparallel chains                               C
9411 C                                                                              C
9412 C          o             o                   o             o                   C
9413 C         /j\           / \             \   / \           / \   /              C
9414 C        /   \         /   \             \ /   \         /   \ /               C
9415 C      j1| o |l        | o |              o| o |         | o |o                C
9416 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9417 C      \i/   \         /   \ /             /   \         /   \                 C
9418 C       o     k1            o                                                  C
9419 C         (I)          (II)                (III)          (IV)                 C
9420 C                                                                              C
9421 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9422 C                                                                              C
9423 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9424 C                                                                              C
9425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9426 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9427 cd        eello5=0.0d0
9428 cd        return
9429 cd      endif
9430 cd      write (iout,*)
9431 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9432 cd     &   ' and',k,l
9433       itk=itortyp(itype(k))
9434       itl=itortyp(itype(l))
9435       itj=itortyp(itype(j))
9436       eello5_1=0.0d0
9437       eello5_2=0.0d0
9438       eello5_3=0.0d0
9439       eello5_4=0.0d0
9440 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9441 cd     &   eel5_3_num,eel5_4_num)
9442       do iii=1,2
9443         do kkk=1,5
9444           do lll=1,3
9445             derx(lll,kkk,iii)=0.0d0
9446           enddo
9447         enddo
9448       enddo
9449 cd      eij=facont_hb(jj,i)
9450 cd      ekl=facont_hb(kk,k)
9451 cd      ekont=eij*ekl
9452 cd      write (iout,*)'Contacts have occurred for peptide groups',
9453 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9454 cd      goto 1111
9455 C Contribution from the graph I.
9456 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9457 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9458       call transpose2(EUg(1,1,k),auxmat(1,1))
9459       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9460       vv(1)=pizda(1,1)-pizda(2,2)
9461       vv(2)=pizda(1,2)+pizda(2,1)
9462       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9463      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9464 C Explicit gradient in virtual-dihedral angles.
9465       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9466      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9467      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9468       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9469       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9470       vv(1)=pizda(1,1)-pizda(2,2)
9471       vv(2)=pizda(1,2)+pizda(2,1)
9472       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9473      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9474      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9475       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9476       vv(1)=pizda(1,1)-pizda(2,2)
9477       vv(2)=pizda(1,2)+pizda(2,1)
9478       if (l.eq.j+1) then
9479         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9480      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9481      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9482       else
9483         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9484      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9485      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9486       endif
9487 C Cartesian gradient
9488       do iii=1,2
9489         do kkk=1,5
9490           do lll=1,3
9491             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9492      &        pizda(1,1))
9493             vv(1)=pizda(1,1)-pizda(2,2)
9494             vv(2)=pizda(1,2)+pizda(2,1)
9495             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9496      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9497      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9498           enddo
9499         enddo
9500       enddo
9501 c      goto 1112
9502 c1111  continue
9503 C Contribution from graph II
9504       call transpose2(EE(1,1,itk),auxmat(1,1))
9505       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9506       vv(1)=pizda(1,1)+pizda(2,2)
9507       vv(2)=pizda(2,1)-pizda(1,2)
9508       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9509      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9510 C Explicit gradient in virtual-dihedral angles.
9511       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9512      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9513       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9514       vv(1)=pizda(1,1)+pizda(2,2)
9515       vv(2)=pizda(2,1)-pizda(1,2)
9516       if (l.eq.j+1) then
9517         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9518      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9519      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9520       else
9521         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9522      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9523      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9524       endif
9525 C Cartesian gradient
9526       do iii=1,2
9527         do kkk=1,5
9528           do lll=1,3
9529             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9530      &        pizda(1,1))
9531             vv(1)=pizda(1,1)+pizda(2,2)
9532             vv(2)=pizda(2,1)-pizda(1,2)
9533             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9534      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9535      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9536           enddo
9537         enddo
9538       enddo
9539 cd      goto 1112
9540 cd1111  continue
9541       if (l.eq.j+1) then
9542 cd        goto 1110
9543 C Parallel orientation
9544 C Contribution from graph III
9545         call transpose2(EUg(1,1,l),auxmat(1,1))
9546         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9547         vv(1)=pizda(1,1)-pizda(2,2)
9548         vv(2)=pizda(1,2)+pizda(2,1)
9549         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9550      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9551 C Explicit gradient in virtual-dihedral angles.
9552         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9553      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9554      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9555         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9556         vv(1)=pizda(1,1)-pizda(2,2)
9557         vv(2)=pizda(1,2)+pizda(2,1)
9558         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9559      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9560      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9561         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9562         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9563         vv(1)=pizda(1,1)-pizda(2,2)
9564         vv(2)=pizda(1,2)+pizda(2,1)
9565         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9566      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9567      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9568 C Cartesian gradient
9569         do iii=1,2
9570           do kkk=1,5
9571             do lll=1,3
9572               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9573      &          pizda(1,1))
9574               vv(1)=pizda(1,1)-pizda(2,2)
9575               vv(2)=pizda(1,2)+pizda(2,1)
9576               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9577      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9578      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9579             enddo
9580           enddo
9581         enddo
9582 cd        goto 1112
9583 C Contribution from graph IV
9584 cd1110    continue
9585         call transpose2(EE(1,1,itl),auxmat(1,1))
9586         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9587         vv(1)=pizda(1,1)+pizda(2,2)
9588         vv(2)=pizda(2,1)-pizda(1,2)
9589         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9590      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9591 C Explicit gradient in virtual-dihedral angles.
9592         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9593      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9594         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9595         vv(1)=pizda(1,1)+pizda(2,2)
9596         vv(2)=pizda(2,1)-pizda(1,2)
9597         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9598      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9599      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9600 C Cartesian gradient
9601         do iii=1,2
9602           do kkk=1,5
9603             do lll=1,3
9604               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9605      &          pizda(1,1))
9606               vv(1)=pizda(1,1)+pizda(2,2)
9607               vv(2)=pizda(2,1)-pizda(1,2)
9608               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9609      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9610      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9611             enddo
9612           enddo
9613         enddo
9614       else
9615 C Antiparallel orientation
9616 C Contribution from graph III
9617 c        goto 1110
9618         call transpose2(EUg(1,1,j),auxmat(1,1))
9619         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9620         vv(1)=pizda(1,1)-pizda(2,2)
9621         vv(2)=pizda(1,2)+pizda(2,1)
9622         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9623      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9624 C Explicit gradient in virtual-dihedral angles.
9625         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9626      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9627      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9628         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9629         vv(1)=pizda(1,1)-pizda(2,2)
9630         vv(2)=pizda(1,2)+pizda(2,1)
9631         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9632      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9633      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9634         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9635         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9636         vv(1)=pizda(1,1)-pizda(2,2)
9637         vv(2)=pizda(1,2)+pizda(2,1)
9638         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9639      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9640      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9641 C Cartesian gradient
9642         do iii=1,2
9643           do kkk=1,5
9644             do lll=1,3
9645               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9646      &          pizda(1,1))
9647               vv(1)=pizda(1,1)-pizda(2,2)
9648               vv(2)=pizda(1,2)+pizda(2,1)
9649               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9650      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9651      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9652             enddo
9653           enddo
9654         enddo
9655 cd        goto 1112
9656 C Contribution from graph IV
9657 1110    continue
9658         call transpose2(EE(1,1,itj),auxmat(1,1))
9659         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9660         vv(1)=pizda(1,1)+pizda(2,2)
9661         vv(2)=pizda(2,1)-pizda(1,2)
9662         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9663      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9664 C Explicit gradient in virtual-dihedral angles.
9665         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9666      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9667         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9668         vv(1)=pizda(1,1)+pizda(2,2)
9669         vv(2)=pizda(2,1)-pizda(1,2)
9670         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9671      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9672      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9673 C Cartesian gradient
9674         do iii=1,2
9675           do kkk=1,5
9676             do lll=1,3
9677               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9678      &          pizda(1,1))
9679               vv(1)=pizda(1,1)+pizda(2,2)
9680               vv(2)=pizda(2,1)-pizda(1,2)
9681               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9682      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9683      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9684             enddo
9685           enddo
9686         enddo
9687       endif
9688 1112  continue
9689       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9690 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9691 cd        write (2,*) 'ijkl',i,j,k,l
9692 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9693 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9694 cd      endif
9695 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9696 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9697 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9698 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9699       if (j.lt.nres-1) then
9700         j1=j+1
9701         j2=j-1
9702       else
9703         j1=j-1
9704         j2=j-2
9705       endif
9706       if (l.lt.nres-1) then
9707         l1=l+1
9708         l2=l-1
9709       else
9710         l1=l-1
9711         l2=l-2
9712       endif
9713 cd      eij=1.0d0
9714 cd      ekl=1.0d0
9715 cd      ekont=1.0d0
9716 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9717 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9718 C        summed up outside the subrouine as for the other subroutines
9719 C        handling long-range interactions. The old code is commented out
9720 C        with "cgrad" to keep track of changes.
9721       do ll=1,3
9722 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9723 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9724         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9725         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9726 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9727 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9728 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9729 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9730 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9731 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9732 c     &   gradcorr5ij,
9733 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9734 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9735 cgrad        ghalf=0.5d0*ggg1(ll)
9736 cd        ghalf=0.0d0
9737         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9738         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9739         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9740         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9741         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9742         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9743 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9744 cgrad        ghalf=0.5d0*ggg2(ll)
9745 cd        ghalf=0.0d0
9746         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9747         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9748         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9749         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9750         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9751         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9752       enddo
9753 cd      goto 1112
9754 cgrad      do m=i+1,j-1
9755 cgrad        do ll=1,3
9756 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9757 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9758 cgrad        enddo
9759 cgrad      enddo
9760 cgrad      do m=k+1,l-1
9761 cgrad        do ll=1,3
9762 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9763 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9764 cgrad        enddo
9765 cgrad      enddo
9766 c1112  continue
9767 cgrad      do m=i+2,j2
9768 cgrad        do ll=1,3
9769 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9770 cgrad        enddo
9771 cgrad      enddo
9772 cgrad      do m=k+2,l2
9773 cgrad        do ll=1,3
9774 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9775 cgrad        enddo
9776 cgrad      enddo
9777 cd      do iii=1,nres-3
9778 cd        write (2,*) iii,g_corr5_loc(iii)
9779 cd      enddo
9780       eello5=ekont*eel5
9781 cd      write (2,*) 'ekont',ekont
9782 cd      write (iout,*) 'eello5',ekont*eel5
9783       return
9784       end
9785 c--------------------------------------------------------------------------
9786       double precision function eello6(i,j,k,l,jj,kk)
9787       implicit real*8 (a-h,o-z)
9788       include 'DIMENSIONS'
9789       include 'COMMON.IOUNITS'
9790       include 'COMMON.CHAIN'
9791       include 'COMMON.DERIV'
9792       include 'COMMON.INTERACT'
9793       include 'COMMON.CONTACTS'
9794       include 'COMMON.TORSION'
9795       include 'COMMON.VAR'
9796       include 'COMMON.GEO'
9797       include 'COMMON.FFIELD'
9798       double precision ggg1(3),ggg2(3)
9799 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9800 cd        eello6=0.0d0
9801 cd        return
9802 cd      endif
9803 cd      write (iout,*)
9804 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9805 cd     &   ' and',k,l
9806       eello6_1=0.0d0
9807       eello6_2=0.0d0
9808       eello6_3=0.0d0
9809       eello6_4=0.0d0
9810       eello6_5=0.0d0
9811       eello6_6=0.0d0
9812 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9813 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9814       do iii=1,2
9815         do kkk=1,5
9816           do lll=1,3
9817             derx(lll,kkk,iii)=0.0d0
9818           enddo
9819         enddo
9820       enddo
9821 cd      eij=facont_hb(jj,i)
9822 cd      ekl=facont_hb(kk,k)
9823 cd      ekont=eij*ekl
9824 cd      eij=1.0d0
9825 cd      ekl=1.0d0
9826 cd      ekont=1.0d0
9827       if (l.eq.j+1) then
9828         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9829         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9830         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9831         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9832         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9833         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9834       else
9835         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9836         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9837         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9838         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9839         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9840           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9841         else
9842           eello6_5=0.0d0
9843         endif
9844         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9845       endif
9846 C If turn contributions are considered, they will be handled separately.
9847       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9848 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9849 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9850 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9851 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9852 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9853 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9854 cd      goto 1112
9855       if (j.lt.nres-1) then
9856         j1=j+1
9857         j2=j-1
9858       else
9859         j1=j-1
9860         j2=j-2
9861       endif
9862       if (l.lt.nres-1) then
9863         l1=l+1
9864         l2=l-1
9865       else
9866         l1=l-1
9867         l2=l-2
9868       endif
9869       do ll=1,3
9870 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9871 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9872 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9873 cgrad        ghalf=0.5d0*ggg1(ll)
9874 cd        ghalf=0.0d0
9875         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9876         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9877         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9878         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9879         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9880         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9881         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9882         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9883 cgrad        ghalf=0.5d0*ggg2(ll)
9884 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9885 cd        ghalf=0.0d0
9886         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9887         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9888         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9889         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9890         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9891         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9892       enddo
9893 cd      goto 1112
9894 cgrad      do m=i+1,j-1
9895 cgrad        do ll=1,3
9896 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9897 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9898 cgrad        enddo
9899 cgrad      enddo
9900 cgrad      do m=k+1,l-1
9901 cgrad        do ll=1,3
9902 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9903 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9904 cgrad        enddo
9905 cgrad      enddo
9906 cgrad1112  continue
9907 cgrad      do m=i+2,j2
9908 cgrad        do ll=1,3
9909 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9910 cgrad        enddo
9911 cgrad      enddo
9912 cgrad      do m=k+2,l2
9913 cgrad        do ll=1,3
9914 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9915 cgrad        enddo
9916 cgrad      enddo
9917 cd      do iii=1,nres-3
9918 cd        write (2,*) iii,g_corr6_loc(iii)
9919 cd      enddo
9920       eello6=ekont*eel6
9921 cd      write (2,*) 'ekont',ekont
9922 cd      write (iout,*) 'eello6',ekont*eel6
9923       return
9924       end
9925 c--------------------------------------------------------------------------
9926       double precision function eello6_graph1(i,j,k,l,imat,swap)
9927       implicit real*8 (a-h,o-z)
9928       include 'DIMENSIONS'
9929       include 'COMMON.IOUNITS'
9930       include 'COMMON.CHAIN'
9931       include 'COMMON.DERIV'
9932       include 'COMMON.INTERACT'
9933       include 'COMMON.CONTACTS'
9934       include 'COMMON.TORSION'
9935       include 'COMMON.VAR'
9936       include 'COMMON.GEO'
9937       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9938       logical swap
9939       logical lprn
9940       common /kutas/ lprn
9941 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9942 C                                                                              C
9943 C      Parallel       Antiparallel                                             C
9944 C                                                                              C
9945 C          o             o                                                     C
9946 C         /l\           /j\                                                    C
9947 C        /   \         /   \                                                   C
9948 C       /| o |         | o |\                                                  C
9949 C     \ j|/k\|  /   \  |/k\|l /                                                C
9950 C      \ /   \ /     \ /   \ /                                                 C
9951 C       o     o       o     o                                                  C
9952 C       i             i                                                        C
9953 C                                                                              C
9954 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9955       itk=itortyp(itype(k))
9956       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9957       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9958       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9959       call transpose2(EUgC(1,1,k),auxmat(1,1))
9960       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9961       vv1(1)=pizda1(1,1)-pizda1(2,2)
9962       vv1(2)=pizda1(1,2)+pizda1(2,1)
9963       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9964       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9965       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9966       s5=scalar2(vv(1),Dtobr2(1,i))
9967 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9968       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9969       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9970      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9971      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9972      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9973      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9974      & +scalar2(vv(1),Dtobr2der(1,i)))
9975       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9976       vv1(1)=pizda1(1,1)-pizda1(2,2)
9977       vv1(2)=pizda1(1,2)+pizda1(2,1)
9978       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9979       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9980       if (l.eq.j+1) then
9981         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9982      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9983      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9984      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9985      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9986       else
9987         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9988      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9989      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9990      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9991      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9992       endif
9993       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9994       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9995       vv1(1)=pizda1(1,1)-pizda1(2,2)
9996       vv1(2)=pizda1(1,2)+pizda1(2,1)
9997       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9998      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9999      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10000      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10001       do iii=1,2
10002         if (swap) then
10003           ind=3-iii
10004         else
10005           ind=iii
10006         endif
10007         do kkk=1,5
10008           do lll=1,3
10009             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10010             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10011             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10012             call transpose2(EUgC(1,1,k),auxmat(1,1))
10013             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10014      &        pizda1(1,1))
10015             vv1(1)=pizda1(1,1)-pizda1(2,2)
10016             vv1(2)=pizda1(1,2)+pizda1(2,1)
10017             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10018             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10019      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10020             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10021      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10022             s5=scalar2(vv(1),Dtobr2(1,i))
10023             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10024           enddo
10025         enddo
10026       enddo
10027       return
10028       end
10029 c----------------------------------------------------------------------------
10030       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10031       implicit real*8 (a-h,o-z)
10032       include 'DIMENSIONS'
10033       include 'COMMON.IOUNITS'
10034       include 'COMMON.CHAIN'
10035       include 'COMMON.DERIV'
10036       include 'COMMON.INTERACT'
10037       include 'COMMON.CONTACTS'
10038       include 'COMMON.TORSION'
10039       include 'COMMON.VAR'
10040       include 'COMMON.GEO'
10041       logical swap
10042       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10043      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10044       logical lprn
10045       common /kutas/ lprn
10046 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10047 C                                                                              C
10048 C      Parallel       Antiparallel                                             C
10049 C                                                                              C
10050 C          o             o                                                     C
10051 C     \   /l\           /j\   /                                                C
10052 C      \ /   \         /   \ /                                                 C
10053 C       o| o |         | o |o                                                  C
10054 C     \ j|/k\|      \  |/k\|l                                                  C
10055 C      \ /   \       \ /   \                                                   C
10056 C       o             o                                                        C
10057 C       i             i                                                        C
10058 C                                                                              C
10059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10060 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10061 C AL 7/4/01 s1 would occur in the sixth-order moment,
10062 C           but not in a cluster cumulant
10063 #ifdef MOMENT
10064       s1=dip(1,jj,i)*dip(1,kk,k)
10065 #endif
10066       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10067       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10068       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10069       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10070       call transpose2(EUg(1,1,k),auxmat(1,1))
10071       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10072       vv(1)=pizda(1,1)-pizda(2,2)
10073       vv(2)=pizda(1,2)+pizda(2,1)
10074       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10075 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10076 #ifdef MOMENT
10077       eello6_graph2=-(s1+s2+s3+s4)
10078 #else
10079       eello6_graph2=-(s2+s3+s4)
10080 #endif
10081 c      eello6_graph2=-s3
10082 C Derivatives in gamma(i-1)
10083       if (i.gt.1) then
10084 #ifdef MOMENT
10085         s1=dipderg(1,jj,i)*dip(1,kk,k)
10086 #endif
10087         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10088         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10089         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10090         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10091 #ifdef MOMENT
10092         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10093 #else
10094         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10095 #endif
10096 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10097       endif
10098 C Derivatives in gamma(k-1)
10099 #ifdef MOMENT
10100       s1=dip(1,jj,i)*dipderg(1,kk,k)
10101 #endif
10102       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10103       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10104       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10105       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10106       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10107       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10108       vv(1)=pizda(1,1)-pizda(2,2)
10109       vv(2)=pizda(1,2)+pizda(2,1)
10110       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10111 #ifdef MOMENT
10112       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10113 #else
10114       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10115 #endif
10116 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10117 C Derivatives in gamma(j-1) or gamma(l-1)
10118       if (j.gt.1) then
10119 #ifdef MOMENT
10120         s1=dipderg(3,jj,i)*dip(1,kk,k)
10121 #endif
10122         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10123         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10124         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10125         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10126         vv(1)=pizda(1,1)-pizda(2,2)
10127         vv(2)=pizda(1,2)+pizda(2,1)
10128         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10129 #ifdef MOMENT
10130         if (swap) then
10131           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10132         else
10133           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10134         endif
10135 #endif
10136         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10137 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10138       endif
10139 C Derivatives in gamma(l-1) or gamma(j-1)
10140       if (l.gt.1) then
10141 #ifdef MOMENT
10142         s1=dip(1,jj,i)*dipderg(3,kk,k)
10143 #endif
10144         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10145         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10146         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10147         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10148         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10149         vv(1)=pizda(1,1)-pizda(2,2)
10150         vv(2)=pizda(1,2)+pizda(2,1)
10151         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10152 #ifdef MOMENT
10153         if (swap) then
10154           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10155         else
10156           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10157         endif
10158 #endif
10159         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10160 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10161       endif
10162 C Cartesian derivatives.
10163       if (lprn) then
10164         write (2,*) 'In eello6_graph2'
10165         do iii=1,2
10166           write (2,*) 'iii=',iii
10167           do kkk=1,5
10168             write (2,*) 'kkk=',kkk
10169             do jjj=1,2
10170               write (2,'(3(2f10.5),5x)')
10171      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10172             enddo
10173           enddo
10174         enddo
10175       endif
10176       do iii=1,2
10177         do kkk=1,5
10178           do lll=1,3
10179 #ifdef MOMENT
10180             if (iii.eq.1) then
10181               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10182             else
10183               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10184             endif
10185 #endif
10186             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10187      &        auxvec(1))
10188             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10189             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10190      &        auxvec(1))
10191             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10192             call transpose2(EUg(1,1,k),auxmat(1,1))
10193             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10194      &        pizda(1,1))
10195             vv(1)=pizda(1,1)-pizda(2,2)
10196             vv(2)=pizda(1,2)+pizda(2,1)
10197             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10198 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10199 #ifdef MOMENT
10200             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10201 #else
10202             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10203 #endif
10204             if (swap) then
10205               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10206             else
10207               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10208             endif
10209           enddo
10210         enddo
10211       enddo
10212       return
10213       end
10214 c----------------------------------------------------------------------------
10215       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10216       implicit real*8 (a-h,o-z)
10217       include 'DIMENSIONS'
10218       include 'COMMON.IOUNITS'
10219       include 'COMMON.CHAIN'
10220       include 'COMMON.DERIV'
10221       include 'COMMON.INTERACT'
10222       include 'COMMON.CONTACTS'
10223       include 'COMMON.TORSION'
10224       include 'COMMON.VAR'
10225       include 'COMMON.GEO'
10226       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10227       logical swap
10228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10229 C                                                                              C
10230 C      Parallel       Antiparallel                                             C
10231 C                                                                              C
10232 C          o             o                                                     C
10233 C         /l\   /   \   /j\                                                    C
10234 C        /   \ /     \ /   \                                                   C
10235 C       /| o |o       o| o |\                                                  C
10236 C       j|/k\|  /      |/k\|l /                                                C
10237 C        /   \ /       /   \ /                                                 C
10238 C       /     o       /     o                                                  C
10239 C       i             i                                                        C
10240 C                                                                              C
10241 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10242 C
10243 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10244 C           energy moment and not to the cluster cumulant.
10245       iti=itortyp(itype(i))
10246       if (j.lt.nres-1) then
10247         itj1=itortyp(itype(j+1))
10248       else
10249         itj1=ntortyp
10250       endif
10251       itk=itortyp(itype(k))
10252       itk1=itortyp(itype(k+1))
10253       if (l.lt.nres-1) then
10254         itl1=itortyp(itype(l+1))
10255       else
10256         itl1=ntortyp
10257       endif
10258 #ifdef MOMENT
10259       s1=dip(4,jj,i)*dip(4,kk,k)
10260 #endif
10261       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10262       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10263       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10264       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10265       call transpose2(EE(1,1,itk),auxmat(1,1))
10266       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10267       vv(1)=pizda(1,1)+pizda(2,2)
10268       vv(2)=pizda(2,1)-pizda(1,2)
10269       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10270 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10271 cd     & "sum",-(s2+s3+s4)
10272 #ifdef MOMENT
10273       eello6_graph3=-(s1+s2+s3+s4)
10274 #else
10275       eello6_graph3=-(s2+s3+s4)
10276 #endif
10277 c      eello6_graph3=-s4
10278 C Derivatives in gamma(k-1)
10279       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10280       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10281       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10282       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10283 C Derivatives in gamma(l-1)
10284       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10285       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10286       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10287       vv(1)=pizda(1,1)+pizda(2,2)
10288       vv(2)=pizda(2,1)-pizda(1,2)
10289       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10290       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10291 C Cartesian derivatives.
10292       do iii=1,2
10293         do kkk=1,5
10294           do lll=1,3
10295 #ifdef MOMENT
10296             if (iii.eq.1) then
10297               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10298             else
10299               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10300             endif
10301 #endif
10302             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10303      &        auxvec(1))
10304             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10305             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10306      &        auxvec(1))
10307             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10308             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10309      &        pizda(1,1))
10310             vv(1)=pizda(1,1)+pizda(2,2)
10311             vv(2)=pizda(2,1)-pizda(1,2)
10312             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10313 #ifdef MOMENT
10314             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10315 #else
10316             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10317 #endif
10318             if (swap) then
10319               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10320             else
10321               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10322             endif
10323 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10324           enddo
10325         enddo
10326       enddo
10327       return
10328       end
10329 c----------------------------------------------------------------------------
10330       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10331       implicit real*8 (a-h,o-z)
10332       include 'DIMENSIONS'
10333       include 'COMMON.IOUNITS'
10334       include 'COMMON.CHAIN'
10335       include 'COMMON.DERIV'
10336       include 'COMMON.INTERACT'
10337       include 'COMMON.CONTACTS'
10338       include 'COMMON.TORSION'
10339       include 'COMMON.VAR'
10340       include 'COMMON.GEO'
10341       include 'COMMON.FFIELD'
10342       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10343      & auxvec1(2),auxmat1(2,2)
10344       logical swap
10345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10346 C                                                                              C
10347 C      Parallel       Antiparallel                                             C
10348 C                                                                              C
10349 C          o             o                                                     C
10350 C         /l\   /   \   /j\                                                    C
10351 C        /   \ /     \ /   \                                                   C
10352 C       /| o |o       o| o |\                                                  C
10353 C     \ j|/k\|      \  |/k\|l                                                  C
10354 C      \ /   \       \ /   \                                                   C
10355 C       o     \       o     \                                                  C
10356 C       i             i                                                        C
10357 C                                                                              C
10358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10359 C
10360 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10361 C           energy moment and not to the cluster cumulant.
10362 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10363       iti=itortyp(itype(i))
10364       itj=itortyp(itype(j))
10365       if (j.lt.nres-1) then
10366         itj1=itortyp(itype(j+1))
10367       else
10368         itj1=ntortyp
10369       endif
10370       itk=itortyp(itype(k))
10371       if (k.lt.nres-1) then
10372         itk1=itortyp(itype(k+1))
10373       else
10374         itk1=ntortyp
10375       endif
10376       itl=itortyp(itype(l))
10377       if (l.lt.nres-1) then
10378         itl1=itortyp(itype(l+1))
10379       else
10380         itl1=ntortyp
10381       endif
10382 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10383 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10384 cd     & ' itl',itl,' itl1',itl1
10385 #ifdef MOMENT
10386       if (imat.eq.1) then
10387         s1=dip(3,jj,i)*dip(3,kk,k)
10388       else
10389         s1=dip(2,jj,j)*dip(2,kk,l)
10390       endif
10391 #endif
10392       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10393       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10394       if (j.eq.l+1) then
10395         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10396         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10397       else
10398         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10399         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10400       endif
10401       call transpose2(EUg(1,1,k),auxmat(1,1))
10402       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10403       vv(1)=pizda(1,1)-pizda(2,2)
10404       vv(2)=pizda(2,1)+pizda(1,2)
10405       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10406 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10407 #ifdef MOMENT
10408       eello6_graph4=-(s1+s2+s3+s4)
10409 #else
10410       eello6_graph4=-(s2+s3+s4)
10411 #endif
10412 C Derivatives in gamma(i-1)
10413       if (i.gt.1) then
10414 #ifdef MOMENT
10415         if (imat.eq.1) then
10416           s1=dipderg(2,jj,i)*dip(3,kk,k)
10417         else
10418           s1=dipderg(4,jj,j)*dip(2,kk,l)
10419         endif
10420 #endif
10421         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10422         if (j.eq.l+1) then
10423           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10424           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10425         else
10426           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10427           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10428         endif
10429         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10430         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10431 cd          write (2,*) 'turn6 derivatives'
10432 #ifdef MOMENT
10433           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10434 #else
10435           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10436 #endif
10437         else
10438 #ifdef MOMENT
10439           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10440 #else
10441           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10442 #endif
10443         endif
10444       endif
10445 C Derivatives in gamma(k-1)
10446 #ifdef MOMENT
10447       if (imat.eq.1) then
10448         s1=dip(3,jj,i)*dipderg(2,kk,k)
10449       else
10450         s1=dip(2,jj,j)*dipderg(4,kk,l)
10451       endif
10452 #endif
10453       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10454       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10455       if (j.eq.l+1) then
10456         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10457         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10458       else
10459         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10460         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10461       endif
10462       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10463       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10464       vv(1)=pizda(1,1)-pizda(2,2)
10465       vv(2)=pizda(2,1)+pizda(1,2)
10466       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10467       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10468 #ifdef MOMENT
10469         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10470 #else
10471         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10472 #endif
10473       else
10474 #ifdef MOMENT
10475         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10476 #else
10477         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10478 #endif
10479       endif
10480 C Derivatives in gamma(j-1) or gamma(l-1)
10481       if (l.eq.j+1 .and. l.gt.1) then
10482         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10483         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10484         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10485         vv(1)=pizda(1,1)-pizda(2,2)
10486         vv(2)=pizda(2,1)+pizda(1,2)
10487         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10488         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10489       else if (j.gt.1) then
10490         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10491         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10492         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10493         vv(1)=pizda(1,1)-pizda(2,2)
10494         vv(2)=pizda(2,1)+pizda(1,2)
10495         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10496         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10497           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10498         else
10499           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10500         endif
10501       endif
10502 C Cartesian derivatives.
10503       do iii=1,2
10504         do kkk=1,5
10505           do lll=1,3
10506 #ifdef MOMENT
10507             if (iii.eq.1) then
10508               if (imat.eq.1) then
10509                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10510               else
10511                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10512               endif
10513             else
10514               if (imat.eq.1) then
10515                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10516               else
10517                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10518               endif
10519             endif
10520 #endif
10521             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10522      &        auxvec(1))
10523             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10524             if (j.eq.l+1) then
10525               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10526      &          b1(1,j+1),auxvec(1))
10527               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10528             else
10529               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10530      &          b1(1,l+1),auxvec(1))
10531               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10532             endif
10533             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10534      &        pizda(1,1))
10535             vv(1)=pizda(1,1)-pizda(2,2)
10536             vv(2)=pizda(2,1)+pizda(1,2)
10537             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10538             if (swap) then
10539               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10540 #ifdef MOMENT
10541                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10542      &             -(s1+s2+s4)
10543 #else
10544                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10545      &             -(s2+s4)
10546 #endif
10547                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10548               else
10549 #ifdef MOMENT
10550                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10551 #else
10552                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10553 #endif
10554                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10555               endif
10556             else
10557 #ifdef MOMENT
10558               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10559 #else
10560               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10561 #endif
10562               if (l.eq.j+1) then
10563                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10564               else
10565                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10566               endif
10567             endif
10568           enddo
10569         enddo
10570       enddo
10571       return
10572       end
10573 c----------------------------------------------------------------------------
10574       double precision function eello_turn6(i,jj,kk)
10575       implicit real*8 (a-h,o-z)
10576       include 'DIMENSIONS'
10577       include 'COMMON.IOUNITS'
10578       include 'COMMON.CHAIN'
10579       include 'COMMON.DERIV'
10580       include 'COMMON.INTERACT'
10581       include 'COMMON.CONTACTS'
10582       include 'COMMON.TORSION'
10583       include 'COMMON.VAR'
10584       include 'COMMON.GEO'
10585       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10586      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10587      &  ggg1(3),ggg2(3)
10588       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10589      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10590 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10591 C           the respective energy moment and not to the cluster cumulant.
10592       s1=0.0d0
10593       s8=0.0d0
10594       s13=0.0d0
10595 c
10596       eello_turn6=0.0d0
10597       j=i+4
10598       k=i+1
10599       l=i+3
10600       iti=itortyp(itype(i))
10601       itk=itortyp(itype(k))
10602       itk1=itortyp(itype(k+1))
10603       itl=itortyp(itype(l))
10604       itj=itortyp(itype(j))
10605 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10606 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10607 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10608 cd        eello6=0.0d0
10609 cd        return
10610 cd      endif
10611 cd      write (iout,*)
10612 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10613 cd     &   ' and',k,l
10614 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10615       do iii=1,2
10616         do kkk=1,5
10617           do lll=1,3
10618             derx_turn(lll,kkk,iii)=0.0d0
10619           enddo
10620         enddo
10621       enddo
10622 cd      eij=1.0d0
10623 cd      ekl=1.0d0
10624 cd      ekont=1.0d0
10625       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10626 cd      eello6_5=0.0d0
10627 cd      write (2,*) 'eello6_5',eello6_5
10628 #ifdef MOMENT
10629       call transpose2(AEA(1,1,1),auxmat(1,1))
10630       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10631       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10632       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10633 #endif
10634       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10635       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10636       s2 = scalar2(b1(1,k),vtemp1(1))
10637 #ifdef MOMENT
10638       call transpose2(AEA(1,1,2),atemp(1,1))
10639       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10640       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10641       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10642 #endif
10643       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10644       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10645       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10646 #ifdef MOMENT
10647       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10648       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10649       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10650       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10651       ss13 = scalar2(b1(1,k),vtemp4(1))
10652       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10653 #endif
10654 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10655 c      s1=0.0d0
10656 c      s2=0.0d0
10657 c      s8=0.0d0
10658 c      s12=0.0d0
10659 c      s13=0.0d0
10660       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10661 C Derivatives in gamma(i+2)
10662       s1d =0.0d0
10663       s8d =0.0d0
10664 #ifdef MOMENT
10665       call transpose2(AEA(1,1,1),auxmatd(1,1))
10666       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10667       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10668       call transpose2(AEAderg(1,1,2),atempd(1,1))
10669       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10670       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10671 #endif
10672       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10673       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10674       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10675 c      s1d=0.0d0
10676 c      s2d=0.0d0
10677 c      s8d=0.0d0
10678 c      s12d=0.0d0
10679 c      s13d=0.0d0
10680       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10681 C Derivatives in gamma(i+3)
10682 #ifdef MOMENT
10683       call transpose2(AEA(1,1,1),auxmatd(1,1))
10684       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10685       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10686       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10687 #endif
10688       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10689       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10690       s2d = scalar2(b1(1,k),vtemp1d(1))
10691 #ifdef MOMENT
10692       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10693       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10694 #endif
10695       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10696 #ifdef MOMENT
10697       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10698       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10699       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10700 #endif
10701 c      s1d=0.0d0
10702 c      s2d=0.0d0
10703 c      s8d=0.0d0
10704 c      s12d=0.0d0
10705 c      s13d=0.0d0
10706 #ifdef MOMENT
10707       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10708      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10709 #else
10710       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10711      &               -0.5d0*ekont*(s2d+s12d)
10712 #endif
10713 C Derivatives in gamma(i+4)
10714       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10715       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10716       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10717 #ifdef MOMENT
10718       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10719       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10720       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10721 #endif
10722 c      s1d=0.0d0
10723 c      s2d=0.0d0
10724 c      s8d=0.0d0
10725 C      s12d=0.0d0
10726 c      s13d=0.0d0
10727 #ifdef MOMENT
10728       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10729 #else
10730       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10731 #endif
10732 C Derivatives in gamma(i+5)
10733 #ifdef MOMENT
10734       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10735       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10736       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10737 #endif
10738       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10739       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10740       s2d = scalar2(b1(1,k),vtemp1d(1))
10741 #ifdef MOMENT
10742       call transpose2(AEA(1,1,2),atempd(1,1))
10743       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10744       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10745 #endif
10746       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10747       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10748 #ifdef MOMENT
10749       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10750       ss13d = scalar2(b1(1,k),vtemp4d(1))
10751       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10752 #endif
10753 c      s1d=0.0d0
10754 c      s2d=0.0d0
10755 c      s8d=0.0d0
10756 c      s12d=0.0d0
10757 c      s13d=0.0d0
10758 #ifdef MOMENT
10759       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10760      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10761 #else
10762       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10763      &               -0.5d0*ekont*(s2d+s12d)
10764 #endif
10765 C Cartesian derivatives
10766       do iii=1,2
10767         do kkk=1,5
10768           do lll=1,3
10769 #ifdef MOMENT
10770             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10771             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10772             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10773 #endif
10774             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10775             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10776      &          vtemp1d(1))
10777             s2d = scalar2(b1(1,k),vtemp1d(1))
10778 #ifdef MOMENT
10779             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10780             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10781             s8d = -(atempd(1,1)+atempd(2,2))*
10782      &           scalar2(cc(1,1,itl),vtemp2(1))
10783 #endif
10784             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10785      &           auxmatd(1,1))
10786             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10787             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10788 c      s1d=0.0d0
10789 c      s2d=0.0d0
10790 c      s8d=0.0d0
10791 c      s12d=0.0d0
10792 c      s13d=0.0d0
10793 #ifdef MOMENT
10794             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10795      &        - 0.5d0*(s1d+s2d)
10796 #else
10797             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10798      &        - 0.5d0*s2d
10799 #endif
10800 #ifdef MOMENT
10801             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10802      &        - 0.5d0*(s8d+s12d)
10803 #else
10804             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10805      &        - 0.5d0*s12d
10806 #endif
10807           enddo
10808         enddo
10809       enddo
10810 #ifdef MOMENT
10811       do kkk=1,5
10812         do lll=1,3
10813           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10814      &      achuj_tempd(1,1))
10815           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10816           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10817           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10818           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10819           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10820      &      vtemp4d(1))
10821           ss13d = scalar2(b1(1,k),vtemp4d(1))
10822           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10823           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10824         enddo
10825       enddo
10826 #endif
10827 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10828 cd     &  16*eel_turn6_num
10829 cd      goto 1112
10830       if (j.lt.nres-1) then
10831         j1=j+1
10832         j2=j-1
10833       else
10834         j1=j-1
10835         j2=j-2
10836       endif
10837       if (l.lt.nres-1) then
10838         l1=l+1
10839         l2=l-1
10840       else
10841         l1=l-1
10842         l2=l-2
10843       endif
10844       do ll=1,3
10845 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10846 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10847 cgrad        ghalf=0.5d0*ggg1(ll)
10848 cd        ghalf=0.0d0
10849         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10850         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10851         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10852      &    +ekont*derx_turn(ll,2,1)
10853         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10854         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10855      &    +ekont*derx_turn(ll,4,1)
10856         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10857         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10858         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10859 cgrad        ghalf=0.5d0*ggg2(ll)
10860 cd        ghalf=0.0d0
10861         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10862      &    +ekont*derx_turn(ll,2,2)
10863         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10864         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10865      &    +ekont*derx_turn(ll,4,2)
10866         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10867         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10868         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10869       enddo
10870 cd      goto 1112
10871 cgrad      do m=i+1,j-1
10872 cgrad        do ll=1,3
10873 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10874 cgrad        enddo
10875 cgrad      enddo
10876 cgrad      do m=k+1,l-1
10877 cgrad        do ll=1,3
10878 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10879 cgrad        enddo
10880 cgrad      enddo
10881 cgrad1112  continue
10882 cgrad      do m=i+2,j2
10883 cgrad        do ll=1,3
10884 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10885 cgrad        enddo
10886 cgrad      enddo
10887 cgrad      do m=k+2,l2
10888 cgrad        do ll=1,3
10889 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10890 cgrad        enddo
10891 cgrad      enddo
10892 cd      do iii=1,nres-3
10893 cd        write (2,*) iii,g_corr6_loc(iii)
10894 cd      enddo
10895       eello_turn6=ekont*eel_turn6
10896 cd      write (2,*) 'ekont',ekont
10897 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10898       return
10899       end
10900
10901 C-----------------------------------------------------------------------------
10902       double precision function scalar(u,v)
10903 !DIR$ INLINEALWAYS scalar
10904 #ifndef OSF
10905 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10906 #endif
10907       implicit none
10908       double precision u(3),v(3)
10909 cd      double precision sc
10910 cd      integer i
10911 cd      sc=0.0d0
10912 cd      do i=1,3
10913 cd        sc=sc+u(i)*v(i)
10914 cd      enddo
10915 cd      scalar=sc
10916
10917       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10918       return
10919       end
10920 crc-------------------------------------------------
10921       SUBROUTINE MATVEC2(A1,V1,V2)
10922 !DIR$ INLINEALWAYS MATVEC2
10923 #ifndef OSF
10924 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10925 #endif
10926       implicit real*8 (a-h,o-z)
10927       include 'DIMENSIONS'
10928       DIMENSION A1(2,2),V1(2),V2(2)
10929 c      DO 1 I=1,2
10930 c        VI=0.0
10931 c        DO 3 K=1,2
10932 c    3     VI=VI+A1(I,K)*V1(K)
10933 c        Vaux(I)=VI
10934 c    1 CONTINUE
10935
10936       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10937       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10938
10939       v2(1)=vaux1
10940       v2(2)=vaux2
10941       END
10942 C---------------------------------------
10943       SUBROUTINE MATMAT2(A1,A2,A3)
10944 #ifndef OSF
10945 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10946 #endif
10947       implicit real*8 (a-h,o-z)
10948       include 'DIMENSIONS'
10949       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10950 c      DIMENSION AI3(2,2)
10951 c        DO  J=1,2
10952 c          A3IJ=0.0
10953 c          DO K=1,2
10954 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10955 c          enddo
10956 c          A3(I,J)=A3IJ
10957 c       enddo
10958 c      enddo
10959
10960       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10961       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10962       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10963       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10964
10965       A3(1,1)=AI3_11
10966       A3(2,1)=AI3_21
10967       A3(1,2)=AI3_12
10968       A3(2,2)=AI3_22
10969       END
10970
10971 c-------------------------------------------------------------------------
10972       double precision function scalar2(u,v)
10973 !DIR$ INLINEALWAYS scalar2
10974       implicit none
10975       double precision u(2),v(2)
10976       double precision sc
10977       integer i
10978       scalar2=u(1)*v(1)+u(2)*v(2)
10979       return
10980       end
10981
10982 C-----------------------------------------------------------------------------
10983
10984       subroutine transpose2(a,at)
10985 !DIR$ INLINEALWAYS transpose2
10986 #ifndef OSF
10987 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10988 #endif
10989       implicit none
10990       double precision a(2,2),at(2,2)
10991       at(1,1)=a(1,1)
10992       at(1,2)=a(2,1)
10993       at(2,1)=a(1,2)
10994       at(2,2)=a(2,2)
10995       return
10996       end
10997 c--------------------------------------------------------------------------
10998       subroutine transpose(n,a,at)
10999       implicit none
11000       integer n,i,j
11001       double precision a(n,n),at(n,n)
11002       do i=1,n
11003         do j=1,n
11004           at(j,i)=a(i,j)
11005         enddo
11006       enddo
11007       return
11008       end
11009 C---------------------------------------------------------------------------
11010       subroutine prodmat3(a1,a2,kk,transp,prod)
11011 !DIR$ INLINEALWAYS prodmat3
11012 #ifndef OSF
11013 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11014 #endif
11015       implicit none
11016       integer i,j
11017       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11018       logical transp
11019 crc      double precision auxmat(2,2),prod_(2,2)
11020
11021       if (transp) then
11022 crc        call transpose2(kk(1,1),auxmat(1,1))
11023 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11024 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11025
11026            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11027      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11028            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11029      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11030            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11031      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11032            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11033      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11034
11035       else
11036 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11037 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11038
11039            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11040      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11041            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11042      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11043            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11044      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11045            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11046      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11047
11048       endif
11049 c      call transpose2(a2(1,1),a2t(1,1))
11050
11051 crc      print *,transp
11052 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11053 crc      print *,((prod(i,j),i=1,2),j=1,2)
11054
11055       return
11056       end
11057 CCC----------------------------------------------
11058       subroutine Eliptransfer(eliptran)
11059       implicit real*8 (a-h,o-z)
11060       include 'DIMENSIONS'
11061       include 'COMMON.GEO'
11062       include 'COMMON.VAR'
11063       include 'COMMON.LOCAL'
11064       include 'COMMON.CHAIN'
11065       include 'COMMON.DERIV'
11066       include 'COMMON.NAMES'
11067       include 'COMMON.INTERACT'
11068       include 'COMMON.IOUNITS'
11069       include 'COMMON.CALC'
11070       include 'COMMON.CONTROL'
11071       include 'COMMON.SPLITELE'
11072       include 'COMMON.SBRIDGE'
11073 C this is done by Adasko
11074 C      print *,"wchodze"
11075 C structure of box:
11076 C      water
11077 C--bordliptop-- buffore starts
11078 C--bufliptop--- here true lipid starts
11079 C      lipid
11080 C--buflipbot--- lipid ends buffore starts
11081 C--bordlipbot--buffore ends
11082       eliptran=0.0
11083       do i=ilip_start,ilip_end
11084 C       do i=1,1
11085         if (itype(i).eq.ntyp1) cycle
11086
11087         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11088         if (positi.le.0) positi=positi+boxzsize
11089 C        print *,i
11090 C first for peptide groups
11091 c for each residue check if it is in lipid or lipid water border area
11092        if ((positi.gt.bordlipbot)
11093      &.and.(positi.lt.bordliptop)) then
11094 C the energy transfer exist
11095         if (positi.lt.buflipbot) then
11096 C what fraction I am in
11097          fracinbuf=1.0d0-
11098      &        ((positi-bordlipbot)/lipbufthick)
11099 C lipbufthick is thickenes of lipid buffore
11100          sslip=sscalelip(fracinbuf)
11101          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11102          eliptran=eliptran+sslip*pepliptran
11103          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11104          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11105 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11106
11107 C        print *,"doing sccale for lower part"
11108 C         print *,i,sslip,fracinbuf,ssgradlip
11109         elseif (positi.gt.bufliptop) then
11110          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11111          sslip=sscalelip(fracinbuf)
11112          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11113          eliptran=eliptran+sslip*pepliptran
11114          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11115          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11116 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11117 C          print *, "doing sscalefor top part"
11118 C         print *,i,sslip,fracinbuf,ssgradlip
11119         else
11120          eliptran=eliptran+pepliptran
11121 C         print *,"I am in true lipid"
11122         endif
11123 C       else
11124 C       eliptran=elpitran+0.0 ! I am in water
11125        endif
11126        enddo
11127 C       print *, "nic nie bylo w lipidzie?"
11128 C now multiply all by the peptide group transfer factor
11129 C       eliptran=eliptran*pepliptran
11130 C now the same for side chains
11131 CV       do i=1,1
11132        do i=ilip_start,ilip_end
11133         if (itype(i).eq.ntyp1) cycle
11134         positi=(mod(c(3,i+nres),boxzsize))
11135         if (positi.le.0) positi=positi+boxzsize
11136 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11137 c for each residue check if it is in lipid or lipid water border area
11138 C       respos=mod(c(3,i+nres),boxzsize)
11139 C       print *,positi,bordlipbot,buflipbot
11140        if ((positi.gt.bordlipbot)
11141      & .and.(positi.lt.bordliptop)) then
11142 C the energy transfer exist
11143         if (positi.lt.buflipbot) then
11144          fracinbuf=1.0d0-
11145      &     ((positi-bordlipbot)/lipbufthick)
11146 C lipbufthick is thickenes of lipid buffore
11147          sslip=sscalelip(fracinbuf)
11148          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11149          eliptran=eliptran+sslip*liptranene(itype(i))
11150          gliptranx(3,i)=gliptranx(3,i)
11151      &+ssgradlip*liptranene(itype(i))
11152          gliptranc(3,i-1)= gliptranc(3,i-1)
11153      &+ssgradlip*liptranene(itype(i))
11154 C         print *,"doing sccale for lower part"
11155         elseif (positi.gt.bufliptop) then
11156          fracinbuf=1.0d0-
11157      &((bordliptop-positi)/lipbufthick)
11158          sslip=sscalelip(fracinbuf)
11159          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11160          eliptran=eliptran+sslip*liptranene(itype(i))
11161          gliptranx(3,i)=gliptranx(3,i)
11162      &+ssgradlip*liptranene(itype(i))
11163          gliptranc(3,i-1)= gliptranc(3,i-1)
11164      &+ssgradlip*liptranene(itype(i))
11165 C          print *, "doing sscalefor top part",sslip,fracinbuf
11166         else
11167          eliptran=eliptran+liptranene(itype(i))
11168 C         print *,"I am in true lipid"
11169         endif
11170         endif ! if in lipid or buffor
11171 C       else
11172 C       eliptran=elpitran+0.0 ! I am in water
11173        enddo
11174        return
11175        end
11176 C---------------------------------------------------------
11177 C AFM soubroutine for constant force
11178        subroutine AFMforce(Eafmforce)
11179        implicit real*8 (a-h,o-z)
11180       include 'DIMENSIONS'
11181       include 'COMMON.GEO'
11182       include 'COMMON.VAR'
11183       include 'COMMON.LOCAL'
11184       include 'COMMON.CHAIN'
11185       include 'COMMON.DERIV'
11186       include 'COMMON.NAMES'
11187       include 'COMMON.INTERACT'
11188       include 'COMMON.IOUNITS'
11189       include 'COMMON.CALC'
11190       include 'COMMON.CONTROL'
11191       include 'COMMON.SPLITELE'
11192       include 'COMMON.SBRIDGE'
11193       real*8 diffafm(3)
11194       dist=0.0d0
11195       Eafmforce=0.0d0
11196       do i=1,3
11197       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11198       dist=dist+diffafm(i)**2
11199       enddo
11200       dist=dsqrt(dist)
11201       Eafmforce=-forceAFMconst*(dist-distafminit)
11202       do i=1,3
11203       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11204       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11205       enddo
11206 C      print *,'AFM',Eafmforce
11207       return
11208       end
11209 C---------------------------------------------------------
11210 C AFM subroutine with pseudoconstant velocity
11211        subroutine AFMvel(Eafmforce)
11212        implicit real*8 (a-h,o-z)
11213       include 'DIMENSIONS'
11214       include 'COMMON.GEO'
11215       include 'COMMON.VAR'
11216       include 'COMMON.LOCAL'
11217       include 'COMMON.CHAIN'
11218       include 'COMMON.DERIV'
11219       include 'COMMON.NAMES'
11220       include 'COMMON.INTERACT'
11221       include 'COMMON.IOUNITS'
11222       include 'COMMON.CALC'
11223       include 'COMMON.CONTROL'
11224       include 'COMMON.SPLITELE'
11225       include 'COMMON.SBRIDGE'
11226       real*8 diffafm(3)
11227 C Only for check grad COMMENT if not used for checkgrad
11228 C      totT=3.0d0
11229 C--------------------------------------------------------
11230 C      print *,"wchodze"
11231       dist=0.0d0
11232       Eafmforce=0.0d0
11233       do i=1,3
11234       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11235       dist=dist+diffafm(i)**2
11236       enddo
11237       dist=dsqrt(dist)
11238       Eafmforce=0.5d0*forceAFMconst
11239      & *(distafminit+totTafm*velAFMconst-dist)**2
11240 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11241       do i=1,3
11242       gradafm(i,afmend-1)=-forceAFMconst*
11243      &(distafminit+totTafm*velAFMconst-dist)
11244      &*diffafm(i)/dist
11245       gradafm(i,afmbeg-1)=forceAFMconst*
11246      &(distafminit+totTafm*velAFMconst-dist)
11247      &*diffafm(i)/dist
11248       enddo
11249 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11250       return
11251       end
11252 C-----------------------------------------------------------
11253 C first for shielding is setting of function of side-chains
11254        subroutine set_shield_fac
11255       implicit real*8 (a-h,o-z)
11256       include 'DIMENSIONS'
11257       include 'COMMON.CHAIN'
11258       include 'COMMON.DERIV'
11259       include 'COMMON.IOUNITS'
11260       include 'COMMON.SHIELD'
11261       include 'COMMON.INTERACT'
11262 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11263       double precision div77_81/0.974996043d0/,
11264      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11265
11266 C the vector between center of side_chain and peptide group
11267        double precision pep_side(3),long,side_calf(3),
11268      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11269      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11270 C the line belowe needs to be changed for FGPROC>1
11271       do i=1,nres-1
11272       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11273       ishield_list(i)=0
11274 Cif there two consequtive dummy atoms there is no peptide group between them
11275 C the line below has to be changed for FGPROC>1
11276       VolumeTotal=0.0
11277       do k=1,nres
11278        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11279        dist_pep_side=0.0
11280        dist_side_calf=0.0
11281        do j=1,3
11282 C first lets set vector conecting the ithe side-chain with kth side-chain
11283       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11284 C      pep_side(j)=2.0d0
11285 C and vector conecting the side-chain with its proper calfa
11286       side_calf(j)=c(j,k+nres)-c(j,k)
11287 C      side_calf(j)=2.0d0
11288       pept_group(j)=c(j,i)-c(j,i+1)
11289 C lets have their lenght
11290       dist_pep_side=pep_side(j)**2+dist_pep_side
11291       dist_side_calf=dist_side_calf+side_calf(j)**2
11292       dist_pept_group=dist_pept_group+pept_group(j)**2
11293       enddo
11294        dist_pep_side=dsqrt(dist_pep_side)
11295        dist_pept_group=dsqrt(dist_pept_group)
11296        dist_side_calf=dsqrt(dist_side_calf)
11297       do j=1,3
11298         pep_side_norm(j)=pep_side(j)/dist_pep_side
11299         side_calf_norm(j)=dist_side_calf
11300       enddo
11301 C now sscale fraction
11302        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11303 C       print *,buff_shield,"buff"
11304 C now sscale
11305         if (sh_frac_dist.le.0.0) cycle
11306 C If we reach here it means that this side chain reaches the shielding sphere
11307 C Lets add him to the list for gradient
11308         ishield_list(i)=ishield_list(i)+1
11309 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11310 C this list is essential otherwise problem would be O3
11311         shield_list(ishield_list(i),i)=k
11312 C Lets have the sscale value
11313         if (sh_frac_dist.gt.1.0) then
11314          scale_fac_dist=1.0d0
11315          do j=1,3
11316          sh_frac_dist_grad(j)=0.0d0
11317          enddo
11318         else
11319          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11320      &                   *(2.0*sh_frac_dist-3.0d0)
11321          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11322      &                  /dist_pep_side/buff_shield*0.5
11323 C remember for the final gradient multiply sh_frac_dist_grad(j)
11324 C for side_chain by factor -2 !
11325          do j=1,3
11326          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11327 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11328 C     &                    sh_frac_dist_grad(j)
11329          enddo
11330         endif
11331 C        if ((i.eq.3).and.(k.eq.2)) then
11332 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11333 C     & ,"TU"
11334 C        endif
11335
11336 C this is what is now we have the distance scaling now volume...
11337       short=short_r_sidechain(itype(k))
11338       long=long_r_sidechain(itype(k))
11339       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11340 C now costhet_grad
11341 C       costhet=0.0d0
11342        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11343 C       costhet_fac=0.0d0
11344        do j=1,3
11345          costhet_grad(j)=costhet_fac*pep_side(j)
11346        enddo
11347 C remember for the final gradient multiply costhet_grad(j)
11348 C for side_chain by factor -2 !
11349 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11350 C pep_side0pept_group is vector multiplication
11351       pep_side0pept_group=0.0
11352       do j=1,3
11353       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11354       enddo
11355       cosalfa=(pep_side0pept_group/
11356      & (dist_pep_side*dist_side_calf))
11357       fac_alfa_sin=1.0-cosalfa**2
11358       fac_alfa_sin=dsqrt(fac_alfa_sin)
11359       rkprim=fac_alfa_sin*(long-short)+short
11360 C now costhet_grad
11361        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11362        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11363
11364        do j=1,3
11365          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11366      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11367      &*(long-short)/fac_alfa_sin*cosalfa/
11368      &((dist_pep_side*dist_side_calf))*
11369      &((side_calf(j))-cosalfa*
11370      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11371
11372         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11373      &*(long-short)/fac_alfa_sin*cosalfa
11374      &/((dist_pep_side*dist_side_calf))*
11375      &(pep_side(j)-
11376      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11377        enddo
11378
11379       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11380      &                    /VSolvSphere_div
11381      &                    *wshield
11382 C now the gradient...
11383 C grad_shield is gradient of Calfa for peptide groups
11384 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11385 C     &               costhet,cosphi
11386 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11387 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11388       do j=1,3
11389       grad_shield(j,i)=grad_shield(j,i)
11390 C gradient po skalowaniu
11391      &                +(sh_frac_dist_grad(j)
11392 C  gradient po costhet
11393      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11394      &-scale_fac_dist*(cosphi_grad_long(j))
11395      &/(1.0-cosphi) )*div77_81
11396      &*VofOverlap
11397 C grad_shield_side is Cbeta sidechain gradient
11398       grad_shield_side(j,ishield_list(i),i)=
11399      &        (sh_frac_dist_grad(j)*-2.0d0
11400      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11401      &       +scale_fac_dist*(cosphi_grad_long(j))
11402      &        *2.0d0/(1.0-cosphi))
11403      &        *div77_81*VofOverlap
11404
11405        grad_shield_loc(j,ishield_list(i),i)=
11406      &   scale_fac_dist*cosphi_grad_loc(j)
11407      &        *2.0d0/(1.0-cosphi)
11408      &        *div77_81*VofOverlap
11409       enddo
11410       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11411       enddo
11412       fac_shield(i)=VolumeTotal*div77_81+div4_81
11413 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11414       enddo
11415       return
11416       end
11417 C--------------------------------------------------------------------------
11418       double precision function tschebyshev(m,n,x,y)
11419       implicit none
11420       include "DIMENSIONS"
11421       integer i,m,n
11422       double precision x(n),y,yy(0:maxvar),aux
11423 c Tschebyshev polynomial. Note that the first term is omitted
11424 c m=0: the constant term is included
11425 c m=1: the constant term is not included
11426       yy(0)=1.0d0
11427       yy(1)=y
11428       do i=2,n
11429         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11430       enddo
11431       aux=0.0d0
11432       do i=m,n
11433         aux=aux+x(i)*yy(i)
11434       enddo
11435       tschebyshev=aux
11436       return
11437       end
11438 C--------------------------------------------------------------------------
11439       double precision function gradtschebyshev(m,n,x,y)
11440       implicit none
11441       include "DIMENSIONS"
11442       integer i,m,n
11443       double precision x(n+1),y,yy(0:maxvar),aux
11444 c Tschebyshev polynomial. Note that the first term is omitted
11445 c m=0: the constant term is included
11446 c m=1: the constant term is not included
11447       yy(0)=1.0d0
11448       yy(1)=2.0d0*y
11449       do i=2,n
11450         yy(i)=2*y*yy(i-1)-yy(i-2)
11451       enddo
11452       aux=0.0d0
11453       do i=m,n
11454         aux=aux+x(i+1)*yy(i)*(i+1)
11455 C        print *, x(i+1),yy(i),i
11456       enddo
11457       gradtschebyshev=aux
11458       return
11459       end
11460 C------------------------------------------------------------------------
11461 C first for shielding is setting of function of side-chains
11462        subroutine set_shield_fac2
11463       implicit real*8 (a-h,o-z)
11464       include 'DIMENSIONS'
11465       include 'COMMON.CHAIN'
11466       include 'COMMON.DERIV'
11467       include 'COMMON.IOUNITS'
11468       include 'COMMON.SHIELD'
11469       include 'COMMON.INTERACT'
11470 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11471       double precision div77_81/0.974996043d0/,
11472      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11473
11474 C the vector between center of side_chain and peptide group
11475        double precision pep_side(3),long,side_calf(3),
11476      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11477      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11478 C the line belowe needs to be changed for FGPROC>1
11479       do i=1,nres-1
11480       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11481       ishield_list(i)=0
11482 Cif there two consequtive dummy atoms there is no peptide group between them
11483 C the line below has to be changed for FGPROC>1
11484       VolumeTotal=0.0
11485       do k=1,nres
11486        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11487        dist_pep_side=0.0
11488        dist_side_calf=0.0
11489        do j=1,3
11490 C first lets set vector conecting the ithe side-chain with kth side-chain
11491       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11492 C      pep_side(j)=2.0d0
11493 C and vector conecting the side-chain with its proper calfa
11494       side_calf(j)=c(j,k+nres)-c(j,k)
11495 C      side_calf(j)=2.0d0
11496       pept_group(j)=c(j,i)-c(j,i+1)
11497 C lets have their lenght
11498       dist_pep_side=pep_side(j)**2+dist_pep_side
11499       dist_side_calf=dist_side_calf+side_calf(j)**2
11500       dist_pept_group=dist_pept_group+pept_group(j)**2
11501       enddo
11502        dist_pep_side=dsqrt(dist_pep_side)
11503        dist_pept_group=dsqrt(dist_pept_group)
11504        dist_side_calf=dsqrt(dist_side_calf)
11505       do j=1,3
11506         pep_side_norm(j)=pep_side(j)/dist_pep_side
11507         side_calf_norm(j)=dist_side_calf
11508       enddo
11509 C now sscale fraction
11510        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11511 C       print *,buff_shield,"buff"
11512 C now sscale
11513         if (sh_frac_dist.le.0.0) cycle
11514 C If we reach here it means that this side chain reaches the shielding sphere
11515 C Lets add him to the list for gradient
11516         ishield_list(i)=ishield_list(i)+1
11517 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11518 C this list is essential otherwise problem would be O3
11519         shield_list(ishield_list(i),i)=k
11520 C Lets have the sscale value
11521         if (sh_frac_dist.gt.1.0) then
11522          scale_fac_dist=1.0d0
11523          do j=1,3
11524          sh_frac_dist_grad(j)=0.0d0
11525          enddo
11526         else
11527          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11528      &                   *(2.0d0*sh_frac_dist-3.0d0)
11529          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11530      &                  /dist_pep_side/buff_shield*0.5d0
11531 C remember for the final gradient multiply sh_frac_dist_grad(j)
11532 C for side_chain by factor -2 !
11533          do j=1,3
11534          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11535 C         sh_frac_dist_grad(j)=0.0d0
11536 C         scale_fac_dist=1.0d0
11537 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11538 C     &                    sh_frac_dist_grad(j)
11539          enddo
11540         endif
11541 C this is what is now we have the distance scaling now volume...
11542       short=short_r_sidechain(itype(k))
11543       long=long_r_sidechain(itype(k))
11544       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11545       sinthet=short/dist_pep_side*costhet
11546 C now costhet_grad
11547 C       costhet=0.6d0
11548 C       sinthet=0.8
11549        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11550 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11551 C     &             -short/dist_pep_side**2/costhet)
11552 C       costhet_fac=0.0d0
11553        do j=1,3
11554          costhet_grad(j)=costhet_fac*pep_side(j)
11555        enddo
11556 C remember for the final gradient multiply costhet_grad(j)
11557 C for side_chain by factor -2 !
11558 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11559 C pep_side0pept_group is vector multiplication
11560       pep_side0pept_group=0.0d0
11561       do j=1,3
11562       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11563       enddo
11564       cosalfa=(pep_side0pept_group/
11565      & (dist_pep_side*dist_side_calf))
11566       fac_alfa_sin=1.0d0-cosalfa**2
11567       fac_alfa_sin=dsqrt(fac_alfa_sin)
11568       rkprim=fac_alfa_sin*(long-short)+short
11569 C      rkprim=short
11570
11571 C now costhet_grad
11572        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11573 C       cosphi=0.6
11574        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11575        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11576      &      dist_pep_side**2)
11577 C       sinphi=0.8
11578        do j=1,3
11579          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11580      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11581      &*(long-short)/fac_alfa_sin*cosalfa/
11582      &((dist_pep_side*dist_side_calf))*
11583      &((side_calf(j))-cosalfa*
11584      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11585 C       cosphi_grad_long(j)=0.0d0
11586         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11587      &*(long-short)/fac_alfa_sin*cosalfa
11588      &/((dist_pep_side*dist_side_calf))*
11589      &(pep_side(j)-
11590      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11591 C       cosphi_grad_loc(j)=0.0d0
11592        enddo
11593 C      print *,sinphi,sinthet
11594       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11595      &                    /VSolvSphere_div
11596 C     &                    *wshield
11597 C now the gradient...
11598       do j=1,3
11599       grad_shield(j,i)=grad_shield(j,i)
11600 C gradient po skalowaniu
11601      &                +(sh_frac_dist_grad(j)*VofOverlap
11602 C  gradient po costhet
11603      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11604      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11605      &       sinphi/sinthet*costhet*costhet_grad(j)
11606      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11607      & )*wshield
11608 C grad_shield_side is Cbeta sidechain gradient
11609       grad_shield_side(j,ishield_list(i),i)=
11610      &        (sh_frac_dist_grad(j)*-2.0d0
11611      &        *VofOverlap
11612      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11613      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11614      &       sinphi/sinthet*costhet*costhet_grad(j)
11615      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11616      &       )*wshield
11617
11618        grad_shield_loc(j,ishield_list(i),i)=
11619      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11620      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11621      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11622      &        ))
11623      &        *wshield
11624       enddo
11625       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11626       enddo
11627       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11628 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11629       enddo
11630       return
11631       end
11632