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 = itype2loc(itype(i-2))
2787         else
2788           iti=nloctyp
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 = itype2loc(itype(i-1))
2793         else
2794           iti1=nloctyp
2795         endif
2796 c        write(iout,*),i
2797         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2798      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2799      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
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.0d0)
2806      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2807      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
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 = itype2loc(itype(i-2))
2847         else
2848           iti=nloctyp
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 = itype2loc(itype(i-1))
2853         else
2854           iti1=nloctyp
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 = itype2loc(itype(i-2))
2944         else
2945           iti=nloctyp
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 = itype2loc(itype(i-1))
2950         else
2951           iti1=nloctyp
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,i),EE(2,1,i),
2965 c     &    EE(1,2,iti),EE(2,2,i)
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 = itype2loc(itype(i-1))
3001           else
3002             iti1=nloctyp
3003           endif
3004         else
3005           iti1=nloctyp
3006         endif
3007         do k=1,2
3008           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3009         enddo
3010 #ifdef MUOUT
3011         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3012      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3013      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3014      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3015      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3016      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3017 #endif
3018 cd        write (iout,*) 'mu1',mu1(:,i-2)
3019 cd        write (iout,*) 'mu2',mu2(:,i-2)
3020         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3021      &  then
3022         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3023         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3024         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3025         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3026         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3027 C Vectors and matrices dependent on a single virtual-bond dihedral.
3028         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3029         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3030         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3031         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3032         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3033         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3034         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3035         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3036         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3037         endif
3038       enddo
3039 C Matrices dependent on two consecutive virtual-bond dihedrals.
3040 C The order of matrices is from left to right.
3041       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3042      &then
3043 c      do i=max0(ivec_start,2),ivec_end
3044       do i=2,nres-1
3045         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3046         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3047         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3048         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3049         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3050         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3051         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3052         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3053       enddo
3054       endif
3055 #if defined(MPI) && defined(PARMAT)
3056 #ifdef DEBUG
3057 c      if (fg_rank.eq.0) then
3058         write (iout,*) "Arrays UG and UGDER before GATHER"
3059         do i=1,nres-1
3060           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3061      &     ((ug(l,k,i),l=1,2),k=1,2),
3062      &     ((ugder(l,k,i),l=1,2),k=1,2)
3063         enddo
3064         write (iout,*) "Arrays UG2 and UG2DER"
3065         do i=1,nres-1
3066           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3067      &     ((ug2(l,k,i),l=1,2),k=1,2),
3068      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3069         enddo
3070         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3071         do i=1,nres-1
3072           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3073      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3074      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3075         enddo
3076         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3077         do i=1,nres-1
3078           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3079      &     costab(i),sintab(i),costab2(i),sintab2(i)
3080         enddo
3081         write (iout,*) "Array MUDER"
3082         do i=1,nres-1
3083           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3084         enddo
3085 c      endif
3086 #endif
3087       if (nfgtasks.gt.1) then
3088         time00=MPI_Wtime()
3089 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3090 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3091 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3092 #ifdef MATGATHER
3093         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3094      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3095      &   FG_COMM1,IERR)
3096         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3097      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3098      &   FG_COMM1,IERR)
3099         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3100      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3101      &   FG_COMM1,IERR)
3102         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3103      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3104      &   FG_COMM1,IERR)
3105         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3106      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3107      &   FG_COMM1,IERR)
3108         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3109      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3110      &   FG_COMM1,IERR)
3111         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3112      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3113      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3114         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3115      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3116      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3117         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3118      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3119      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3120         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3121      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3122      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3123         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3124      &  then
3125         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3126      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3127      &   FG_COMM1,IERR)
3128         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3129      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3130      &   FG_COMM1,IERR)
3131         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3132      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3133      &   FG_COMM1,IERR)
3134        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3135      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3136      &   FG_COMM1,IERR)
3137         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3138      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3139      &   FG_COMM1,IERR)
3140         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3141      &   ivec_count(fg_rank1),
3142      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3143      &   FG_COMM1,IERR)
3144         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3145      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3146      &   FG_COMM1,IERR)
3147         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3148      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3149      &   FG_COMM1,IERR)
3150         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3151      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3152      &   FG_COMM1,IERR)
3153         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3154      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3155      &   FG_COMM1,IERR)
3156         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3157      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3158      &   FG_COMM1,IERR)
3159         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3160      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3161      &   FG_COMM1,IERR)
3162         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3163      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3164      &   FG_COMM1,IERR)
3165         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3166      &   ivec_count(fg_rank1),
3167      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3168      &   FG_COMM1,IERR)
3169         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3170      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3171      &   FG_COMM1,IERR)
3172        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3173      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3174      &   FG_COMM1,IERR)
3175         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3176      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3177      &   FG_COMM1,IERR)
3178        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3179      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3180      &   FG_COMM1,IERR)
3181         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3182      &   ivec_count(fg_rank1),
3183      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3184      &   FG_COMM1,IERR)
3185         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3186      &   ivec_count(fg_rank1),
3187      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3188      &   FG_COMM1,IERR)
3189         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3190      &   ivec_count(fg_rank1),
3191      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3192      &   MPI_MAT2,FG_COMM1,IERR)
3193         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3194      &   ivec_count(fg_rank1),
3195      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3196      &   MPI_MAT2,FG_COMM1,IERR)
3197         endif
3198 #else
3199 c Passes matrix info through the ring
3200       isend=fg_rank1
3201       irecv=fg_rank1-1
3202       if (irecv.lt.0) irecv=nfgtasks1-1
3203       iprev=irecv
3204       inext=fg_rank1+1
3205       if (inext.ge.nfgtasks1) inext=0
3206       do i=1,nfgtasks1-1
3207 c        write (iout,*) "isend",isend," irecv",irecv
3208 c        call flush(iout)
3209         lensend=lentyp(isend)
3210         lenrecv=lentyp(irecv)
3211 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3212 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3213 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3214 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3215 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3216 c        write (iout,*) "Gather ROTAT1"
3217 c        call flush(iout)
3218 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3219 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3220 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3221 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3222 c        write (iout,*) "Gather ROTAT2"
3223 c        call flush(iout)
3224         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3225      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3226      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3227      &   iprev,4400+irecv,FG_COMM,status,IERR)
3228 c        write (iout,*) "Gather ROTAT_OLD"
3229 c        call flush(iout)
3230         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3231      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3232      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3233      &   iprev,5500+irecv,FG_COMM,status,IERR)
3234 c        write (iout,*) "Gather PRECOMP11"
3235 c        call flush(iout)
3236         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3237      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3238      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3239      &   iprev,6600+irecv,FG_COMM,status,IERR)
3240 c        write (iout,*) "Gather PRECOMP12"
3241 c        call flush(iout)
3242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3243      &  then
3244         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3245      &   MPI_ROTAT2(lensend),inext,7700+isend,
3246      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3247      &   iprev,7700+irecv,FG_COMM,status,IERR)
3248 c        write (iout,*) "Gather PRECOMP21"
3249 c        call flush(iout)
3250         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3251      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3252      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3253      &   iprev,8800+irecv,FG_COMM,status,IERR)
3254 c        write (iout,*) "Gather PRECOMP22"
3255 c        call flush(iout)
3256         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3257      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3258      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3259      &   MPI_PRECOMP23(lenrecv),
3260      &   iprev,9900+irecv,FG_COMM,status,IERR)
3261 c        write (iout,*) "Gather PRECOMP23"
3262 c        call flush(iout)
3263         endif
3264         isend=irecv
3265         irecv=irecv-1
3266         if (irecv.lt.0) irecv=nfgtasks1-1
3267       enddo
3268 #endif
3269         time_gather=time_gather+MPI_Wtime()-time00
3270       endif
3271 #ifdef DEBUG
3272 c      if (fg_rank.eq.0) then
3273         write (iout,*) "Arrays UG and UGDER"
3274         do i=1,nres-1
3275           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3276      &     ((ug(l,k,i),l=1,2),k=1,2),
3277      &     ((ugder(l,k,i),l=1,2),k=1,2)
3278         enddo
3279         write (iout,*) "Arrays UG2 and UG2DER"
3280         do i=1,nres-1
3281           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3282      &     ((ug2(l,k,i),l=1,2),k=1,2),
3283      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3284         enddo
3285         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3288      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3289      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3290         enddo
3291         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     costab(i),sintab(i),costab2(i),sintab2(i)
3295         enddo
3296         write (iout,*) "Array MUDER"
3297         do i=1,nres-1
3298           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3299         enddo
3300 c      endif
3301 #endif
3302 #endif
3303 cd      do i=1,nres
3304 cd        iti = itype2loc(itype(i))
3305 cd        write (iout,*) i
3306 cd        do j=1,2
3307 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3308 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3309 cd        enddo
3310 cd      enddo
3311       return
3312       end
3313 C--------------------------------------------------------------------------
3314       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3315 C
3316 C This subroutine calculates the average interaction energy and its gradient
3317 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3318 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3319 C The potential depends both on the distance of peptide-group centers and on
3320 C the orientation of the CA-CA virtual bonds.
3321 C
3322       implicit real*8 (a-h,o-z)
3323 #ifdef MPI
3324       include 'mpif.h'
3325 #endif
3326       include 'DIMENSIONS'
3327       include 'COMMON.CONTROL'
3328       include 'COMMON.SETUP'
3329       include 'COMMON.IOUNITS'
3330       include 'COMMON.GEO'
3331       include 'COMMON.VAR'
3332       include 'COMMON.LOCAL'
3333       include 'COMMON.CHAIN'
3334       include 'COMMON.DERIV'
3335       include 'COMMON.INTERACT'
3336       include 'COMMON.CONTACTS'
3337       include 'COMMON.TORSION'
3338       include 'COMMON.VECTORS'
3339       include 'COMMON.FFIELD'
3340       include 'COMMON.TIME1'
3341       include 'COMMON.SPLITELE'
3342       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3343      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3344       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3345      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3346       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3347      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3348      &    num_conti,j1,j2
3349 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3350 #ifdef MOMENT
3351       double precision scal_el /1.0d0/
3352 #else
3353       double precision scal_el /0.5d0/
3354 #endif
3355 C 12/13/98
3356 C 13-go grudnia roku pamietnego...
3357       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3358      &                   0.0d0,1.0d0,0.0d0,
3359      &                   0.0d0,0.0d0,1.0d0/
3360 cd      write(iout,*) 'In EELEC'
3361 cd      do i=1,nloctyp
3362 cd        write(iout,*) 'Type',i
3363 cd        write(iout,*) 'B1',B1(:,i)
3364 cd        write(iout,*) 'B2',B2(:,i)
3365 cd        write(iout,*) 'CC',CC(:,:,i)
3366 cd        write(iout,*) 'DD',DD(:,:,i)
3367 cd        write(iout,*) 'EE',EE(:,:,i)
3368 cd      enddo
3369 cd      call check_vecgrad
3370 cd      stop
3371       if (icheckgrad.eq.1) then
3372         do i=1,nres-1
3373           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3374           do k=1,3
3375             dc_norm(k,i)=dc(k,i)*fac
3376           enddo
3377 c          write (iout,*) 'i',i,' fac',fac
3378         enddo
3379       endif
3380       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3381      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3382      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3383 c        call vec_and_deriv
3384 #ifdef TIMING
3385         time01=MPI_Wtime()
3386 #endif
3387         call set_matrices
3388 #ifdef TIMING
3389         time_mat=time_mat+MPI_Wtime()-time01
3390 #endif
3391       endif
3392 cd      do i=1,nres-1
3393 cd        write (iout,*) 'i=',i
3394 cd        do k=1,3
3395 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3396 cd        enddo
3397 cd        do k=1,3
3398 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3399 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3400 cd        enddo
3401 cd      enddo
3402       t_eelecij=0.0d0
3403       ees=0.0D0
3404       evdw1=0.0D0
3405       eel_loc=0.0d0
3406       eello_turn3=0.0d0
3407       eello_turn4=0.0d0
3408       ind=0
3409       do i=1,nres
3410         num_cont_hb(i)=0
3411       enddo
3412 cd      print '(a)','Enter EELEC'
3413 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3414       do i=1,nres
3415         gel_loc_loc(i)=0.0d0
3416         gcorr_loc(i)=0.0d0
3417       enddo
3418 c
3419 c
3420 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3421 C
3422 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3423 C
3424 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3425       do i=iturn3_start,iturn3_end
3426 c        if (i.le.1) cycle
3427 C        write(iout,*) "tu jest i",i
3428         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3429 C changes suggested by Ana to avoid out of bounds
3430 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3431 c     & .or.((i+4).gt.nres)
3432 c     & .or.((i-1).le.0)
3433 C end of changes by Ana
3434      &  .or. itype(i+2).eq.ntyp1
3435      &  .or. itype(i+3).eq.ntyp1) cycle
3436 C Adam: Instructions below will switch off existing interactions
3437 c        if(i.gt.1)then
3438 c          if(itype(i-1).eq.ntyp1)cycle
3439 c        end if
3440 c        if(i.LT.nres-3)then
3441 c          if (itype(i+4).eq.ntyp1) cycle
3442 c        end if
3443         dxi=dc(1,i)
3444         dyi=dc(2,i)
3445         dzi=dc(3,i)
3446         dx_normi=dc_norm(1,i)
3447         dy_normi=dc_norm(2,i)
3448         dz_normi=dc_norm(3,i)
3449         xmedi=c(1,i)+0.5d0*dxi
3450         ymedi=c(2,i)+0.5d0*dyi
3451         zmedi=c(3,i)+0.5d0*dzi
3452           xmedi=mod(xmedi,boxxsize)
3453           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3454           ymedi=mod(ymedi,boxysize)
3455           if (ymedi.lt.0) ymedi=ymedi+boxysize
3456           zmedi=mod(zmedi,boxzsize)
3457           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3458         num_conti=0
3459         call eelecij(i,i+2,ees,evdw1,eel_loc)
3460         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3461         num_cont_hb(i)=num_conti
3462       enddo
3463       do i=iturn4_start,iturn4_end
3464         if (i.le.1) cycle
3465         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3466 C changes suggested by Ana to avoid out of bounds
3467 c     & .or.((i+5).gt.nres)
3468 c     & .or.((i-1).le.0)
3469 C end of changes suggested by Ana
3470      &    .or. itype(i+3).eq.ntyp1
3471      &    .or. itype(i+4).eq.ntyp1
3472 c     &    .or. itype(i+5).eq.ntyp1
3473 c     &    .or. itype(i).eq.ntyp1
3474 c     &    .or. itype(i-1).eq.ntyp1
3475      &                             ) cycle
3476         dxi=dc(1,i)
3477         dyi=dc(2,i)
3478         dzi=dc(3,i)
3479         dx_normi=dc_norm(1,i)
3480         dy_normi=dc_norm(2,i)
3481         dz_normi=dc_norm(3,i)
3482         xmedi=c(1,i)+0.5d0*dxi
3483         ymedi=c(2,i)+0.5d0*dyi
3484         zmedi=c(3,i)+0.5d0*dzi
3485 C Return atom into box, boxxsize is size of box in x dimension
3486 c  194   continue
3487 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3488 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3489 C Condition for being inside the proper box
3490 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3491 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3492 c        go to 194
3493 c        endif
3494 c  195   continue
3495 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3496 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3497 C Condition for being inside the proper box
3498 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3499 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3500 c        go to 195
3501 c        endif
3502 c  196   continue
3503 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3504 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3505 C Condition for being inside the proper box
3506 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3507 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3508 c        go to 196
3509 c        endif
3510           xmedi=mod(xmedi,boxxsize)
3511           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3512           ymedi=mod(ymedi,boxysize)
3513           if (ymedi.lt.0) ymedi=ymedi+boxysize
3514           zmedi=mod(zmedi,boxzsize)
3515           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3516
3517         num_conti=num_cont_hb(i)
3518 c        write(iout,*) "JESTEM W PETLI"
3519         call eelecij(i,i+3,ees,evdw1,eel_loc)
3520         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3521      &   call eturn4(i,eello_turn4)
3522         num_cont_hb(i)=num_conti
3523       enddo   ! i
3524 C Loop over all neighbouring boxes
3525 C      do xshift=-1,1
3526 C      do yshift=-1,1
3527 C      do zshift=-1,1
3528 c
3529 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3530 c
3531 CTU KURWA
3532       do i=iatel_s,iatel_e
3533 C        do i=75,75
3534 c        if (i.le.1) cycle
3535         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3536 C changes suggested by Ana to avoid out of bounds
3537 c     & .or.((i+2).gt.nres)
3538 c     & .or.((i-1).le.0)
3539 C end of changes by Ana
3540 c     &  .or. itype(i+2).eq.ntyp1
3541 c     &  .or. itype(i-1).eq.ntyp1
3542      &                ) cycle
3543         dxi=dc(1,i)
3544         dyi=dc(2,i)
3545         dzi=dc(3,i)
3546         dx_normi=dc_norm(1,i)
3547         dy_normi=dc_norm(2,i)
3548         dz_normi=dc_norm(3,i)
3549         xmedi=c(1,i)+0.5d0*dxi
3550         ymedi=c(2,i)+0.5d0*dyi
3551         zmedi=c(3,i)+0.5d0*dzi
3552           xmedi=mod(xmedi,boxxsize)
3553           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3554           ymedi=mod(ymedi,boxysize)
3555           if (ymedi.lt.0) ymedi=ymedi+boxysize
3556           zmedi=mod(zmedi,boxzsize)
3557           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3558 C          xmedi=xmedi+xshift*boxxsize
3559 C          ymedi=ymedi+yshift*boxysize
3560 C          zmedi=zmedi+zshift*boxzsize
3561
3562 C Return tom into box, boxxsize is size of box in x dimension
3563 c  164   continue
3564 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3565 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3566 C Condition for being inside the proper box
3567 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3568 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3569 c        go to 164
3570 c        endif
3571 c  165   continue
3572 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3573 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3574 C Condition for being inside the proper box
3575 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3576 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3577 c        go to 165
3578 c        endif
3579 c  166   continue
3580 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3581 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3582 cC Condition for being inside the proper box
3583 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3584 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3585 c        go to 166
3586 c        endif
3587
3588 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3589         num_conti=num_cont_hb(i)
3590 C I TU KURWA
3591         do j=ielstart(i),ielend(i)
3592 C          do j=16,17
3593 C          write (iout,*) i,j
3594          if (j.le.1) cycle
3595           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3596 C changes suggested by Ana to avoid out of bounds
3597 c     & .or.((j+2).gt.nres)
3598 c     & .or.((j-1).le.0)
3599 C end of changes by Ana
3600 c     & .or.itype(j+2).eq.ntyp1
3601 c     & .or.itype(j-1).eq.ntyp1
3602      &) cycle
3603           call eelecij(i,j,ees,evdw1,eel_loc)
3604         enddo ! j
3605         num_cont_hb(i)=num_conti
3606       enddo   ! i
3607 C     enddo   ! zshift
3608 C      enddo   ! yshift
3609 C      enddo   ! xshift
3610
3611 c      write (iout,*) "Number of loop steps in EELEC:",ind
3612 cd      do i=1,nres
3613 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3614 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3615 cd      enddo
3616 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3617 ccc      eel_loc=eel_loc+eello_turn3
3618 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3619       return
3620       end
3621 C-------------------------------------------------------------------------------
3622       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3623       implicit real*8 (a-h,o-z)
3624       include 'DIMENSIONS'
3625 #ifdef MPI
3626       include "mpif.h"
3627 #endif
3628       include 'COMMON.CONTROL'
3629       include 'COMMON.IOUNITS'
3630       include 'COMMON.GEO'
3631       include 'COMMON.VAR'
3632       include 'COMMON.LOCAL'
3633       include 'COMMON.CHAIN'
3634       include 'COMMON.DERIV'
3635       include 'COMMON.INTERACT'
3636       include 'COMMON.CONTACTS'
3637       include 'COMMON.TORSION'
3638       include 'COMMON.VECTORS'
3639       include 'COMMON.FFIELD'
3640       include 'COMMON.TIME1'
3641       include 'COMMON.SPLITELE'
3642       include 'COMMON.SHIELD'
3643       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3644      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3645       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3646      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3647      &    gmuij2(4),gmuji2(4)
3648       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3649      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3650      &    num_conti,j1,j2
3651 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3652 #ifdef MOMENT
3653       double precision scal_el /1.0d0/
3654 #else
3655       double precision scal_el /0.5d0/
3656 #endif
3657 C 12/13/98
3658 C 13-go grudnia roku pamietnego...
3659       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3660      &                   0.0d0,1.0d0,0.0d0,
3661      &                   0.0d0,0.0d0,1.0d0/
3662 c          time00=MPI_Wtime()
3663 cd      write (iout,*) "eelecij",i,j
3664 c          ind=ind+1
3665           iteli=itel(i)
3666           itelj=itel(j)
3667           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3668           aaa=app(iteli,itelj)
3669           bbb=bpp(iteli,itelj)
3670           ael6i=ael6(iteli,itelj)
3671           ael3i=ael3(iteli,itelj)
3672           dxj=dc(1,j)
3673           dyj=dc(2,j)
3674           dzj=dc(3,j)
3675           dx_normj=dc_norm(1,j)
3676           dy_normj=dc_norm(2,j)
3677           dz_normj=dc_norm(3,j)
3678 C          xj=c(1,j)+0.5D0*dxj-xmedi
3679 C          yj=c(2,j)+0.5D0*dyj-ymedi
3680 C          zj=c(3,j)+0.5D0*dzj-zmedi
3681           xj=c(1,j)+0.5D0*dxj
3682           yj=c(2,j)+0.5D0*dyj
3683           zj=c(3,j)+0.5D0*dzj
3684           xj=mod(xj,boxxsize)
3685           if (xj.lt.0) xj=xj+boxxsize
3686           yj=mod(yj,boxysize)
3687           if (yj.lt.0) yj=yj+boxysize
3688           zj=mod(zj,boxzsize)
3689           if (zj.lt.0) zj=zj+boxzsize
3690           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3691       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3692       xj_safe=xj
3693       yj_safe=yj
3694       zj_safe=zj
3695       isubchap=0
3696       do xshift=-1,1
3697       do yshift=-1,1
3698       do zshift=-1,1
3699           xj=xj_safe+xshift*boxxsize
3700           yj=yj_safe+yshift*boxysize
3701           zj=zj_safe+zshift*boxzsize
3702           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3703           if(dist_temp.lt.dist_init) then
3704             dist_init=dist_temp
3705             xj_temp=xj
3706             yj_temp=yj
3707             zj_temp=zj
3708             isubchap=1
3709           endif
3710        enddo
3711        enddo
3712        enddo
3713        if (isubchap.eq.1) then
3714           xj=xj_temp-xmedi
3715           yj=yj_temp-ymedi
3716           zj=zj_temp-zmedi
3717        else
3718           xj=xj_safe-xmedi
3719           yj=yj_safe-ymedi
3720           zj=zj_safe-zmedi
3721        endif
3722 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3723 c  174   continue
3724 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3725 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3726 C Condition for being inside the proper box
3727 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3728 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3729 c        go to 174
3730 c        endif
3731 c  175   continue
3732 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3733 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3734 C Condition for being inside the proper box
3735 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3736 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3737 c        go to 175
3738 c        endif
3739 c  176   continue
3740 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3741 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3742 C Condition for being inside the proper box
3743 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3744 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3745 c        go to 176
3746 c        endif
3747 C        endif !endPBC condintion
3748 C        xj=xj-xmedi
3749 C        yj=yj-ymedi
3750 C        zj=zj-zmedi
3751           rij=xj*xj+yj*yj+zj*zj
3752
3753             sss=sscale(sqrt(rij))
3754             sssgrad=sscagrad(sqrt(rij))
3755 c            if (sss.gt.0.0d0) then
3756           rrmij=1.0D0/rij
3757           rij=dsqrt(rij)
3758           rmij=1.0D0/rij
3759           r3ij=rrmij*rmij
3760           r6ij=r3ij*r3ij
3761           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3762           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3763           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3764           fac=cosa-3.0D0*cosb*cosg
3765           ev1=aaa*r6ij*r6ij
3766 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3767           if (j.eq.i+2) ev1=scal_el*ev1
3768           ev2=bbb*r6ij
3769           fac3=ael6i*r6ij
3770           fac4=ael3i*r3ij
3771           evdwij=(ev1+ev2)
3772           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3773           el2=fac4*fac
3774 C MARYSIA
3775 C          eesij=(el1+el2)
3776 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3777           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3778           if (shield_mode.gt.0) then
3779 C          fac_shield(i)=0.4
3780 C          fac_shield(j)=0.6
3781           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3782           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3783           eesij=(el1+el2)
3784           ees=ees+eesij
3785           else
3786           fac_shield(i)=1.0
3787           fac_shield(j)=1.0
3788           eesij=(el1+el2)
3789           ees=ees+eesij
3790           endif
3791           evdw1=evdw1+evdwij*sss
3792 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3793 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3794 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3795 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3796
3797           if (energy_dec) then
3798               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3799      &'evdw1',i,j,evdwij
3800      &,iteli,itelj,aaa,evdw1
3801               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3802      &fac_shield(i),fac_shield(j)
3803           endif
3804
3805 C
3806 C Calculate contributions to the Cartesian gradient.
3807 C
3808 #ifdef SPLITELE
3809           facvdw=-6*rrmij*(ev1+evdwij)*sss
3810           facel=-3*rrmij*(el1+eesij)
3811           fac1=fac
3812           erij(1)=xj*rmij
3813           erij(2)=yj*rmij
3814           erij(3)=zj*rmij
3815
3816 *
3817 * Radial derivatives. First process both termini of the fragment (i,j)
3818 *
3819           ggg(1)=facel*xj
3820           ggg(2)=facel*yj
3821           ggg(3)=facel*zj
3822           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3823      &  (shield_mode.gt.0)) then
3824 C          print *,i,j
3825           do ilist=1,ishield_list(i)
3826            iresshield=shield_list(ilist,i)
3827            do k=1,3
3828            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3829      &      *2.0
3830            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3831      &              rlocshield
3832      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3833             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3834 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3835 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3836 C             if (iresshield.gt.i) then
3837 C               do ishi=i+1,iresshield-1
3838 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3839 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3840 C
3841 C              enddo
3842 C             else
3843 C               do ishi=iresshield,i
3844 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3845 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3846 C
3847 C               enddo
3848 C              endif
3849            enddo
3850           enddo
3851           do ilist=1,ishield_list(j)
3852            iresshield=shield_list(ilist,j)
3853            do k=1,3
3854            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3855      &     *2.0
3856            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3857      &              rlocshield
3858      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3859            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3860
3861 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3862 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3863 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3864 C             if (iresshield.gt.j) then
3865 C               do ishi=j+1,iresshield-1
3866 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3867 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3868 C
3869 C               enddo
3870 C            else
3871 C               do ishi=iresshield,j
3872 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3873 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3874 C               enddo
3875 C              endif
3876            enddo
3877           enddo
3878
3879           do k=1,3
3880             gshieldc(k,i)=gshieldc(k,i)+
3881      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3882             gshieldc(k,j)=gshieldc(k,j)+
3883      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3884             gshieldc(k,i-1)=gshieldc(k,i-1)+
3885      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3886             gshieldc(k,j-1)=gshieldc(k,j-1)+
3887      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3888
3889            enddo
3890            endif
3891 c          do k=1,3
3892 c            ghalf=0.5D0*ggg(k)
3893 c            gelc(k,i)=gelc(k,i)+ghalf
3894 c            gelc(k,j)=gelc(k,j)+ghalf
3895 c          enddo
3896 c 9/28/08 AL Gradient compotents will be summed only at the end
3897 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3898           do k=1,3
3899             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3900 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3901             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3902 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3903 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3904 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3905 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3906 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3907           enddo
3908 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3909
3910 *
3911 * Loop over residues i+1 thru j-1.
3912 *
3913 cgrad          do k=i+1,j-1
3914 cgrad            do l=1,3
3915 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3916 cgrad            enddo
3917 cgrad          enddo
3918           if (sss.gt.0.0) then
3919           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3920           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3921           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3922           else
3923           ggg(1)=0.0
3924           ggg(2)=0.0
3925           ggg(3)=0.0
3926           endif
3927 c          do k=1,3
3928 c            ghalf=0.5D0*ggg(k)
3929 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3930 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3931 c          enddo
3932 c 9/28/08 AL Gradient compotents will be summed only at the end
3933           do k=1,3
3934             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3935             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3936           enddo
3937 *
3938 * Loop over residues i+1 thru j-1.
3939 *
3940 cgrad          do k=i+1,j-1
3941 cgrad            do l=1,3
3942 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3943 cgrad            enddo
3944 cgrad          enddo
3945 #else
3946 C MARYSIA
3947           facvdw=(ev1+evdwij)*sss
3948           facel=(el1+eesij)
3949           fac1=fac
3950           fac=-3*rrmij*(facvdw+facvdw+facel)
3951           erij(1)=xj*rmij
3952           erij(2)=yj*rmij
3953           erij(3)=zj*rmij
3954 *
3955 * Radial derivatives. First process both termini of the fragment (i,j)
3956 *
3957           ggg(1)=fac*xj
3958 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3959           ggg(2)=fac*yj
3960 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3961           ggg(3)=fac*zj
3962 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3963 c          do k=1,3
3964 c            ghalf=0.5D0*ggg(k)
3965 c            gelc(k,i)=gelc(k,i)+ghalf
3966 c            gelc(k,j)=gelc(k,j)+ghalf
3967 c          enddo
3968 c 9/28/08 AL Gradient compotents will be summed only at the end
3969           do k=1,3
3970             gelc_long(k,j)=gelc(k,j)+ggg(k)
3971             gelc_long(k,i)=gelc(k,i)-ggg(k)
3972           enddo
3973 *
3974 * Loop over residues i+1 thru j-1.
3975 *
3976 cgrad          do k=i+1,j-1
3977 cgrad            do l=1,3
3978 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3979 cgrad            enddo
3980 cgrad          enddo
3981 c 9/28/08 AL Gradient compotents will be summed only at the end
3982           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3983           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3984           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3985           do k=1,3
3986             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3987             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3988           enddo
3989 #endif
3990 *
3991 * Angular part
3992 *
3993           ecosa=2.0D0*fac3*fac1+fac4
3994           fac4=-3.0D0*fac4
3995           fac3=-6.0D0*fac3
3996           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3997           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3998           do k=1,3
3999             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4000             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4001           enddo
4002 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4003 cd   &          (dcosg(k),k=1,3)
4004           do k=1,3
4005             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4006      &      fac_shield(i)**2*fac_shield(j)**2
4007           enddo
4008 c          do k=1,3
4009 c            ghalf=0.5D0*ggg(k)
4010 c            gelc(k,i)=gelc(k,i)+ghalf
4011 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4012 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4013 c            gelc(k,j)=gelc(k,j)+ghalf
4014 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4015 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4016 c          enddo
4017 cgrad          do k=i+1,j-1
4018 cgrad            do l=1,3
4019 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4020 cgrad            enddo
4021 cgrad          enddo
4022 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4023           do k=1,3
4024             gelc(k,i)=gelc(k,i)
4025      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4026      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4027      &           *fac_shield(i)**2*fac_shield(j)**2
4028             gelc(k,j)=gelc(k,j)
4029      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4030      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4031      &           *fac_shield(i)**2*fac_shield(j)**2
4032             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4033             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4034           enddo
4035 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4036
4037 C MARYSIA
4038 c          endif !sscale
4039           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4040      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4041      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4042 C
4043 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4044 C   energy of a peptide unit is assumed in the form of a second-order
4045 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4046 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4047 C   are computed for EVERY pair of non-contiguous peptide groups.
4048 C
4049
4050           if (j.lt.nres-1) then
4051             j1=j+1
4052             j2=j-1
4053           else
4054             j1=j-1
4055             j2=j-2
4056           endif
4057           kkk=0
4058           lll=0
4059           do k=1,2
4060             do l=1,2
4061               kkk=kkk+1
4062               muij(kkk)=mu(k,i)*mu(l,j)
4063 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4064 #ifdef NEWCORR
4065              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4066 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4067              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4068              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4069 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4070              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4071 #endif
4072             enddo
4073           enddo
4074 cd         write (iout,*) 'EELEC: i',i,' j',j
4075 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4076 cd          write(iout,*) 'muij',muij
4077           ury=scalar(uy(1,i),erij)
4078           urz=scalar(uz(1,i),erij)
4079           vry=scalar(uy(1,j),erij)
4080           vrz=scalar(uz(1,j),erij)
4081           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4082           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4083           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4084           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4085           fac=dsqrt(-ael6i)*r3ij
4086           a22=a22*fac
4087           a23=a23*fac
4088           a32=a32*fac
4089           a33=a33*fac
4090 cd          write (iout,'(4i5,4f10.5)')
4091 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4092 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4093 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4094 cd     &      uy(:,j),uz(:,j)
4095 cd          write (iout,'(4f10.5)')
4096 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4097 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4098 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4099 cd           write (iout,'(9f10.5/)')
4100 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4101 C Derivatives of the elements of A in virtual-bond vectors
4102           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4103           do k=1,3
4104             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4105             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4106             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4107             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4108             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4109             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4110             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4111             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4112             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4113             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4114             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4115             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4116           enddo
4117 C Compute radial contributions to the gradient
4118           facr=-3.0d0*rrmij
4119           a22der=a22*facr
4120           a23der=a23*facr
4121           a32der=a32*facr
4122           a33der=a33*facr
4123           agg(1,1)=a22der*xj
4124           agg(2,1)=a22der*yj
4125           agg(3,1)=a22der*zj
4126           agg(1,2)=a23der*xj
4127           agg(2,2)=a23der*yj
4128           agg(3,2)=a23der*zj
4129           agg(1,3)=a32der*xj
4130           agg(2,3)=a32der*yj
4131           agg(3,3)=a32der*zj
4132           agg(1,4)=a33der*xj
4133           agg(2,4)=a33der*yj
4134           agg(3,4)=a33der*zj
4135 C Add the contributions coming from er
4136           fac3=-3.0d0*fac
4137           do k=1,3
4138             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4139             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4140             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4141             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4142           enddo
4143           do k=1,3
4144 C Derivatives in DC(i)
4145 cgrad            ghalf1=0.5d0*agg(k,1)
4146 cgrad            ghalf2=0.5d0*agg(k,2)
4147 cgrad            ghalf3=0.5d0*agg(k,3)
4148 cgrad            ghalf4=0.5d0*agg(k,4)
4149             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4150      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4151             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4152      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4153             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4154      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4155             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4156      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4157 C Derivatives in DC(i+1)
4158             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4159      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4160             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4161      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4162             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4163      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4164             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4165      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4166 C Derivatives in DC(j)
4167             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4168      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4169             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4170      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4171             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4172      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4173             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4174      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4175 C Derivatives in DC(j+1) or DC(nres-1)
4176             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4177      &      -3.0d0*vryg(k,3)*ury)
4178             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4179      &      -3.0d0*vrzg(k,3)*ury)
4180             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4181      &      -3.0d0*vryg(k,3)*urz)
4182             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4183      &      -3.0d0*vrzg(k,3)*urz)
4184 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4185 cgrad              do l=1,4
4186 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4187 cgrad              enddo
4188 cgrad            endif
4189           enddo
4190           acipa(1,1)=a22
4191           acipa(1,2)=a23
4192           acipa(2,1)=a32
4193           acipa(2,2)=a33
4194           a22=-a22
4195           a23=-a23
4196           do l=1,2
4197             do k=1,3
4198               agg(k,l)=-agg(k,l)
4199               aggi(k,l)=-aggi(k,l)
4200               aggi1(k,l)=-aggi1(k,l)
4201               aggj(k,l)=-aggj(k,l)
4202               aggj1(k,l)=-aggj1(k,l)
4203             enddo
4204           enddo
4205           if (j.lt.nres-1) then
4206             a22=-a22
4207             a32=-a32
4208             do l=1,3,2
4209               do k=1,3
4210                 agg(k,l)=-agg(k,l)
4211                 aggi(k,l)=-aggi(k,l)
4212                 aggi1(k,l)=-aggi1(k,l)
4213                 aggj(k,l)=-aggj(k,l)
4214                 aggj1(k,l)=-aggj1(k,l)
4215               enddo
4216             enddo
4217           else
4218             a22=-a22
4219             a23=-a23
4220             a32=-a32
4221             a33=-a33
4222             do l=1,4
4223               do k=1,3
4224                 agg(k,l)=-agg(k,l)
4225                 aggi(k,l)=-aggi(k,l)
4226                 aggi1(k,l)=-aggi1(k,l)
4227                 aggj(k,l)=-aggj(k,l)
4228                 aggj1(k,l)=-aggj1(k,l)
4229               enddo
4230             enddo
4231           endif
4232           ENDIF ! WCORR
4233           IF (wel_loc.gt.0.0d0) THEN
4234 C Contribution to the local-electrostatic energy coming from the i-j pair
4235           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4236      &     +a33*muij(4)
4237           if (shield_mode.eq.0) then
4238            fac_shield(i)=1.0
4239            fac_shield(j)=1.0
4240 C          else
4241 C           fac_shield(i)=0.4
4242 C           fac_shield(j)=0.6
4243           endif
4244           eel_loc_ij=eel_loc_ij
4245      &    *fac_shield(i)*fac_shield(j)
4246 C Now derivative over eel_loc
4247           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4248      &  (shield_mode.gt.0)) then
4249 C          print *,i,j
4250
4251           do ilist=1,ishield_list(i)
4252            iresshield=shield_list(ilist,i)
4253            do k=1,3
4254            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4255      &                                          /fac_shield(i)
4256 C     &      *2.0
4257            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4258      &              rlocshield
4259      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4260             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4261      &      +rlocshield
4262            enddo
4263           enddo
4264           do ilist=1,ishield_list(j)
4265            iresshield=shield_list(ilist,j)
4266            do k=1,3
4267            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4268      &                                       /fac_shield(j)
4269 C     &     *2.0
4270            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4271      &              rlocshield
4272      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4273            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4274      &             +rlocshield
4275
4276            enddo
4277           enddo
4278
4279           do k=1,3
4280             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4281      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4282             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4283      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4284             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4285      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4286             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4287      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4288            enddo
4289            endif
4290
4291
4292 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4293 c     &                     ' eel_loc_ij',eel_loc_ij
4294 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4295 C Calculate patrial derivative for theta angle
4296 #ifdef NEWCORR
4297          geel_loc_ij=(a22*gmuij1(1)
4298      &     +a23*gmuij1(2)
4299      &     +a32*gmuij1(3)
4300      &     +a33*gmuij1(4))
4301      &    *fac_shield(i)*fac_shield(j)
4302 c         write(iout,*) "derivative over thatai"
4303 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4304 c     &   a33*gmuij1(4)
4305          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4306      &      geel_loc_ij*wel_loc
4307 c         write(iout,*) "derivative over thatai-1"
4308 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4309 c     &   a33*gmuij2(4)
4310          geel_loc_ij=
4311      &     a22*gmuij2(1)
4312      &     +a23*gmuij2(2)
4313      &     +a32*gmuij2(3)
4314      &     +a33*gmuij2(4)
4315          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4316      &      geel_loc_ij*wel_loc
4317      &    *fac_shield(i)*fac_shield(j)
4318
4319 c  Derivative over j residue
4320          geel_loc_ji=a22*gmuji1(1)
4321      &     +a23*gmuji1(2)
4322      &     +a32*gmuji1(3)
4323      &     +a33*gmuji1(4)
4324 c         write(iout,*) "derivative over thataj"
4325 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4326 c     &   a33*gmuji1(4)
4327
4328         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4329      &      geel_loc_ji*wel_loc
4330      &    *fac_shield(i)*fac_shield(j)
4331
4332          geel_loc_ji=
4333      &     +a22*gmuji2(1)
4334      &     +a23*gmuji2(2)
4335      &     +a32*gmuji2(3)
4336      &     +a33*gmuji2(4)
4337 c         write(iout,*) "derivative over thataj-1"
4338 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4339 c     &   a33*gmuji2(4)
4340          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4341      &      geel_loc_ji*wel_loc
4342      &    *fac_shield(i)*fac_shield(j)
4343 #endif
4344 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4345
4346           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4347      &            'eelloc',i,j,eel_loc_ij
4348 c           if (eel_loc_ij.ne.0)
4349 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4350 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4351
4352           eel_loc=eel_loc+eel_loc_ij
4353 C Partial derivatives in virtual-bond dihedral angles gamma
4354           if (i.gt.1)
4355      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4356      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4357      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4358      &    *fac_shield(i)*fac_shield(j)
4359
4360           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4361      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4362      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4363      &    *fac_shield(i)*fac_shield(j)
4364 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4365           do l=1,3
4366             ggg(l)=(agg(l,1)*muij(1)+
4367      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4368      &    *fac_shield(i)*fac_shield(j)
4369             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4370             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4371 cgrad            ghalf=0.5d0*ggg(l)
4372 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4373 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4374           enddo
4375 cgrad          do k=i+1,j2
4376 cgrad            do l=1,3
4377 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4378 cgrad            enddo
4379 cgrad          enddo
4380 C Remaining derivatives of eello
4381           do l=1,3
4382             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4383      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4384      &    *fac_shield(i)*fac_shield(j)
4385
4386             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4387      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4388      &    *fac_shield(i)*fac_shield(j)
4389
4390             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4391      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4392      &    *fac_shield(i)*fac_shield(j)
4393
4394             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4395      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4396      &    *fac_shield(i)*fac_shield(j)
4397
4398           enddo
4399           ENDIF
4400 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4401 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4402           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4403      &       .and. num_conti.le.maxconts) then
4404 c            write (iout,*) i,j," entered corr"
4405 C
4406 C Calculate the contact function. The ith column of the array JCONT will
4407 C contain the numbers of atoms that make contacts with the atom I (of numbers
4408 C greater than I). The arrays FACONT and GACONT will contain the values of
4409 C the contact function and its derivative.
4410 c           r0ij=1.02D0*rpp(iteli,itelj)
4411 c           r0ij=1.11D0*rpp(iteli,itelj)
4412             r0ij=2.20D0*rpp(iteli,itelj)
4413 c           r0ij=1.55D0*rpp(iteli,itelj)
4414             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4415             if (fcont.gt.0.0D0) then
4416               num_conti=num_conti+1
4417               if (num_conti.gt.maxconts) then
4418                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4419      &                         ' will skip next contacts for this conf.'
4420               else
4421                 jcont_hb(num_conti,i)=j
4422 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4423 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4424                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4425      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4426 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4427 C  terms.
4428                 d_cont(num_conti,i)=rij
4429 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4430 C     --- Electrostatic-interaction matrix ---
4431                 a_chuj(1,1,num_conti,i)=a22
4432                 a_chuj(1,2,num_conti,i)=a23
4433                 a_chuj(2,1,num_conti,i)=a32
4434                 a_chuj(2,2,num_conti,i)=a33
4435 C     --- Gradient of rij
4436                 do kkk=1,3
4437                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4438                 enddo
4439                 kkll=0
4440                 do k=1,2
4441                   do l=1,2
4442                     kkll=kkll+1
4443                     do m=1,3
4444                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4445                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4446                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4447                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4448                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4449                     enddo
4450                   enddo
4451                 enddo
4452                 ENDIF
4453                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4454 C Calculate contact energies
4455                 cosa4=4.0D0*cosa
4456                 wij=cosa-3.0D0*cosb*cosg
4457                 cosbg1=cosb+cosg
4458                 cosbg2=cosb-cosg
4459 c               fac3=dsqrt(-ael6i)/r0ij**3
4460                 fac3=dsqrt(-ael6i)*r3ij
4461 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4462                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4463                 if (ees0tmp.gt.0) then
4464                   ees0pij=dsqrt(ees0tmp)
4465                 else
4466                   ees0pij=0
4467                 endif
4468 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4469                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4470                 if (ees0tmp.gt.0) then
4471                   ees0mij=dsqrt(ees0tmp)
4472                 else
4473                   ees0mij=0
4474                 endif
4475 c               ees0mij=0.0D0
4476                 if (shield_mode.eq.0) then
4477                 fac_shield(i)=1.0d0
4478                 fac_shield(j)=1.0d0
4479                 else
4480                 ees0plist(num_conti,i)=j
4481 C                fac_shield(i)=0.4d0
4482 C                fac_shield(j)=0.6d0
4483                 endif
4484                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4485      &          *fac_shield(i)*fac_shield(j)
4486                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4487      &          *fac_shield(i)*fac_shield(j)
4488 C Diagnostics. Comment out or remove after debugging!
4489 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4490 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4491 c               ees0m(num_conti,i)=0.0D0
4492 C End diagnostics.
4493 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4494 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4495 C Angular derivatives of the contact function
4496                 ees0pij1=fac3/ees0pij
4497                 ees0mij1=fac3/ees0mij
4498                 fac3p=-3.0D0*fac3*rrmij
4499                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4500                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4501 c               ees0mij1=0.0D0
4502                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4503                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4504                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4505                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4506                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4507                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4508                 ecosap=ecosa1+ecosa2
4509                 ecosbp=ecosb1+ecosb2
4510                 ecosgp=ecosg1+ecosg2
4511                 ecosam=ecosa1-ecosa2
4512                 ecosbm=ecosb1-ecosb2
4513                 ecosgm=ecosg1-ecosg2
4514 C Diagnostics
4515 c               ecosap=ecosa1
4516 c               ecosbp=ecosb1
4517 c               ecosgp=ecosg1
4518 c               ecosam=0.0D0
4519 c               ecosbm=0.0D0
4520 c               ecosgm=0.0D0
4521 C End diagnostics
4522                 facont_hb(num_conti,i)=fcont
4523                 fprimcont=fprimcont/rij
4524 cd              facont_hb(num_conti,i)=1.0D0
4525 C Following line is for diagnostics.
4526 cd              fprimcont=0.0D0
4527                 do k=1,3
4528                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4529                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4530                 enddo
4531                 do k=1,3
4532                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4533                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4534                 enddo
4535                 gggp(1)=gggp(1)+ees0pijp*xj
4536                 gggp(2)=gggp(2)+ees0pijp*yj
4537                 gggp(3)=gggp(3)+ees0pijp*zj
4538                 gggm(1)=gggm(1)+ees0mijp*xj
4539                 gggm(2)=gggm(2)+ees0mijp*yj
4540                 gggm(3)=gggm(3)+ees0mijp*zj
4541 C Derivatives due to the contact function
4542                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4543                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4544                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4545                 do k=1,3
4546 c
4547 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4548 c          following the change of gradient-summation algorithm.
4549 c
4550 cgrad                  ghalfp=0.5D0*gggp(k)
4551 cgrad                  ghalfm=0.5D0*gggm(k)
4552                   gacontp_hb1(k,num_conti,i)=!ghalfp
4553      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4554      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4555      &          *fac_shield(i)*fac_shield(j)
4556
4557                   gacontp_hb2(k,num_conti,i)=!ghalfp
4558      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4559      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4560      &          *fac_shield(i)*fac_shield(j)
4561
4562                   gacontp_hb3(k,num_conti,i)=gggp(k)
4563      &          *fac_shield(i)*fac_shield(j)
4564
4565                   gacontm_hb1(k,num_conti,i)=!ghalfm
4566      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4567      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4568      &          *fac_shield(i)*fac_shield(j)
4569
4570                   gacontm_hb2(k,num_conti,i)=!ghalfm
4571      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4572      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4573      &          *fac_shield(i)*fac_shield(j)
4574
4575                   gacontm_hb3(k,num_conti,i)=gggm(k)
4576      &          *fac_shield(i)*fac_shield(j)
4577
4578                 enddo
4579 C Diagnostics. Comment out or remove after debugging!
4580 cdiag           do k=1,3
4581 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4582 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4583 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4584 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4585 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4586 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4587 cdiag           enddo
4588               ENDIF ! wcorr
4589               endif  ! num_conti.le.maxconts
4590             endif  ! fcont.gt.0
4591           endif    ! j.gt.i+1
4592           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4593             do k=1,4
4594               do l=1,3
4595                 ghalf=0.5d0*agg(l,k)
4596                 aggi(l,k)=aggi(l,k)+ghalf
4597                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4598                 aggj(l,k)=aggj(l,k)+ghalf
4599               enddo
4600             enddo
4601             if (j.eq.nres-1 .and. i.lt.j-2) then
4602               do k=1,4
4603                 do l=1,3
4604                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4605                 enddo
4606               enddo
4607             endif
4608           endif
4609 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4610       return
4611       end
4612 C-----------------------------------------------------------------------------
4613       subroutine eturn3(i,eello_turn3)
4614 C Third- and fourth-order contributions from turns
4615       implicit real*8 (a-h,o-z)
4616       include 'DIMENSIONS'
4617       include 'COMMON.IOUNITS'
4618       include 'COMMON.GEO'
4619       include 'COMMON.VAR'
4620       include 'COMMON.LOCAL'
4621       include 'COMMON.CHAIN'
4622       include 'COMMON.DERIV'
4623       include 'COMMON.INTERACT'
4624       include 'COMMON.CONTACTS'
4625       include 'COMMON.TORSION'
4626       include 'COMMON.VECTORS'
4627       include 'COMMON.FFIELD'
4628       include 'COMMON.CONTROL'
4629       include 'COMMON.SHIELD'
4630       dimension ggg(3)
4631       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4632      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4633      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4634      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4635      &  auxgmat2(2,2),auxgmatt2(2,2)
4636       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4637      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4638       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4639      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4640      &    num_conti,j1,j2
4641       j=i+2
4642 c      write (iout,*) "eturn3",i,j,j1,j2
4643       a_temp(1,1)=a22
4644       a_temp(1,2)=a23
4645       a_temp(2,1)=a32
4646       a_temp(2,2)=a33
4647 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4648 C
4649 C               Third-order contributions
4650 C
4651 C                 (i+2)o----(i+3)
4652 C                      | |
4653 C                      | |
4654 C                 (i+1)o----i
4655 C
4656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4657 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4658         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4659 c auxalary matices for theta gradient
4660 c auxalary matrix for i+1 and constant i+2
4661         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4662 c auxalary matrix for i+2 and constant i+1
4663         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4664         call transpose2(auxmat(1,1),auxmat1(1,1))
4665         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4666         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4667         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4668         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4669         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4670         if (shield_mode.eq.0) then
4671         fac_shield(i)=1.0
4672         fac_shield(j)=1.0
4673 C        else
4674 C        fac_shield(i)=0.4
4675 C        fac_shield(j)=0.6
4676         endif
4677         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4678      &  *fac_shield(i)*fac_shield(j)
4679         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4680      &  *fac_shield(i)*fac_shield(j)
4681 C Derivatives in theta
4682         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4683      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4684      &   *fac_shield(i)*fac_shield(j)
4685         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4686      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4687      &   *fac_shield(i)*fac_shield(j)
4688
4689
4690 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4691 C Derivatives in shield mode
4692           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4693      &  (shield_mode.gt.0)) then
4694 C          print *,i,j
4695
4696           do ilist=1,ishield_list(i)
4697            iresshield=shield_list(ilist,i)
4698            do k=1,3
4699            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4700 C     &      *2.0
4701            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4702      &              rlocshield
4703      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4704             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4705      &      +rlocshield
4706            enddo
4707           enddo
4708           do ilist=1,ishield_list(j)
4709            iresshield=shield_list(ilist,j)
4710            do k=1,3
4711            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4712 C     &     *2.0
4713            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4714      &              rlocshield
4715      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4716            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4717      &             +rlocshield
4718
4719            enddo
4720           enddo
4721
4722           do k=1,3
4723             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4724      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4725             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4726      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4727             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4728      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4729             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4730      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4731            enddo
4732            endif
4733
4734 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4735 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4736 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4737 cd     &    ' eello_turn3_num',4*eello_turn3_num
4738 C Derivatives in gamma(i)
4739         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4740         call transpose2(auxmat2(1,1),auxmat3(1,1))
4741         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4742         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4743      &   *fac_shield(i)*fac_shield(j)
4744 C Derivatives in gamma(i+1)
4745         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4746         call transpose2(auxmat2(1,1),auxmat3(1,1))
4747         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4748         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4749      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4750      &   *fac_shield(i)*fac_shield(j)
4751 C Cartesian derivatives
4752         do l=1,3
4753 c            ghalf1=0.5d0*agg(l,1)
4754 c            ghalf2=0.5d0*agg(l,2)
4755 c            ghalf3=0.5d0*agg(l,3)
4756 c            ghalf4=0.5d0*agg(l,4)
4757           a_temp(1,1)=aggi(l,1)!+ghalf1
4758           a_temp(1,2)=aggi(l,2)!+ghalf2
4759           a_temp(2,1)=aggi(l,3)!+ghalf3
4760           a_temp(2,2)=aggi(l,4)!+ghalf4
4761           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4762           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4763      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4764      &   *fac_shield(i)*fac_shield(j)
4765
4766           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4767           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4768           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4769           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4770           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4771           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4772      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4773      &   *fac_shield(i)*fac_shield(j)
4774           a_temp(1,1)=aggj(l,1)!+ghalf1
4775           a_temp(1,2)=aggj(l,2)!+ghalf2
4776           a_temp(2,1)=aggj(l,3)!+ghalf3
4777           a_temp(2,2)=aggj(l,4)!+ghalf4
4778           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4779           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4780      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4781      &   *fac_shield(i)*fac_shield(j)
4782           a_temp(1,1)=aggj1(l,1)
4783           a_temp(1,2)=aggj1(l,2)
4784           a_temp(2,1)=aggj1(l,3)
4785           a_temp(2,2)=aggj1(l,4)
4786           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4787           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4788      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4789      &   *fac_shield(i)*fac_shield(j)
4790         enddo
4791       return
4792       end
4793 C-------------------------------------------------------------------------------
4794       subroutine eturn4(i,eello_turn4)
4795 C Third- and fourth-order contributions from turns
4796       implicit real*8 (a-h,o-z)
4797       include 'DIMENSIONS'
4798       include 'COMMON.IOUNITS'
4799       include 'COMMON.GEO'
4800       include 'COMMON.VAR'
4801       include 'COMMON.LOCAL'
4802       include 'COMMON.CHAIN'
4803       include 'COMMON.DERIV'
4804       include 'COMMON.INTERACT'
4805       include 'COMMON.CONTACTS'
4806       include 'COMMON.TORSION'
4807       include 'COMMON.VECTORS'
4808       include 'COMMON.FFIELD'
4809       include 'COMMON.CONTROL'
4810       include 'COMMON.SHIELD'
4811       dimension ggg(3)
4812       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4813      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4814      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4815      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4816      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4817      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4818      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4819       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4820      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4821       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4822      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4823      &    num_conti,j1,j2
4824       j=i+3
4825 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4826 C
4827 C               Fourth-order contributions
4828 C
4829 C                 (i+3)o----(i+4)
4830 C                     /  |
4831 C               (i+2)o   |
4832 C                     \  |
4833 C                 (i+1)o----i
4834 C
4835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4836 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4837 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4838 c        write(iout,*)"WCHODZE W PROGRAM"
4839         a_temp(1,1)=a22
4840         a_temp(1,2)=a23
4841         a_temp(2,1)=a32
4842         a_temp(2,2)=a33
4843         iti1=itype2loc(itype(i+1))
4844         iti2=itype2loc(itype(i+2))
4845         iti3=itype2loc(itype(i+3))
4846 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4847         call transpose2(EUg(1,1,i+1),e1t(1,1))
4848         call transpose2(Eug(1,1,i+2),e2t(1,1))
4849         call transpose2(Eug(1,1,i+3),e3t(1,1))
4850 C Ematrix derivative in theta
4851         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4852         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4853         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4854         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4855 c       eta1 in derivative theta
4856         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4857         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4858 c       auxgvec is derivative of Ub2 so i+3 theta
4859         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4860 c       auxalary matrix of E i+1
4861         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4862 c        s1=0.0
4863 c        gs1=0.0
4864         s1=scalar2(b1(1,i+2),auxvec(1))
4865 c derivative of theta i+2 with constant i+3
4866         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4867 c derivative of theta i+2 with constant i+2
4868         gs32=scalar2(b1(1,i+2),auxgvec(1))
4869 c derivative of E matix in theta of i+1
4870         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4871
4872         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4873 c       ea31 in derivative theta
4874         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4875         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4876 c auxilary matrix auxgvec of Ub2 with constant E matirx
4877         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4878 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4879         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4880
4881 c        s2=0.0
4882 c        gs2=0.0
4883         s2=scalar2(b1(1,i+1),auxvec(1))
4884 c derivative of theta i+1 with constant i+3
4885         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4886 c derivative of theta i+2 with constant i+1
4887         gs21=scalar2(b1(1,i+1),auxgvec(1))
4888 c derivative of theta i+3 with constant i+1
4889         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4890 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4891 c     &  gtb1(1,i+1)
4892         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4893 c two derivatives over diffetent matrices
4894 c gtae3e2 is derivative over i+3
4895         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4896 c ae3gte2 is derivative over i+2
4897         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4898         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4899 c three possible derivative over theta E matices
4900 c i+1
4901         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4902 c i+2
4903         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4904 c i+3
4905         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4906         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4907
4908         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4909         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4910         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4911         if (shield_mode.eq.0) then
4912         fac_shield(i)=1.0
4913         fac_shield(j)=1.0
4914 C        else
4915 C        fac_shield(i)=0.6
4916 C        fac_shield(j)=0.4
4917         endif
4918         eello_turn4=eello_turn4-(s1+s2+s3)
4919      &  *fac_shield(i)*fac_shield(j)
4920         eello_t4=-(s1+s2+s3)
4921      &  *fac_shield(i)*fac_shield(j)
4922 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4923         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4924      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4925 C Now derivative over shield:
4926           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4927      &  (shield_mode.gt.0)) then
4928 C          print *,i,j
4929
4930           do ilist=1,ishield_list(i)
4931            iresshield=shield_list(ilist,i)
4932            do k=1,3
4933            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4934 C     &      *2.0
4935            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4936      &              rlocshield
4937      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4938             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4939      &      +rlocshield
4940            enddo
4941           enddo
4942           do ilist=1,ishield_list(j)
4943            iresshield=shield_list(ilist,j)
4944            do k=1,3
4945            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4946 C     &     *2.0
4947            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4948      &              rlocshield
4949      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4950            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4951      &             +rlocshield
4952
4953            enddo
4954           enddo
4955
4956           do k=1,3
4957             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4958      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4959             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4960      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4961             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4962      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4963             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4964      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4965            enddo
4966            endif
4967
4968
4969
4970
4971
4972
4973 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4974 cd     &    ' eello_turn4_num',8*eello_turn4_num
4975 #ifdef NEWCORR
4976         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4977      &                  -(gs13+gsE13+gsEE1)*wturn4
4978      &  *fac_shield(i)*fac_shield(j)
4979         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4980      &                    -(gs23+gs21+gsEE2)*wturn4
4981      &  *fac_shield(i)*fac_shield(j)
4982
4983         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4984      &                    -(gs32+gsE31+gsEE3)*wturn4
4985      &  *fac_shield(i)*fac_shield(j)
4986
4987 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4988 c     &   gs2
4989 #endif
4990         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4991      &      'eturn4',i,j,-(s1+s2+s3)
4992 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4993 c     &    ' eello_turn4_num',8*eello_turn4_num
4994 C Derivatives in gamma(i)
4995         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4996         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4997         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4998         s1=scalar2(b1(1,i+2),auxvec(1))
4999         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5000         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5001         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5002      &  *fac_shield(i)*fac_shield(j)
5003 C Derivatives in gamma(i+1)
5004         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5005         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5006         s2=scalar2(b1(1,i+1),auxvec(1))
5007         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5008         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5009         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5010         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5011      &  *fac_shield(i)*fac_shield(j)
5012 C Derivatives in gamma(i+2)
5013         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5014         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5015         s1=scalar2(b1(1,i+2),auxvec(1))
5016         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5017         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5018         s2=scalar2(b1(1,i+1),auxvec(1))
5019         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5020         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5021         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5022         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5023      &  *fac_shield(i)*fac_shield(j)
5024 C Cartesian derivatives
5025 C Derivatives of this turn contributions in DC(i+2)
5026         if (j.lt.nres-1) then
5027           do l=1,3
5028             a_temp(1,1)=agg(l,1)
5029             a_temp(1,2)=agg(l,2)
5030             a_temp(2,1)=agg(l,3)
5031             a_temp(2,2)=agg(l,4)
5032             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5033             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5034             s1=scalar2(b1(1,i+2),auxvec(1))
5035             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5036             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5037             s2=scalar2(b1(1,i+1),auxvec(1))
5038             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5039             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5040             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5041             ggg(l)=-(s1+s2+s3)
5042             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5043      &  *fac_shield(i)*fac_shield(j)
5044           enddo
5045         endif
5046 C Remaining derivatives of this turn contribution
5047         do l=1,3
5048           a_temp(1,1)=aggi(l,1)
5049           a_temp(1,2)=aggi(l,2)
5050           a_temp(2,1)=aggi(l,3)
5051           a_temp(2,2)=aggi(l,4)
5052           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5053           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5054           s1=scalar2(b1(1,i+2),auxvec(1))
5055           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5056           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5057           s2=scalar2(b1(1,i+1),auxvec(1))
5058           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5059           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5060           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5061           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5062      &  *fac_shield(i)*fac_shield(j)
5063           a_temp(1,1)=aggi1(l,1)
5064           a_temp(1,2)=aggi1(l,2)
5065           a_temp(2,1)=aggi1(l,3)
5066           a_temp(2,2)=aggi1(l,4)
5067           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5068           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5069           s1=scalar2(b1(1,i+2),auxvec(1))
5070           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5071           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5072           s2=scalar2(b1(1,i+1),auxvec(1))
5073           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5074           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5075           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5076           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5077      &  *fac_shield(i)*fac_shield(j)
5078           a_temp(1,1)=aggj(l,1)
5079           a_temp(1,2)=aggj(l,2)
5080           a_temp(2,1)=aggj(l,3)
5081           a_temp(2,2)=aggj(l,4)
5082           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5083           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5084           s1=scalar2(b1(1,i+2),auxvec(1))
5085           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5086           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5087           s2=scalar2(b1(1,i+1),auxvec(1))
5088           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5089           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5090           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5091           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5092      &  *fac_shield(i)*fac_shield(j)
5093           a_temp(1,1)=aggj1(l,1)
5094           a_temp(1,2)=aggj1(l,2)
5095           a_temp(2,1)=aggj1(l,3)
5096           a_temp(2,2)=aggj1(l,4)
5097           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5098           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5099           s1=scalar2(b1(1,i+2),auxvec(1))
5100           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5101           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5102           s2=scalar2(b1(1,i+1),auxvec(1))
5103           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5104           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5105           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5106 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5107           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5108      &  *fac_shield(i)*fac_shield(j)
5109         enddo
5110       return
5111       end
5112 C-----------------------------------------------------------------------------
5113       subroutine vecpr(u,v,w)
5114       implicit real*8(a-h,o-z)
5115       dimension u(3),v(3),w(3)
5116       w(1)=u(2)*v(3)-u(3)*v(2)
5117       w(2)=-u(1)*v(3)+u(3)*v(1)
5118       w(3)=u(1)*v(2)-u(2)*v(1)
5119       return
5120       end
5121 C-----------------------------------------------------------------------------
5122       subroutine unormderiv(u,ugrad,unorm,ungrad)
5123 C This subroutine computes the derivatives of a normalized vector u, given
5124 C the derivatives computed without normalization conditions, ugrad. Returns
5125 C ungrad.
5126       implicit none
5127       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5128       double precision vec(3)
5129       double precision scalar
5130       integer i,j
5131 c      write (2,*) 'ugrad',ugrad
5132 c      write (2,*) 'u',u
5133       do i=1,3
5134         vec(i)=scalar(ugrad(1,i),u(1))
5135       enddo
5136 c      write (2,*) 'vec',vec
5137       do i=1,3
5138         do j=1,3
5139           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5140         enddo
5141       enddo
5142 c      write (2,*) 'ungrad',ungrad
5143       return
5144       end
5145 C-----------------------------------------------------------------------------
5146       subroutine escp_soft_sphere(evdw2,evdw2_14)
5147 C
5148 C This subroutine calculates the excluded-volume interaction energy between
5149 C peptide-group centers and side chains and its gradient in virtual-bond and
5150 C side-chain vectors.
5151 C
5152       implicit real*8 (a-h,o-z)
5153       include 'DIMENSIONS'
5154       include 'COMMON.GEO'
5155       include 'COMMON.VAR'
5156       include 'COMMON.LOCAL'
5157       include 'COMMON.CHAIN'
5158       include 'COMMON.DERIV'
5159       include 'COMMON.INTERACT'
5160       include 'COMMON.FFIELD'
5161       include 'COMMON.IOUNITS'
5162       include 'COMMON.CONTROL'
5163       dimension ggg(3)
5164       evdw2=0.0D0
5165       evdw2_14=0.0d0
5166       r0_scp=4.5d0
5167 cd    print '(a)','Enter ESCP'
5168 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5169 C      do xshift=-1,1
5170 C      do yshift=-1,1
5171 C      do zshift=-1,1
5172       do i=iatscp_s,iatscp_e
5173         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5174         iteli=itel(i)
5175         xi=0.5D0*(c(1,i)+c(1,i+1))
5176         yi=0.5D0*(c(2,i)+c(2,i+1))
5177         zi=0.5D0*(c(3,i)+c(3,i+1))
5178 C Return atom into box, boxxsize is size of box in x dimension
5179 c  134   continue
5180 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5181 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5182 C Condition for being inside the proper box
5183 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5184 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5185 c        go to 134
5186 c        endif
5187 c  135   continue
5188 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5189 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5190 C Condition for being inside the proper box
5191 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5192 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5193 c        go to 135
5194 c c       endif
5195 c  136   continue
5196 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5197 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5198 cC Condition for being inside the proper box
5199 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5200 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5201 c        go to 136
5202 c        endif
5203           xi=mod(xi,boxxsize)
5204           if (xi.lt.0) xi=xi+boxxsize
5205           yi=mod(yi,boxysize)
5206           if (yi.lt.0) yi=yi+boxysize
5207           zi=mod(zi,boxzsize)
5208           if (zi.lt.0) zi=zi+boxzsize
5209 C          xi=xi+xshift*boxxsize
5210 C          yi=yi+yshift*boxysize
5211 C          zi=zi+zshift*boxzsize
5212         do iint=1,nscp_gr(i)
5213
5214         do j=iscpstart(i,iint),iscpend(i,iint)
5215           if (itype(j).eq.ntyp1) cycle
5216           itypj=iabs(itype(j))
5217 C Uncomment following three lines for SC-p interactions
5218 c         xj=c(1,nres+j)-xi
5219 c         yj=c(2,nres+j)-yi
5220 c         zj=c(3,nres+j)-zi
5221 C Uncomment following three lines for Ca-p interactions
5222           xj=c(1,j)
5223           yj=c(2,j)
5224           zj=c(3,j)
5225 c  174   continue
5226 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5227 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5228 C Condition for being inside the proper box
5229 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5230 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5231 c        go to 174
5232 c        endif
5233 c  175   continue
5234 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5235 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5236 cC Condition for being inside the proper box
5237 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5238 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5239 c        go to 175
5240 c        endif
5241 c  176   continue
5242 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5243 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5244 C Condition for being inside the proper box
5245 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5246 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5247 c        go to 176
5248           xj=mod(xj,boxxsize)
5249           if (xj.lt.0) xj=xj+boxxsize
5250           yj=mod(yj,boxysize)
5251           if (yj.lt.0) yj=yj+boxysize
5252           zj=mod(zj,boxzsize)
5253           if (zj.lt.0) zj=zj+boxzsize
5254       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5255       xj_safe=xj
5256       yj_safe=yj
5257       zj_safe=zj
5258       subchap=0
5259       do xshift=-1,1
5260       do yshift=-1,1
5261       do zshift=-1,1
5262           xj=xj_safe+xshift*boxxsize
5263           yj=yj_safe+yshift*boxysize
5264           zj=zj_safe+zshift*boxzsize
5265           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5266           if(dist_temp.lt.dist_init) then
5267             dist_init=dist_temp
5268             xj_temp=xj
5269             yj_temp=yj
5270             zj_temp=zj
5271             subchap=1
5272           endif
5273        enddo
5274        enddo
5275        enddo
5276        if (subchap.eq.1) then
5277           xj=xj_temp-xi
5278           yj=yj_temp-yi
5279           zj=zj_temp-zi
5280        else
5281           xj=xj_safe-xi
5282           yj=yj_safe-yi
5283           zj=zj_safe-zi
5284        endif
5285 c c       endif
5286 C          xj=xj-xi
5287 C          yj=yj-yi
5288 C          zj=zj-zi
5289           rij=xj*xj+yj*yj+zj*zj
5290
5291           r0ij=r0_scp
5292           r0ijsq=r0ij*r0ij
5293           if (rij.lt.r0ijsq) then
5294             evdwij=0.25d0*(rij-r0ijsq)**2
5295             fac=rij-r0ijsq
5296           else
5297             evdwij=0.0d0
5298             fac=0.0d0
5299           endif
5300           evdw2=evdw2+evdwij
5301 C
5302 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5303 C
5304           ggg(1)=xj*fac
5305           ggg(2)=yj*fac
5306           ggg(3)=zj*fac
5307 cgrad          if (j.lt.i) then
5308 cd          write (iout,*) 'j<i'
5309 C Uncomment following three lines for SC-p interactions
5310 c           do k=1,3
5311 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5312 c           enddo
5313 cgrad          else
5314 cd          write (iout,*) 'j>i'
5315 cgrad            do k=1,3
5316 cgrad              ggg(k)=-ggg(k)
5317 C Uncomment following line for SC-p interactions
5318 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5319 cgrad            enddo
5320 cgrad          endif
5321 cgrad          do k=1,3
5322 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5323 cgrad          enddo
5324 cgrad          kstart=min0(i+1,j)
5325 cgrad          kend=max0(i-1,j-1)
5326 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5327 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5328 cgrad          do k=kstart,kend
5329 cgrad            do l=1,3
5330 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5331 cgrad            enddo
5332 cgrad          enddo
5333           do k=1,3
5334             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5335             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5336           enddo
5337         enddo
5338
5339         enddo ! iint
5340       enddo ! i
5341 C      enddo !zshift
5342 C      enddo !yshift
5343 C      enddo !xshift
5344       return
5345       end
5346 C-----------------------------------------------------------------------------
5347       subroutine escp(evdw2,evdw2_14)
5348 C
5349 C This subroutine calculates the excluded-volume interaction energy between
5350 C peptide-group centers and side chains and its gradient in virtual-bond and
5351 C side-chain vectors.
5352 C
5353       implicit real*8 (a-h,o-z)
5354       include 'DIMENSIONS'
5355       include 'COMMON.GEO'
5356       include 'COMMON.VAR'
5357       include 'COMMON.LOCAL'
5358       include 'COMMON.CHAIN'
5359       include 'COMMON.DERIV'
5360       include 'COMMON.INTERACT'
5361       include 'COMMON.FFIELD'
5362       include 'COMMON.IOUNITS'
5363       include 'COMMON.CONTROL'
5364       include 'COMMON.SPLITELE'
5365       dimension ggg(3)
5366       evdw2=0.0D0
5367       evdw2_14=0.0d0
5368 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5369 cd    print '(a)','Enter ESCP'
5370 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5371 C      do xshift=-1,1
5372 C      do yshift=-1,1
5373 C      do zshift=-1,1
5374       do i=iatscp_s,iatscp_e
5375         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5376         iteli=itel(i)
5377         xi=0.5D0*(c(1,i)+c(1,i+1))
5378         yi=0.5D0*(c(2,i)+c(2,i+1))
5379         zi=0.5D0*(c(3,i)+c(3,i+1))
5380           xi=mod(xi,boxxsize)
5381           if (xi.lt.0) xi=xi+boxxsize
5382           yi=mod(yi,boxysize)
5383           if (yi.lt.0) yi=yi+boxysize
5384           zi=mod(zi,boxzsize)
5385           if (zi.lt.0) zi=zi+boxzsize
5386 c          xi=xi+xshift*boxxsize
5387 c          yi=yi+yshift*boxysize
5388 c          zi=zi+zshift*boxzsize
5389 c        print *,xi,yi,zi,'polozenie i'
5390 C Return atom into box, boxxsize is size of box in x dimension
5391 c  134   continue
5392 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5393 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5394 C Condition for being inside the proper box
5395 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5396 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5397 c        go to 134
5398 c        endif
5399 c  135   continue
5400 c          print *,xi,boxxsize,"pierwszy"
5401
5402 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5403 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5404 C Condition for being inside the proper box
5405 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5406 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5407 c        go to 135
5408 c        endif
5409 c  136   continue
5410 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5411 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5412 C Condition for being inside the proper box
5413 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5414 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5415 c        go to 136
5416 c        endif
5417         do iint=1,nscp_gr(i)
5418
5419         do j=iscpstart(i,iint),iscpend(i,iint)
5420           itypj=iabs(itype(j))
5421           if (itypj.eq.ntyp1) cycle
5422 C Uncomment following three lines for SC-p interactions
5423 c         xj=c(1,nres+j)-xi
5424 c         yj=c(2,nres+j)-yi
5425 c         zj=c(3,nres+j)-zi
5426 C Uncomment following three lines for Ca-p interactions
5427           xj=c(1,j)
5428           yj=c(2,j)
5429           zj=c(3,j)
5430           xj=mod(xj,boxxsize)
5431           if (xj.lt.0) xj=xj+boxxsize
5432           yj=mod(yj,boxysize)
5433           if (yj.lt.0) yj=yj+boxysize
5434           zj=mod(zj,boxzsize)
5435           if (zj.lt.0) zj=zj+boxzsize
5436 c  174   continue
5437 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5438 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5439 C Condition for being inside the proper box
5440 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5441 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5442 c        go to 174
5443 c        endif
5444 c  175   continue
5445 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5446 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5447 cC Condition for being inside the proper box
5448 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5449 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5450 c        go to 175
5451 c        endif
5452 c  176   continue
5453 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5454 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5455 C Condition for being inside the proper box
5456 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5457 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5458 c        go to 176
5459 c        endif
5460 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5461       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5462       xj_safe=xj
5463       yj_safe=yj
5464       zj_safe=zj
5465       subchap=0
5466       do xshift=-1,1
5467       do yshift=-1,1
5468       do zshift=-1,1
5469           xj=xj_safe+xshift*boxxsize
5470           yj=yj_safe+yshift*boxysize
5471           zj=zj_safe+zshift*boxzsize
5472           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5473           if(dist_temp.lt.dist_init) then
5474             dist_init=dist_temp
5475             xj_temp=xj
5476             yj_temp=yj
5477             zj_temp=zj
5478             subchap=1
5479           endif
5480        enddo
5481        enddo
5482        enddo
5483        if (subchap.eq.1) then
5484           xj=xj_temp-xi
5485           yj=yj_temp-yi
5486           zj=zj_temp-zi
5487        else
5488           xj=xj_safe-xi
5489           yj=yj_safe-yi
5490           zj=zj_safe-zi
5491        endif
5492 c          print *,xj,yj,zj,'polozenie j'
5493           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5494 c          print *,rrij
5495           sss=sscale(1.0d0/(dsqrt(rrij)))
5496 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5497 c          if (sss.eq.0) print *,'czasem jest OK'
5498           if (sss.le.0.0d0) cycle
5499           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5500           fac=rrij**expon2
5501           e1=fac*fac*aad(itypj,iteli)
5502           e2=fac*bad(itypj,iteli)
5503           if (iabs(j-i) .le. 2) then
5504             e1=scal14*e1
5505             e2=scal14*e2
5506             evdw2_14=evdw2_14+(e1+e2)*sss
5507           endif
5508           evdwij=e1+e2
5509           evdw2=evdw2+evdwij*sss
5510           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5511      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5512      &       bad(itypj,iteli)
5513 C
5514 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5515 C
5516           fac=-(evdwij+e1)*rrij*sss
5517           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5518           ggg(1)=xj*fac
5519           ggg(2)=yj*fac
5520           ggg(3)=zj*fac
5521 cgrad          if (j.lt.i) then
5522 cd          write (iout,*) 'j<i'
5523 C Uncomment following three lines for SC-p interactions
5524 c           do k=1,3
5525 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5526 c           enddo
5527 cgrad          else
5528 cd          write (iout,*) 'j>i'
5529 cgrad            do k=1,3
5530 cgrad              ggg(k)=-ggg(k)
5531 C Uncomment following line for SC-p interactions
5532 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5533 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5534 cgrad            enddo
5535 cgrad          endif
5536 cgrad          do k=1,3
5537 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5538 cgrad          enddo
5539 cgrad          kstart=min0(i+1,j)
5540 cgrad          kend=max0(i-1,j-1)
5541 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5542 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5543 cgrad          do k=kstart,kend
5544 cgrad            do l=1,3
5545 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5546 cgrad            enddo
5547 cgrad          enddo
5548           do k=1,3
5549             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5550             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5551           enddo
5552 c        endif !endif for sscale cutoff
5553         enddo ! j
5554
5555         enddo ! iint
5556       enddo ! i
5557 c      enddo !zshift
5558 c      enddo !yshift
5559 c      enddo !xshift
5560       do i=1,nct
5561         do j=1,3
5562           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5563           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5564           gradx_scp(j,i)=expon*gradx_scp(j,i)
5565         enddo
5566       enddo
5567 C******************************************************************************
5568 C
5569 C                              N O T E !!!
5570 C
5571 C To save time the factor EXPON has been extracted from ALL components
5572 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5573 C use!
5574 C
5575 C******************************************************************************
5576       return
5577       end
5578 C--------------------------------------------------------------------------
5579       subroutine edis(ehpb)
5580 C
5581 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5582 C
5583       implicit real*8 (a-h,o-z)
5584       include 'DIMENSIONS'
5585       include 'COMMON.SBRIDGE'
5586       include 'COMMON.CHAIN'
5587       include 'COMMON.DERIV'
5588       include 'COMMON.VAR'
5589       include 'COMMON.INTERACT'
5590       include 'COMMON.IOUNITS'
5591       include 'COMMON.CONTROL'
5592       dimension ggg(3)
5593       ehpb=0.0D0
5594       do i=1,3
5595        ggg(i)=0.0d0
5596       enddo
5597 C      write (iout,*) ,"link_end",link_end,constr_dist
5598 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5599 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5600       if (link_end.eq.0) return
5601       do i=link_start,link_end
5602 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5603 C CA-CA distance used in regularization of structure.
5604         ii=ihpb(i)
5605         jj=jhpb(i)
5606 C iii and jjj point to the residues for which the distance is assigned.
5607         if (ii.gt.nres) then
5608           iii=ii-nres
5609           jjj=jj-nres
5610         else
5611           iii=ii
5612           jjj=jj
5613         endif
5614 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5615 c     &    dhpb(i),dhpb1(i),forcon(i)
5616 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5617 C    distance and angle dependent SS bond potential.
5618 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5619 C     & iabs(itype(jjj)).eq.1) then
5620 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5621 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5622         if (.not.dyn_ss .and. i.le.nss) then
5623 C 15/02/13 CC dynamic SSbond - additional check
5624          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5625      & iabs(itype(jjj)).eq.1) then
5626           call ssbond_ene(iii,jjj,eij)
5627           ehpb=ehpb+2*eij
5628          endif
5629 cd          write (iout,*) "eij",eij
5630 cd   &   ' waga=',waga,' fac=',fac
5631         else if (ii.gt.nres .and. jj.gt.nres) then
5632 c Restraints from contact prediction
5633           dd=dist(ii,jj)
5634           if (constr_dist.eq.11) then
5635             ehpb=ehpb+fordepth(i)**4.0d0
5636      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5637             fac=fordepth(i)**4.0d0
5638      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5639           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5640      &    ehpb,fordepth(i),dd
5641            else
5642           if (dhpb1(i).gt.0.0d0) then
5643             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5644             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5645 c            write (iout,*) "beta nmr",
5646 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5647           else
5648             dd=dist(ii,jj)
5649             rdis=dd-dhpb(i)
5650 C Get the force constant corresponding to this distance.
5651             waga=forcon(i)
5652 C Calculate the contribution to energy.
5653             ehpb=ehpb+waga*rdis*rdis
5654 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5655 C
5656 C Evaluate gradient.
5657 C
5658             fac=waga*rdis/dd
5659           endif
5660           endif
5661           do j=1,3
5662             ggg(j)=fac*(c(j,jj)-c(j,ii))
5663           enddo
5664           do j=1,3
5665             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5666             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5667           enddo
5668           do k=1,3
5669             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5670             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5671           enddo
5672         else
5673 C Calculate the distance between the two points and its difference from the
5674 C target distance.
5675           dd=dist(ii,jj)
5676           if (constr_dist.eq.11) then
5677             ehpb=ehpb+fordepth(i)**4.0d0
5678      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5679             fac=fordepth(i)**4.0d0
5680      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5681           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5682      &    ehpb,fordepth(i),dd
5683            else
5684           if (dhpb1(i).gt.0.0d0) then
5685             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5686             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5687 c            write (iout,*) "alph nmr",
5688 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5689           else
5690             rdis=dd-dhpb(i)
5691 C Get the force constant corresponding to this distance.
5692             waga=forcon(i)
5693 C Calculate the contribution to energy.
5694             ehpb=ehpb+waga*rdis*rdis
5695 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5696 C
5697 C Evaluate gradient.
5698 C
5699             fac=waga*rdis/dd
5700           endif
5701           endif
5702             do j=1,3
5703               ggg(j)=fac*(c(j,jj)-c(j,ii))
5704             enddo
5705 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5706 C If this is a SC-SC distance, we need to calculate the contributions to the
5707 C Cartesian gradient in the SC vectors (ghpbx).
5708           if (iii.lt.ii) then
5709           do j=1,3
5710             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5711             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5712           enddo
5713           endif
5714 cgrad        do j=iii,jjj-1
5715 cgrad          do k=1,3
5716 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5717 cgrad          enddo
5718 cgrad        enddo
5719           do k=1,3
5720             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5721             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5722           enddo
5723         endif
5724       enddo
5725       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5726       return
5727       end
5728 C--------------------------------------------------------------------------
5729       subroutine ssbond_ene(i,j,eij)
5730 C
5731 C Calculate the distance and angle dependent SS-bond potential energy
5732 C using a free-energy function derived based on RHF/6-31G** ab initio
5733 C calculations of diethyl disulfide.
5734 C
5735 C A. Liwo and U. Kozlowska, 11/24/03
5736 C
5737       implicit real*8 (a-h,o-z)
5738       include 'DIMENSIONS'
5739       include 'COMMON.SBRIDGE'
5740       include 'COMMON.CHAIN'
5741       include 'COMMON.DERIV'
5742       include 'COMMON.LOCAL'
5743       include 'COMMON.INTERACT'
5744       include 'COMMON.VAR'
5745       include 'COMMON.IOUNITS'
5746       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5747       itypi=iabs(itype(i))
5748       xi=c(1,nres+i)
5749       yi=c(2,nres+i)
5750       zi=c(3,nres+i)
5751       dxi=dc_norm(1,nres+i)
5752       dyi=dc_norm(2,nres+i)
5753       dzi=dc_norm(3,nres+i)
5754 c      dsci_inv=dsc_inv(itypi)
5755       dsci_inv=vbld_inv(nres+i)
5756       itypj=iabs(itype(j))
5757 c      dscj_inv=dsc_inv(itypj)
5758       dscj_inv=vbld_inv(nres+j)
5759       xj=c(1,nres+j)-xi
5760       yj=c(2,nres+j)-yi
5761       zj=c(3,nres+j)-zi
5762       dxj=dc_norm(1,nres+j)
5763       dyj=dc_norm(2,nres+j)
5764       dzj=dc_norm(3,nres+j)
5765       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5766       rij=dsqrt(rrij)
5767       erij(1)=xj*rij
5768       erij(2)=yj*rij
5769       erij(3)=zj*rij
5770       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5771       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5772       om12=dxi*dxj+dyi*dyj+dzi*dzj
5773       do k=1,3
5774         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5775         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5776       enddo
5777       rij=1.0d0/rij
5778       deltad=rij-d0cm
5779       deltat1=1.0d0-om1
5780       deltat2=1.0d0+om2
5781       deltat12=om2-om1+2.0d0
5782       cosphi=om12-om1*om2
5783       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5784      &  +akct*deltad*deltat12
5785      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5786 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5787 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5788 c     &  " deltat12",deltat12," eij",eij
5789       ed=2*akcm*deltad+akct*deltat12
5790       pom1=akct*deltad
5791       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5792       eom1=-2*akth*deltat1-pom1-om2*pom2
5793       eom2= 2*akth*deltat2+pom1-om1*pom2
5794       eom12=pom2
5795       do k=1,3
5796         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5797         ghpbx(k,i)=ghpbx(k,i)-ggk
5798      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5799      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5800         ghpbx(k,j)=ghpbx(k,j)+ggk
5801      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5802      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5803         ghpbc(k,i)=ghpbc(k,i)-ggk
5804         ghpbc(k,j)=ghpbc(k,j)+ggk
5805       enddo
5806 C
5807 C Calculate the components of the gradient in DC and X
5808 C
5809 cgrad      do k=i,j-1
5810 cgrad        do l=1,3
5811 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5812 cgrad        enddo
5813 cgrad      enddo
5814       return
5815       end
5816 C--------------------------------------------------------------------------
5817       subroutine ebond(estr)
5818 c
5819 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5820 c
5821       implicit real*8 (a-h,o-z)
5822       include 'DIMENSIONS'
5823       include 'COMMON.LOCAL'
5824       include 'COMMON.GEO'
5825       include 'COMMON.INTERACT'
5826       include 'COMMON.DERIV'
5827       include 'COMMON.VAR'
5828       include 'COMMON.CHAIN'
5829       include 'COMMON.IOUNITS'
5830       include 'COMMON.NAMES'
5831       include 'COMMON.FFIELD'
5832       include 'COMMON.CONTROL'
5833       include 'COMMON.SETUP'
5834       double precision u(3),ud(3)
5835       estr=0.0d0
5836       estr1=0.0d0
5837       do i=ibondp_start,ibondp_end
5838         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5839 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5840 c          do j=1,3
5841 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5842 c     &      *dc(j,i-1)/vbld(i)
5843 c          enddo
5844 c          if (energy_dec) write(iout,*)
5845 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5846 c        else
5847 C       Checking if it involves dummy (NH3+ or COO-) group
5848          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5849 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5850         diff = vbld(i)-vbldpDUM
5851          else
5852 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5853         diff = vbld(i)-vbldp0
5854          endif
5855         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5856      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5857         estr=estr+diff*diff
5858         do j=1,3
5859           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5860         enddo
5861 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5862 c        endif
5863       enddo
5864       estr=0.5d0*AKP*estr+estr1
5865 c
5866 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5867 c
5868       do i=ibond_start,ibond_end
5869         iti=iabs(itype(i))
5870         if (iti.ne.10 .and. iti.ne.ntyp1) then
5871           nbi=nbondterm(iti)
5872           if (nbi.eq.1) then
5873             diff=vbld(i+nres)-vbldsc0(1,iti)
5874             if (energy_dec)  write (iout,*)
5875      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5876      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5877             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5878             do j=1,3
5879               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5880             enddo
5881           else
5882             do j=1,nbi
5883               diff=vbld(i+nres)-vbldsc0(j,iti)
5884               ud(j)=aksc(j,iti)*diff
5885               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5886             enddo
5887             uprod=u(1)
5888             do j=2,nbi
5889               uprod=uprod*u(j)
5890             enddo
5891             usum=0.0d0
5892             usumsqder=0.0d0
5893             do j=1,nbi
5894               uprod1=1.0d0
5895               uprod2=1.0d0
5896               do k=1,nbi
5897                 if (k.ne.j) then
5898                   uprod1=uprod1*u(k)
5899                   uprod2=uprod2*u(k)*u(k)
5900                 endif
5901               enddo
5902               usum=usum+uprod1
5903               usumsqder=usumsqder+ud(j)*uprod2
5904             enddo
5905             estr=estr+uprod/usum
5906             do j=1,3
5907              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5908             enddo
5909           endif
5910         endif
5911       enddo
5912       return
5913       end
5914 #ifdef CRYST_THETA
5915 C--------------------------------------------------------------------------
5916       subroutine ebend(etheta,ethetacnstr)
5917 C
5918 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5919 C angles gamma and its derivatives in consecutive thetas and gammas.
5920 C
5921       implicit real*8 (a-h,o-z)
5922       include 'DIMENSIONS'
5923       include 'COMMON.LOCAL'
5924       include 'COMMON.GEO'
5925       include 'COMMON.INTERACT'
5926       include 'COMMON.DERIV'
5927       include 'COMMON.VAR'
5928       include 'COMMON.CHAIN'
5929       include 'COMMON.IOUNITS'
5930       include 'COMMON.NAMES'
5931       include 'COMMON.FFIELD'
5932       include 'COMMON.CONTROL'
5933       include 'COMMON.TORCNSTR'
5934       common /calcthet/ term1,term2,termm,diffak,ratak,
5935      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5936      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5937       double precision y(2),z(2)
5938       delta=0.02d0*pi
5939 c      time11=dexp(-2*time)
5940 c      time12=1.0d0
5941       etheta=0.0D0
5942 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5943       do i=ithet_start,ithet_end
5944         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5945      &  .or.itype(i).eq.ntyp1) cycle
5946 C Zero the energy function and its derivative at 0 or pi.
5947         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5948         it=itype(i-1)
5949         ichir1=isign(1,itype(i-2))
5950         ichir2=isign(1,itype(i))
5951          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5952          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5953          if (itype(i-1).eq.10) then
5954           itype1=isign(10,itype(i-2))
5955           ichir11=isign(1,itype(i-2))
5956           ichir12=isign(1,itype(i-2))
5957           itype2=isign(10,itype(i))
5958           ichir21=isign(1,itype(i))
5959           ichir22=isign(1,itype(i))
5960          endif
5961
5962         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5963 #ifdef OSF
5964           phii=phi(i)
5965           if (phii.ne.phii) phii=150.0
5966 #else
5967           phii=phi(i)
5968 #endif
5969           y(1)=dcos(phii)
5970           y(2)=dsin(phii)
5971         else
5972           y(1)=0.0D0
5973           y(2)=0.0D0
5974         endif
5975         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5976 #ifdef OSF
5977           phii1=phi(i+1)
5978           if (phii1.ne.phii1) phii1=150.0
5979           phii1=pinorm(phii1)
5980           z(1)=cos(phii1)
5981 #else
5982           phii1=phi(i+1)
5983 #endif
5984           z(1)=dcos(phii1)
5985           z(2)=dsin(phii1)
5986         else
5987           z(1)=0.0D0
5988           z(2)=0.0D0
5989         endif
5990 C Calculate the "mean" value of theta from the part of the distribution
5991 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5992 C In following comments this theta will be referred to as t_c.
5993         thet_pred_mean=0.0d0
5994         do k=1,2
5995             athetk=athet(k,it,ichir1,ichir2)
5996             bthetk=bthet(k,it,ichir1,ichir2)
5997           if (it.eq.10) then
5998              athetk=athet(k,itype1,ichir11,ichir12)
5999              bthetk=bthet(k,itype2,ichir21,ichir22)
6000           endif
6001          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6002 c         write(iout,*) 'chuj tu', y(k),z(k)
6003         enddo
6004         dthett=thet_pred_mean*ssd
6005         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6006 C Derivatives of the "mean" values in gamma1 and gamma2.
6007         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6008      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6009          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6010      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6011          if (it.eq.10) then
6012       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6013      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6014         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6015      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6016          endif
6017         if (theta(i).gt.pi-delta) then
6018           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6019      &         E_tc0)
6020           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6021           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6022           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6023      &        E_theta)
6024           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6025      &        E_tc)
6026         else if (theta(i).lt.delta) then
6027           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6028           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6029           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6030      &        E_theta)
6031           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6032           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6033      &        E_tc)
6034         else
6035           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6036      &        E_theta,E_tc)
6037         endif
6038         etheta=etheta+ethetai
6039         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6040      &      'ebend',i,ethetai,theta(i),itype(i)
6041         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6042         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6043         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6044       enddo
6045       ethetacnstr=0.0d0
6046 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6047       do i=ithetaconstr_start,ithetaconstr_end
6048         itheta=itheta_constr(i)
6049         thetiii=theta(itheta)
6050         difi=pinorm(thetiii-theta_constr0(i))
6051         if (difi.gt.theta_drange(i)) then
6052           difi=difi-theta_drange(i)
6053           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6054           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6055      &    +for_thet_constr(i)*difi**3
6056         else if (difi.lt.-drange(i)) then
6057           difi=difi+drange(i)
6058           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6059           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6060      &    +for_thet_constr(i)*difi**3
6061         else
6062           difi=0.0
6063         endif
6064        if (energy_dec) then
6065         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6066      &    i,itheta,rad2deg*thetiii,
6067      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6068      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6069      &    gloc(itheta+nphi-2,icg)
6070         endif
6071       enddo
6072
6073 C Ufff.... We've done all this!!!
6074       return
6075       end
6076 C---------------------------------------------------------------------------
6077       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6078      &     E_tc)
6079       implicit real*8 (a-h,o-z)
6080       include 'DIMENSIONS'
6081       include 'COMMON.LOCAL'
6082       include 'COMMON.IOUNITS'
6083       common /calcthet/ term1,term2,termm,diffak,ratak,
6084      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6085      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6086 C Calculate the contributions to both Gaussian lobes.
6087 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6088 C The "polynomial part" of the "standard deviation" of this part of
6089 C the distributioni.
6090 ccc        write (iout,*) thetai,thet_pred_mean
6091         sig=polthet(3,it)
6092         do j=2,0,-1
6093           sig=sig*thet_pred_mean+polthet(j,it)
6094         enddo
6095 C Derivative of the "interior part" of the "standard deviation of the"
6096 C gamma-dependent Gaussian lobe in t_c.
6097         sigtc=3*polthet(3,it)
6098         do j=2,1,-1
6099           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6100         enddo
6101         sigtc=sig*sigtc
6102 C Set the parameters of both Gaussian lobes of the distribution.
6103 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6104         fac=sig*sig+sigc0(it)
6105         sigcsq=fac+fac
6106         sigc=1.0D0/sigcsq
6107 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6108         sigsqtc=-4.0D0*sigcsq*sigtc
6109 c       print *,i,sig,sigtc,sigsqtc
6110 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6111         sigtc=-sigtc/(fac*fac)
6112 C Following variable is sigma(t_c)**(-2)
6113         sigcsq=sigcsq*sigcsq
6114         sig0i=sig0(it)
6115         sig0inv=1.0D0/sig0i**2
6116         delthec=thetai-thet_pred_mean
6117         delthe0=thetai-theta0i
6118         term1=-0.5D0*sigcsq*delthec*delthec
6119         term2=-0.5D0*sig0inv*delthe0*delthe0
6120 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6121 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6122 C NaNs in taking the logarithm. We extract the largest exponent which is added
6123 C to the energy (this being the log of the distribution) at the end of energy
6124 C term evaluation for this virtual-bond angle.
6125         if (term1.gt.term2) then
6126           termm=term1
6127           term2=dexp(term2-termm)
6128           term1=1.0d0
6129         else
6130           termm=term2
6131           term1=dexp(term1-termm)
6132           term2=1.0d0
6133         endif
6134 C The ratio between the gamma-independent and gamma-dependent lobes of
6135 C the distribution is a Gaussian function of thet_pred_mean too.
6136         diffak=gthet(2,it)-thet_pred_mean
6137         ratak=diffak/gthet(3,it)**2
6138         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6139 C Let's differentiate it in thet_pred_mean NOW.
6140         aktc=ak*ratak
6141 C Now put together the distribution terms to make complete distribution.
6142         termexp=term1+ak*term2
6143         termpre=sigc+ak*sig0i
6144 C Contribution of the bending energy from this theta is just the -log of
6145 C the sum of the contributions from the two lobes and the pre-exponential
6146 C factor. Simple enough, isn't it?
6147         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6148 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6149 C NOW the derivatives!!!
6150 C 6/6/97 Take into account the deformation.
6151         E_theta=(delthec*sigcsq*term1
6152      &       +ak*delthe0*sig0inv*term2)/termexp
6153         E_tc=((sigtc+aktc*sig0i)/termpre
6154      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6155      &       aktc*term2)/termexp)
6156       return
6157       end
6158 c-----------------------------------------------------------------------------
6159       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6160       implicit real*8 (a-h,o-z)
6161       include 'DIMENSIONS'
6162       include 'COMMON.LOCAL'
6163       include 'COMMON.IOUNITS'
6164       common /calcthet/ term1,term2,termm,diffak,ratak,
6165      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6166      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6167       delthec=thetai-thet_pred_mean
6168       delthe0=thetai-theta0i
6169 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6170       t3 = thetai-thet_pred_mean
6171       t6 = t3**2
6172       t9 = term1
6173       t12 = t3*sigcsq
6174       t14 = t12+t6*sigsqtc
6175       t16 = 1.0d0
6176       t21 = thetai-theta0i
6177       t23 = t21**2
6178       t26 = term2
6179       t27 = t21*t26
6180       t32 = termexp
6181       t40 = t32**2
6182       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6183      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6184      & *(-t12*t9-ak*sig0inv*t27)
6185       return
6186       end
6187 #else
6188 C--------------------------------------------------------------------------
6189       subroutine ebend(etheta,ethetacnstr)
6190 C
6191 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6192 C angles gamma and its derivatives in consecutive thetas and gammas.
6193 C ab initio-derived potentials from
6194 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6195 C
6196       implicit real*8 (a-h,o-z)
6197       include 'DIMENSIONS'
6198       include 'COMMON.LOCAL'
6199       include 'COMMON.GEO'
6200       include 'COMMON.INTERACT'
6201       include 'COMMON.DERIV'
6202       include 'COMMON.VAR'
6203       include 'COMMON.CHAIN'
6204       include 'COMMON.IOUNITS'
6205       include 'COMMON.NAMES'
6206       include 'COMMON.FFIELD'
6207       include 'COMMON.CONTROL'
6208       include 'COMMON.TORCNSTR'
6209       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6210      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6211      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6212      & sinph1ph2(maxdouble,maxdouble)
6213       logical lprn /.false./, lprn1 /.false./
6214       etheta=0.0D0
6215       do i=ithet_start,ithet_end
6216 c        print *,i,itype(i-1),itype(i),itype(i-2)
6217         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6218      &  .or.itype(i).eq.ntyp1) cycle
6219 C        print *,i,theta(i)
6220         if (iabs(itype(i+1)).eq.20) iblock=2
6221         if (iabs(itype(i+1)).ne.20) iblock=1
6222         dethetai=0.0d0
6223         dephii=0.0d0
6224         dephii1=0.0d0
6225         theti2=0.5d0*theta(i)
6226         ityp2=ithetyp((itype(i-1)))
6227         do k=1,nntheterm
6228           coskt(k)=dcos(k*theti2)
6229           sinkt(k)=dsin(k*theti2)
6230         enddo
6231 C        print *,ethetai
6232         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6233 #ifdef OSF
6234           phii=phi(i)
6235           if (phii.ne.phii) phii=150.0
6236 #else
6237           phii=phi(i)
6238 #endif
6239           ityp1=ithetyp((itype(i-2)))
6240 C propagation of chirality for glycine type
6241           do k=1,nsingle
6242             cosph1(k)=dcos(k*phii)
6243             sinph1(k)=dsin(k*phii)
6244           enddo
6245         else
6246           phii=0.0d0
6247           do k=1,nsingle
6248           ityp1=ithetyp((itype(i-2)))
6249             cosph1(k)=0.0d0
6250             sinph1(k)=0.0d0
6251           enddo
6252         endif
6253         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6254 #ifdef OSF
6255           phii1=phi(i+1)
6256           if (phii1.ne.phii1) phii1=150.0
6257           phii1=pinorm(phii1)
6258 #else
6259           phii1=phi(i+1)
6260 #endif
6261           ityp3=ithetyp((itype(i)))
6262           do k=1,nsingle
6263             cosph2(k)=dcos(k*phii1)
6264             sinph2(k)=dsin(k*phii1)
6265           enddo
6266         else
6267           phii1=0.0d0
6268           ityp3=ithetyp((itype(i)))
6269           do k=1,nsingle
6270             cosph2(k)=0.0d0
6271             sinph2(k)=0.0d0
6272           enddo
6273         endif
6274         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6275         do k=1,ndouble
6276           do l=1,k-1
6277             ccl=cosph1(l)*cosph2(k-l)
6278             ssl=sinph1(l)*sinph2(k-l)
6279             scl=sinph1(l)*cosph2(k-l)
6280             csl=cosph1(l)*sinph2(k-l)
6281             cosph1ph2(l,k)=ccl-ssl
6282             cosph1ph2(k,l)=ccl+ssl
6283             sinph1ph2(l,k)=scl+csl
6284             sinph1ph2(k,l)=scl-csl
6285           enddo
6286         enddo
6287         if (lprn) then
6288         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6289      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6290         write (iout,*) "coskt and sinkt"
6291         do k=1,nntheterm
6292           write (iout,*) k,coskt(k),sinkt(k)
6293         enddo
6294         endif
6295         do k=1,ntheterm
6296           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6297           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6298      &      *coskt(k)
6299           if (lprn)
6300      &    write (iout,*) "k",k,"
6301      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6302      &     " ethetai",ethetai
6303         enddo
6304         if (lprn) then
6305         write (iout,*) "cosph and sinph"
6306         do k=1,nsingle
6307           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6308         enddo
6309         write (iout,*) "cosph1ph2 and sinph2ph2"
6310         do k=2,ndouble
6311           do l=1,k-1
6312             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6313      &         sinph1ph2(l,k),sinph1ph2(k,l)
6314           enddo
6315         enddo
6316         write(iout,*) "ethetai",ethetai
6317         endif
6318 C       print *,ethetai
6319         do m=1,ntheterm2
6320           do k=1,nsingle
6321             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6322      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6323      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6324      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6325             ethetai=ethetai+sinkt(m)*aux
6326             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6327             dephii=dephii+k*sinkt(m)*(
6328      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6329      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6330             dephii1=dephii1+k*sinkt(m)*(
6331      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6332      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6333             if (lprn)
6334      &      write (iout,*) "m",m," k",k," bbthet",
6335      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6336      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6337      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6338      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6339 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6340           enddo
6341         enddo
6342 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6343 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6344 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6345 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6346         if (lprn)
6347      &  write(iout,*) "ethetai",ethetai
6348 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6349         do m=1,ntheterm3
6350           do k=2,ndouble
6351             do l=1,k-1
6352               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6353      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6354      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6355      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6356               ethetai=ethetai+sinkt(m)*aux
6357               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6358               dephii=dephii+l*sinkt(m)*(
6359      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6360      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6361      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6362      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6363               dephii1=dephii1+(k-l)*sinkt(m)*(
6364      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6365      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6366      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6367      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6368               if (lprn) then
6369               write (iout,*) "m",m," k",k," l",l," ffthet",
6370      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6371      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6372      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6373      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6374      &            " ethetai",ethetai
6375               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6376      &            cosph1ph2(k,l)*sinkt(m),
6377      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6378               endif
6379             enddo
6380           enddo
6381         enddo
6382 10      continue
6383 c        lprn1=.true.
6384 C        print *,ethetai
6385         if (lprn1)
6386      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6387      &   i,theta(i)*rad2deg,phii*rad2deg,
6388      &   phii1*rad2deg,ethetai
6389 c        lprn1=.false.
6390         etheta=etheta+ethetai
6391         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6392         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6393         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6394       enddo
6395 C now constrains
6396       ethetacnstr=0.0d0
6397 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6398       do i=ithetaconstr_start,ithetaconstr_end
6399         itheta=itheta_constr(i)
6400         thetiii=theta(itheta)
6401         difi=pinorm(thetiii-theta_constr0(i))
6402         if (difi.gt.theta_drange(i)) then
6403           difi=difi-theta_drange(i)
6404           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6405           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6406      &    +for_thet_constr(i)*difi**3
6407         else if (difi.lt.-drange(i)) then
6408           difi=difi+drange(i)
6409           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6410           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6411      &    +for_thet_constr(i)*difi**3
6412         else
6413           difi=0.0
6414         endif
6415        if (energy_dec) then
6416         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6417      &    i,itheta,rad2deg*thetiii,
6418      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6419      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6420      &    gloc(itheta+nphi-2,icg)
6421         endif
6422       enddo
6423
6424       return
6425       end
6426 #endif
6427 #ifdef CRYST_SC
6428 c-----------------------------------------------------------------------------
6429       subroutine esc(escloc)
6430 C Calculate the local energy of a side chain and its derivatives in the
6431 C corresponding virtual-bond valence angles THETA and the spherical angles
6432 C ALPHA and OMEGA.
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'COMMON.GEO'
6436       include 'COMMON.LOCAL'
6437       include 'COMMON.VAR'
6438       include 'COMMON.INTERACT'
6439       include 'COMMON.DERIV'
6440       include 'COMMON.CHAIN'
6441       include 'COMMON.IOUNITS'
6442       include 'COMMON.NAMES'
6443       include 'COMMON.FFIELD'
6444       include 'COMMON.CONTROL'
6445       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6446      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6447       common /sccalc/ time11,time12,time112,theti,it,nlobit
6448       delta=0.02d0*pi
6449       escloc=0.0D0
6450 c     write (iout,'(a)') 'ESC'
6451       do i=loc_start,loc_end
6452         it=itype(i)
6453         if (it.eq.ntyp1) cycle
6454         if (it.eq.10) goto 1
6455         nlobit=nlob(iabs(it))
6456 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6457 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6458         theti=theta(i+1)-pipol
6459         x(1)=dtan(theti)
6460         x(2)=alph(i)
6461         x(3)=omeg(i)
6462
6463         if (x(2).gt.pi-delta) then
6464           xtemp(1)=x(1)
6465           xtemp(2)=pi-delta
6466           xtemp(3)=x(3)
6467           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6468           xtemp(2)=pi
6469           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6470           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6471      &        escloci,dersc(2))
6472           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6473      &        ddersc0(1),dersc(1))
6474           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6475      &        ddersc0(3),dersc(3))
6476           xtemp(2)=pi-delta
6477           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6478           xtemp(2)=pi
6479           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6480           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6481      &            dersc0(2),esclocbi,dersc02)
6482           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6483      &            dersc12,dersc01)
6484           call splinthet(x(2),0.5d0*delta,ss,ssd)
6485           dersc0(1)=dersc01
6486           dersc0(2)=dersc02
6487           dersc0(3)=0.0d0
6488           do k=1,3
6489             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6490           enddo
6491           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6492 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6493 c    &             esclocbi,ss,ssd
6494           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6495 c         escloci=esclocbi
6496 c         write (iout,*) escloci
6497         else if (x(2).lt.delta) then
6498           xtemp(1)=x(1)
6499           xtemp(2)=delta
6500           xtemp(3)=x(3)
6501           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6502           xtemp(2)=0.0d0
6503           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6504           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6505      &        escloci,dersc(2))
6506           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6507      &        ddersc0(1),dersc(1))
6508           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6509      &        ddersc0(3),dersc(3))
6510           xtemp(2)=delta
6511           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6512           xtemp(2)=0.0d0
6513           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6514           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6515      &            dersc0(2),esclocbi,dersc02)
6516           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6517      &            dersc12,dersc01)
6518           dersc0(1)=dersc01
6519           dersc0(2)=dersc02
6520           dersc0(3)=0.0d0
6521           call splinthet(x(2),0.5d0*delta,ss,ssd)
6522           do k=1,3
6523             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6524           enddo
6525           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6526 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6527 c    &             esclocbi,ss,ssd
6528           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6529 c         write (iout,*) escloci
6530         else
6531           call enesc(x,escloci,dersc,ddummy,.false.)
6532         endif
6533
6534         escloc=escloc+escloci
6535         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6536      &     'escloc',i,escloci
6537 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6538
6539         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6540      &   wscloc*dersc(1)
6541         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6542         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6543     1   continue
6544       enddo
6545       return
6546       end
6547 C---------------------------------------------------------------------------
6548       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6549       implicit real*8 (a-h,o-z)
6550       include 'DIMENSIONS'
6551       include 'COMMON.GEO'
6552       include 'COMMON.LOCAL'
6553       include 'COMMON.IOUNITS'
6554       common /sccalc/ time11,time12,time112,theti,it,nlobit
6555       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6556       double precision contr(maxlob,-1:1)
6557       logical mixed
6558 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6559         escloc_i=0.0D0
6560         do j=1,3
6561           dersc(j)=0.0D0
6562           if (mixed) ddersc(j)=0.0d0
6563         enddo
6564         x3=x(3)
6565
6566 C Because of periodicity of the dependence of the SC energy in omega we have
6567 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6568 C To avoid underflows, first compute & store the exponents.
6569
6570         do iii=-1,1
6571
6572           x(3)=x3+iii*dwapi
6573
6574           do j=1,nlobit
6575             do k=1,3
6576               z(k)=x(k)-censc(k,j,it)
6577             enddo
6578             do k=1,3
6579               Axk=0.0D0
6580               do l=1,3
6581                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6582               enddo
6583               Ax(k,j,iii)=Axk
6584             enddo
6585             expfac=0.0D0
6586             do k=1,3
6587               expfac=expfac+Ax(k,j,iii)*z(k)
6588             enddo
6589             contr(j,iii)=expfac
6590           enddo ! j
6591
6592         enddo ! iii
6593
6594         x(3)=x3
6595 C As in the case of ebend, we want to avoid underflows in exponentiation and
6596 C subsequent NaNs and INFs in energy calculation.
6597 C Find the largest exponent
6598         emin=contr(1,-1)
6599         do iii=-1,1
6600           do j=1,nlobit
6601             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6602           enddo
6603         enddo
6604         emin=0.5D0*emin
6605 cd      print *,'it=',it,' emin=',emin
6606
6607 C Compute the contribution to SC energy and derivatives
6608         do iii=-1,1
6609
6610           do j=1,nlobit
6611 #ifdef OSF
6612             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6613             if(adexp.ne.adexp) adexp=1.0
6614             expfac=dexp(adexp)
6615 #else
6616             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6617 #endif
6618 cd          print *,'j=',j,' expfac=',expfac
6619             escloc_i=escloc_i+expfac
6620             do k=1,3
6621               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6622             enddo
6623             if (mixed) then
6624               do k=1,3,2
6625                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6626      &            +gaussc(k,2,j,it))*expfac
6627               enddo
6628             endif
6629           enddo
6630
6631         enddo ! iii
6632
6633         dersc(1)=dersc(1)/cos(theti)**2
6634         ddersc(1)=ddersc(1)/cos(theti)**2
6635         ddersc(3)=ddersc(3)
6636
6637         escloci=-(dlog(escloc_i)-emin)
6638         do j=1,3
6639           dersc(j)=dersc(j)/escloc_i
6640         enddo
6641         if (mixed) then
6642           do j=1,3,2
6643             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6644           enddo
6645         endif
6646       return
6647       end
6648 C------------------------------------------------------------------------------
6649       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6650       implicit real*8 (a-h,o-z)
6651       include 'DIMENSIONS'
6652       include 'COMMON.GEO'
6653       include 'COMMON.LOCAL'
6654       include 'COMMON.IOUNITS'
6655       common /sccalc/ time11,time12,time112,theti,it,nlobit
6656       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6657       double precision contr(maxlob)
6658       logical mixed
6659
6660       escloc_i=0.0D0
6661
6662       do j=1,3
6663         dersc(j)=0.0D0
6664       enddo
6665
6666       do j=1,nlobit
6667         do k=1,2
6668           z(k)=x(k)-censc(k,j,it)
6669         enddo
6670         z(3)=dwapi
6671         do k=1,3
6672           Axk=0.0D0
6673           do l=1,3
6674             Axk=Axk+gaussc(l,k,j,it)*z(l)
6675           enddo
6676           Ax(k,j)=Axk
6677         enddo
6678         expfac=0.0D0
6679         do k=1,3
6680           expfac=expfac+Ax(k,j)*z(k)
6681         enddo
6682         contr(j)=expfac
6683       enddo ! j
6684
6685 C As in the case of ebend, we want to avoid underflows in exponentiation and
6686 C subsequent NaNs and INFs in energy calculation.
6687 C Find the largest exponent
6688       emin=contr(1)
6689       do j=1,nlobit
6690         if (emin.gt.contr(j)) emin=contr(j)
6691       enddo
6692       emin=0.5D0*emin
6693
6694 C Compute the contribution to SC energy and derivatives
6695
6696       dersc12=0.0d0
6697       do j=1,nlobit
6698         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6699         escloc_i=escloc_i+expfac
6700         do k=1,2
6701           dersc(k)=dersc(k)+Ax(k,j)*expfac
6702         enddo
6703         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6704      &            +gaussc(1,2,j,it))*expfac
6705         dersc(3)=0.0d0
6706       enddo
6707
6708       dersc(1)=dersc(1)/cos(theti)**2
6709       dersc12=dersc12/cos(theti)**2
6710       escloci=-(dlog(escloc_i)-emin)
6711       do j=1,2
6712         dersc(j)=dersc(j)/escloc_i
6713       enddo
6714       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6715       return
6716       end
6717 #else
6718 c----------------------------------------------------------------------------------
6719       subroutine esc(escloc)
6720 C Calculate the local energy of a side chain and its derivatives in the
6721 C corresponding virtual-bond valence angles THETA and the spherical angles
6722 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6723 C added by Urszula Kozlowska. 07/11/2007
6724 C
6725       implicit real*8 (a-h,o-z)
6726       include 'DIMENSIONS'
6727       include 'COMMON.GEO'
6728       include 'COMMON.LOCAL'
6729       include 'COMMON.VAR'
6730       include 'COMMON.SCROT'
6731       include 'COMMON.INTERACT'
6732       include 'COMMON.DERIV'
6733       include 'COMMON.CHAIN'
6734       include 'COMMON.IOUNITS'
6735       include 'COMMON.NAMES'
6736       include 'COMMON.FFIELD'
6737       include 'COMMON.CONTROL'
6738       include 'COMMON.VECTORS'
6739       double precision x_prime(3),y_prime(3),z_prime(3)
6740      &    , sumene,dsc_i,dp2_i,x(65),
6741      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6742      &    de_dxx,de_dyy,de_dzz,de_dt
6743       double precision s1_t,s1_6_t,s2_t,s2_6_t
6744       double precision
6745      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6746      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6747      & dt_dCi(3),dt_dCi1(3)
6748       common /sccalc/ time11,time12,time112,theti,it,nlobit
6749       delta=0.02d0*pi
6750       escloc=0.0D0
6751       do i=loc_start,loc_end
6752         if (itype(i).eq.ntyp1) cycle
6753         costtab(i+1) =dcos(theta(i+1))
6754         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6755         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6756         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6757         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6758         cosfac=dsqrt(cosfac2)
6759         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6760         sinfac=dsqrt(sinfac2)
6761         it=iabs(itype(i))
6762         if (it.eq.10) goto 1
6763 c
6764 C  Compute the axes of tghe local cartesian coordinates system; store in
6765 c   x_prime, y_prime and z_prime
6766 c
6767         do j=1,3
6768           x_prime(j) = 0.00
6769           y_prime(j) = 0.00
6770           z_prime(j) = 0.00
6771         enddo
6772 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6773 C     &   dc_norm(3,i+nres)
6774         do j = 1,3
6775           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6776           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6777         enddo
6778         do j = 1,3
6779           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6780         enddo
6781 c       write (2,*) "i",i
6782 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6783 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6784 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6785 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6786 c      & " xy",scalar(x_prime(1),y_prime(1)),
6787 c      & " xz",scalar(x_prime(1),z_prime(1)),
6788 c      & " yy",scalar(y_prime(1),y_prime(1)),
6789 c      & " yz",scalar(y_prime(1),z_prime(1)),
6790 c      & " zz",scalar(z_prime(1),z_prime(1))
6791 c
6792 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6793 C to local coordinate system. Store in xx, yy, zz.
6794 c
6795         xx=0.0d0
6796         yy=0.0d0
6797         zz=0.0d0
6798         do j = 1,3
6799           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6800           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6801           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6802         enddo
6803
6804         xxtab(i)=xx
6805         yytab(i)=yy
6806         zztab(i)=zz
6807 C
6808 C Compute the energy of the ith side cbain
6809 C
6810 c        write (2,*) "xx",xx," yy",yy," zz",zz
6811         it=iabs(itype(i))
6812         do j = 1,65
6813           x(j) = sc_parmin(j,it)
6814         enddo
6815 #ifdef CHECK_COORD
6816 Cc diagnostics - remove later
6817         xx1 = dcos(alph(2))
6818         yy1 = dsin(alph(2))*dcos(omeg(2))
6819         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6820         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6821      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6822      &    xx1,yy1,zz1
6823 C,"  --- ", xx_w,yy_w,zz_w
6824 c end diagnostics
6825 #endif
6826         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6827      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6828      &   + x(10)*yy*zz
6829         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6830      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6831      & + x(20)*yy*zz
6832         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6833      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6834      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6835      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6836      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6837      &  +x(40)*xx*yy*zz
6838         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6839      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6840      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6841      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6842      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6843      &  +x(60)*xx*yy*zz
6844         dsc_i   = 0.743d0+x(61)
6845         dp2_i   = 1.9d0+x(62)
6846         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6847      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6848         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6849      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6850         s1=(1+x(63))/(0.1d0 + dscp1)
6851         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6852         s2=(1+x(65))/(0.1d0 + dscp2)
6853         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6854         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6855      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6856 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6857 c     &   sumene4,
6858 c     &   dscp1,dscp2,sumene
6859 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6860         escloc = escloc + sumene
6861 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6862 c     & ,zz,xx,yy
6863 c#define DEBUG
6864 #ifdef DEBUG
6865 C
6866 C This section to check the numerical derivatives of the energy of ith side
6867 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6868 C #define DEBUG in the code to turn it on.
6869 C
6870         write (2,*) "sumene               =",sumene
6871         aincr=1.0d-7
6872         xxsave=xx
6873         xx=xx+aincr
6874         write (2,*) xx,yy,zz
6875         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6876         de_dxx_num=(sumenep-sumene)/aincr
6877         xx=xxsave
6878         write (2,*) "xx+ sumene from enesc=",sumenep
6879         yysave=yy
6880         yy=yy+aincr
6881         write (2,*) xx,yy,zz
6882         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6883         de_dyy_num=(sumenep-sumene)/aincr
6884         yy=yysave
6885         write (2,*) "yy+ sumene from enesc=",sumenep
6886         zzsave=zz
6887         zz=zz+aincr
6888         write (2,*) xx,yy,zz
6889         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6890         de_dzz_num=(sumenep-sumene)/aincr
6891         zz=zzsave
6892         write (2,*) "zz+ sumene from enesc=",sumenep
6893         costsave=cost2tab(i+1)
6894         sintsave=sint2tab(i+1)
6895         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6896         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6897         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6898         de_dt_num=(sumenep-sumene)/aincr
6899         write (2,*) " t+ sumene from enesc=",sumenep
6900         cost2tab(i+1)=costsave
6901         sint2tab(i+1)=sintsave
6902 C End of diagnostics section.
6903 #endif
6904 C
6905 C Compute the gradient of esc
6906 C
6907 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6908         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6909         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6910         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6911         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6912         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6913         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6914         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6915         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6916         pom1=(sumene3*sint2tab(i+1)+sumene1)
6917      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6918         pom2=(sumene4*cost2tab(i+1)+sumene2)
6919      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6920         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6921         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6922      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6923      &  +x(40)*yy*zz
6924         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6925         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6926      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6927      &  +x(60)*yy*zz
6928         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6929      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6930      &        +(pom1+pom2)*pom_dx
6931 #ifdef DEBUG
6932         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6933 #endif
6934 C
6935         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6936         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6937      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6938      &  +x(40)*xx*zz
6939         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6940         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6941      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6942      &  +x(59)*zz**2 +x(60)*xx*zz
6943         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6944      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6945      &        +(pom1-pom2)*pom_dy
6946 #ifdef DEBUG
6947         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6948 #endif
6949 C
6950         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6951      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6952      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6953      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6954      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6955      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6956      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6957      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6958 #ifdef DEBUG
6959         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6960 #endif
6961 C
6962         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6963      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6964      &  +pom1*pom_dt1+pom2*pom_dt2
6965 #ifdef DEBUG
6966         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6967 #endif
6968 c#undef DEBUG
6969 c
6970 C
6971        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6972        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6973        cosfac2xx=cosfac2*xx
6974        sinfac2yy=sinfac2*yy
6975        do k = 1,3
6976          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6977      &      vbld_inv(i+1)
6978          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6979      &      vbld_inv(i)
6980          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6981          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6982 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6983 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6984 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6985 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6986          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6987          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6988          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6989          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6990          dZZ_Ci1(k)=0.0d0
6991          dZZ_Ci(k)=0.0d0
6992          do j=1,3
6993            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6994      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6995            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6996      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6997          enddo
6998
6999          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7000          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7001          dZZ_XYZ(k)=vbld_inv(i+nres)*
7002      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7003 c
7004          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7005          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7006        enddo
7007
7008        do k=1,3
7009          dXX_Ctab(k,i)=dXX_Ci(k)
7010          dXX_C1tab(k,i)=dXX_Ci1(k)
7011          dYY_Ctab(k,i)=dYY_Ci(k)
7012          dYY_C1tab(k,i)=dYY_Ci1(k)
7013          dZZ_Ctab(k,i)=dZZ_Ci(k)
7014          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7015          dXX_XYZtab(k,i)=dXX_XYZ(k)
7016          dYY_XYZtab(k,i)=dYY_XYZ(k)
7017          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7018        enddo
7019
7020        do k = 1,3
7021 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7022 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7023 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7024 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7025 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7026 c     &    dt_dci(k)
7027 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7028 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7029          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7030      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7031          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7032      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7033          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7034      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7035        enddo
7036 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7037 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7038
7039 C to check gradient call subroutine check_grad
7040
7041     1 continue
7042       enddo
7043       return
7044       end
7045 c------------------------------------------------------------------------------
7046       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7047       implicit none
7048       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7049      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7050       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7051      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7052      &   + x(10)*yy*zz
7053       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7054      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7055      & + x(20)*yy*zz
7056       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7057      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7058      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7059      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7060      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7061      &  +x(40)*xx*yy*zz
7062       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7063      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7064      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7065      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7066      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7067      &  +x(60)*xx*yy*zz
7068       dsc_i   = 0.743d0+x(61)
7069       dp2_i   = 1.9d0+x(62)
7070       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7071      &          *(xx*cost2+yy*sint2))
7072       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7073      &          *(xx*cost2-yy*sint2))
7074       s1=(1+x(63))/(0.1d0 + dscp1)
7075       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7076       s2=(1+x(65))/(0.1d0 + dscp2)
7077       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7078       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7079      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7080       enesc=sumene
7081       return
7082       end
7083 #endif
7084 c------------------------------------------------------------------------------
7085       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7086 C
7087 C This procedure calculates two-body contact function g(rij) and its derivative:
7088 C
7089 C           eps0ij                                     !       x < -1
7090 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7091 C            0                                         !       x > 1
7092 C
7093 C where x=(rij-r0ij)/delta
7094 C
7095 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7096 C
7097       implicit none
7098       double precision rij,r0ij,eps0ij,fcont,fprimcont
7099       double precision x,x2,x4,delta
7100 c     delta=0.02D0*r0ij
7101 c      delta=0.2D0*r0ij
7102       x=(rij-r0ij)/delta
7103       if (x.lt.-1.0D0) then
7104         fcont=eps0ij
7105         fprimcont=0.0D0
7106       else if (x.le.1.0D0) then
7107         x2=x*x
7108         x4=x2*x2
7109         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7110         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7111       else
7112         fcont=0.0D0
7113         fprimcont=0.0D0
7114       endif
7115       return
7116       end
7117 c------------------------------------------------------------------------------
7118       subroutine splinthet(theti,delta,ss,ssder)
7119       implicit real*8 (a-h,o-z)
7120       include 'DIMENSIONS'
7121       include 'COMMON.VAR'
7122       include 'COMMON.GEO'
7123       thetup=pi-delta
7124       thetlow=delta
7125       if (theti.gt.pipol) then
7126         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7127       else
7128         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7129         ssder=-ssder
7130       endif
7131       return
7132       end
7133 c------------------------------------------------------------------------------
7134       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7135       implicit none
7136       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7137       double precision ksi,ksi2,ksi3,a1,a2,a3
7138       a1=fprim0*delta/(f1-f0)
7139       a2=3.0d0-2.0d0*a1
7140       a3=a1-2.0d0
7141       ksi=(x-x0)/delta
7142       ksi2=ksi*ksi
7143       ksi3=ksi2*ksi
7144       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7145       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7146       return
7147       end
7148 c------------------------------------------------------------------------------
7149       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7150       implicit none
7151       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7152       double precision ksi,ksi2,ksi3,a1,a2,a3
7153       ksi=(x-x0)/delta
7154       ksi2=ksi*ksi
7155       ksi3=ksi2*ksi
7156       a1=fprim0x*delta
7157       a2=3*(f1x-f0x)-2*fprim0x*delta
7158       a3=fprim0x*delta-2*(f1x-f0x)
7159       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7160       return
7161       end
7162 C-----------------------------------------------------------------------------
7163 #ifdef CRYST_TOR
7164 C-----------------------------------------------------------------------------
7165       subroutine etor(etors,edihcnstr)
7166       implicit real*8 (a-h,o-z)
7167       include 'DIMENSIONS'
7168       include 'COMMON.VAR'
7169       include 'COMMON.GEO'
7170       include 'COMMON.LOCAL'
7171       include 'COMMON.TORSION'
7172       include 'COMMON.INTERACT'
7173       include 'COMMON.DERIV'
7174       include 'COMMON.CHAIN'
7175       include 'COMMON.NAMES'
7176       include 'COMMON.IOUNITS'
7177       include 'COMMON.FFIELD'
7178       include 'COMMON.TORCNSTR'
7179       include 'COMMON.CONTROL'
7180       logical lprn
7181 C Set lprn=.true. for debugging
7182       lprn=.false.
7183 c      lprn=.true.
7184       etors=0.0D0
7185       do i=iphi_start,iphi_end
7186       etors_ii=0.0D0
7187         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7188      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7189         itori=itortyp(itype(i-2))
7190         itori1=itortyp(itype(i-1))
7191         phii=phi(i)
7192         gloci=0.0D0
7193 C Proline-Proline pair is a special case...
7194         if (itori.eq.3 .and. itori1.eq.3) then
7195           if (phii.gt.-dwapi3) then
7196             cosphi=dcos(3*phii)
7197             fac=1.0D0/(1.0D0-cosphi)
7198             etorsi=v1(1,3,3)*fac
7199             etorsi=etorsi+etorsi
7200             etors=etors+etorsi-v1(1,3,3)
7201             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7202             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7203           endif
7204           do j=1,3
7205             v1ij=v1(j+1,itori,itori1)
7206             v2ij=v2(j+1,itori,itori1)
7207             cosphi=dcos(j*phii)
7208             sinphi=dsin(j*phii)
7209             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7210             if (energy_dec) etors_ii=etors_ii+
7211      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7212             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7213           enddo
7214         else
7215           do j=1,nterm_old
7216             v1ij=v1(j,itori,itori1)
7217             v2ij=v2(j,itori,itori1)
7218             cosphi=dcos(j*phii)
7219             sinphi=dsin(j*phii)
7220             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7221             if (energy_dec) etors_ii=etors_ii+
7222      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7223             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7224           enddo
7225         endif
7226         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7227              'etor',i,etors_ii
7228         if (lprn)
7229      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7230      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7231      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7232         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7233 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7234       enddo
7235 ! 6/20/98 - dihedral angle constraints
7236       edihcnstr=0.0d0
7237       do i=1,ndih_constr
7238         itori=idih_constr(i)
7239         phii=phi(itori)
7240         difi=phii-phi0(i)
7241         if (difi.gt.drange(i)) then
7242           difi=difi-drange(i)
7243           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7244           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7245         else if (difi.lt.-drange(i)) then
7246           difi=difi+drange(i)
7247           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7248           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7249         endif
7250 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7251 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7252       enddo
7253 !      write (iout,*) 'edihcnstr',edihcnstr
7254       return
7255       end
7256 c------------------------------------------------------------------------------
7257       subroutine etor_d(etors_d)
7258       etors_d=0.0d0
7259       return
7260       end
7261 c----------------------------------------------------------------------------
7262 #else
7263       subroutine etor(etors,edihcnstr)
7264       implicit real*8 (a-h,o-z)
7265       include 'DIMENSIONS'
7266       include 'COMMON.VAR'
7267       include 'COMMON.GEO'
7268       include 'COMMON.LOCAL'
7269       include 'COMMON.TORSION'
7270       include 'COMMON.INTERACT'
7271       include 'COMMON.DERIV'
7272       include 'COMMON.CHAIN'
7273       include 'COMMON.NAMES'
7274       include 'COMMON.IOUNITS'
7275       include 'COMMON.FFIELD'
7276       include 'COMMON.TORCNSTR'
7277       include 'COMMON.CONTROL'
7278       logical lprn
7279 C Set lprn=.true. for debugging
7280       lprn=.false.
7281 c     lprn=.true.
7282       etors=0.0D0
7283       do i=iphi_start,iphi_end
7284 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7285 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7286 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7287 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7288         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7289      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7290 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7291 C For introducing the NH3+ and COO- group please check the etor_d for reference
7292 C and guidance
7293         etors_ii=0.0D0
7294          if (iabs(itype(i)).eq.20) then
7295          iblock=2
7296          else
7297          iblock=1
7298          endif
7299         itori=itortyp(itype(i-2))
7300         itori1=itortyp(itype(i-1))
7301         phii=phi(i)
7302         gloci=0.0D0
7303 C Regular cosine and sine terms
7304         do j=1,nterm(itori,itori1,iblock)
7305           v1ij=v1(j,itori,itori1,iblock)
7306           v2ij=v2(j,itori,itori1,iblock)
7307           cosphi=dcos(j*phii)
7308           sinphi=dsin(j*phii)
7309           etors=etors+v1ij*cosphi+v2ij*sinphi
7310           if (energy_dec) etors_ii=etors_ii+
7311      &                v1ij*cosphi+v2ij*sinphi
7312           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7313         enddo
7314 C Lorentz terms
7315 C                         v1
7316 C  E = SUM ----------------------------------- - v1
7317 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7318 C
7319         cosphi=dcos(0.5d0*phii)
7320         sinphi=dsin(0.5d0*phii)
7321         do j=1,nlor(itori,itori1,iblock)
7322           vl1ij=vlor1(j,itori,itori1)
7323           vl2ij=vlor2(j,itori,itori1)
7324           vl3ij=vlor3(j,itori,itori1)
7325           pom=vl2ij*cosphi+vl3ij*sinphi
7326           pom1=1.0d0/(pom*pom+1.0d0)
7327           etors=etors+vl1ij*pom1
7328           if (energy_dec) etors_ii=etors_ii+
7329      &                vl1ij*pom1
7330           pom=-pom*pom1*pom1
7331           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7332         enddo
7333 C Subtract the constant term
7334         etors=etors-v0(itori,itori1,iblock)
7335           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7336      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7337         if (lprn)
7338      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7339      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7340      &  (v1(j,itori,itori1,iblock),j=1,6),
7341      &  (v2(j,itori,itori1,iblock),j=1,6)
7342         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7343 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7344       enddo
7345 ! 6/20/98 - dihedral angle constraints
7346       edihcnstr=0.0d0
7347 c      do i=1,ndih_constr
7348       do i=idihconstr_start,idihconstr_end
7349         itori=idih_constr(i)
7350         phii=phi(itori)
7351         difi=pinorm(phii-phi0(i))
7352         if (difi.gt.drange(i)) then
7353           difi=difi-drange(i)
7354           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7355           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7356         else if (difi.lt.-drange(i)) then
7357           difi=difi+drange(i)
7358           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7359           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7360         else
7361           difi=0.0
7362         endif
7363        if (energy_dec) then
7364         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7365      &    i,itori,rad2deg*phii,
7366      &    rad2deg*phi0(i),  rad2deg*drange(i),
7367      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7368         endif
7369       enddo
7370 cd       write (iout,*) 'edihcnstr',edihcnstr
7371       return
7372       end
7373 c----------------------------------------------------------------------------
7374       subroutine etor_d(etors_d)
7375 C 6/23/01 Compute double torsional energy
7376       implicit real*8 (a-h,o-z)
7377       include 'DIMENSIONS'
7378       include 'COMMON.VAR'
7379       include 'COMMON.GEO'
7380       include 'COMMON.LOCAL'
7381       include 'COMMON.TORSION'
7382       include 'COMMON.INTERACT'
7383       include 'COMMON.DERIV'
7384       include 'COMMON.CHAIN'
7385       include 'COMMON.NAMES'
7386       include 'COMMON.IOUNITS'
7387       include 'COMMON.FFIELD'
7388       include 'COMMON.TORCNSTR'
7389       logical lprn
7390 C Set lprn=.true. for debugging
7391       lprn=.false.
7392 c     lprn=.true.
7393       etors_d=0.0D0
7394 c      write(iout,*) "a tu??"
7395       do i=iphid_start,iphid_end
7396 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7397 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7398 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7399 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7400 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7401          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7402      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7403      &  (itype(i+1).eq.ntyp1)) cycle
7404 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7405         itori=itortyp(itype(i-2))
7406         itori1=itortyp(itype(i-1))
7407         itori2=itortyp(itype(i))
7408         phii=phi(i)
7409         phii1=phi(i+1)
7410         gloci1=0.0D0
7411         gloci2=0.0D0
7412         iblock=1
7413         if (iabs(itype(i+1)).eq.20) iblock=2
7414 C Iblock=2 Proline type
7415 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7416 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7417 C        if (itype(i+1).eq.ntyp1) iblock=3
7418 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7419 C IS or IS NOT need for this
7420 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7421 C        is (itype(i-3).eq.ntyp1) ntblock=2
7422 C        ntblock is N-terminal blocking group
7423
7424 C Regular cosine and sine terms
7425         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7426 C Example of changes for NH3+ blocking group
7427 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7428 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7429           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7430           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7431           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7432           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7433           cosphi1=dcos(j*phii)
7434           sinphi1=dsin(j*phii)
7435           cosphi2=dcos(j*phii1)
7436           sinphi2=dsin(j*phii1)
7437           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7438      &     v2cij*cosphi2+v2sij*sinphi2
7439           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7440           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7441         enddo
7442         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7443           do l=1,k-1
7444             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7445             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7446             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7447             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7448             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7449             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7450             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7451             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7452             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7453      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7454             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7455      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7456             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7457      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7458           enddo
7459         enddo
7460         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7461         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7462       enddo
7463       return
7464       end
7465 #endif
7466 C----------------------------------------------------------------------------------
7467 C The rigorous attempt to derive energy function
7468       subroutine etor_kcc(etors,edihcnstr)
7469       implicit real*8 (a-h,o-z)
7470       include 'DIMENSIONS'
7471       include 'COMMON.VAR'
7472       include 'COMMON.GEO'
7473       include 'COMMON.LOCAL'
7474       include 'COMMON.TORSION'
7475       include 'COMMON.INTERACT'
7476       include 'COMMON.DERIV'
7477       include 'COMMON.CHAIN'
7478       include 'COMMON.NAMES'
7479       include 'COMMON.IOUNITS'
7480       include 'COMMON.FFIELD'
7481       include 'COMMON.TORCNSTR'
7482       include 'COMMON.CONTROL'
7483       logical lprn
7484 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7485 C Set lprn=.true. for debugging
7486       lprn=.false.
7487 c     lprn=.true.
7488 C      print *,"wchodze kcc"
7489       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7490       if (tor_mode.ne.2) then
7491       etors=0.0D0
7492       endif
7493       do i=iphi_start,iphi_end
7494 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7495 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7496 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7497 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7498         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7499      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7500         itori=itortyp_kcc(itype(i-2))
7501         itori1=itortyp_kcc(itype(i-1))
7502         phii=phi(i)
7503         glocig=0.0D0
7504         glocit1=0.0d0
7505         glocit2=0.0d0
7506         sumnonchebyshev=0.0d0
7507         sumchebyshev=0.0d0
7508 C to avoid multiple devision by 2
7509 c        theti22=0.5d0*theta(i)
7510 C theta 12 is the theta_1 /2
7511 C theta 22 is theta_2 /2
7512 c        theti12=0.5d0*theta(i-1)
7513 C and appropriate sinus function
7514         sinthet1=dsin(theta(i-1))
7515         sinthet2=dsin(theta(i))
7516         costhet1=dcos(theta(i-1))
7517         costhet2=dcos(theta(i))
7518 c Cosines of halves thetas
7519         costheti12=0.5d0*(1.0d0+costhet1)
7520         costheti22=0.5d0*(1.0d0+costhet2)
7521 C to speed up lets store its mutliplication
7522         sint1t2=sinthet2*sinthet1
7523         sint1t2n=1.0d0
7524 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7525 C +d_n*sin(n*gamma)) *
7526 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7527 C we have two sum 1) Non-Chebyshev which is with n and gamma
7528         etori=0.0d0
7529         do j=1,nterm_kcc(itori,itori1)
7530
7531           nval=nterm_kcc_Tb(itori,itori1)
7532           v1ij=v1_kcc(j,itori,itori1)
7533           v2ij=v2_kcc(j,itori,itori1)
7534 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7535 C v1ij is c_n and d_n in euation above
7536           cosphi=dcos(j*phii)
7537           sinphi=dsin(j*phii)
7538           sint1t2n1=sint1t2n
7539           sint1t2n=sint1t2n*sint1t2
7540           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7541      &        costheti12)
7542           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7543      &        v11_chyb(1,j,itori,itori1),costheti12)
7544 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7545 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7546           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7547      &        costheti22)
7548           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7549      &        v21_chyb(1,j,itori,itori1),costheti22)
7550 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7551 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7552           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7553      &        costheti12)
7554           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7555      &        v12_chyb(1,j,itori,itori1),costheti12)
7556 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7557 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7558           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7559      &        costheti22)
7560           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7561      &        v22_chyb(1,j,itori,itori1),costheti22)
7562 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7563 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7564 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7565 C          if (energy_dec) etors_ii=etors_ii+
7566 C     &                v1ij*cosphi+v2ij*sinphi
7567 C glocig is the gradient local i site in gamma
7568           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7569           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7570           etori=etori+sint1t2n*(actval1+actval2)
7571           glocig=glocig+
7572      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7573      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7574 C now gradient over theta_1
7575           glocit1=glocit1+
7576      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7577      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7578           glocit2=glocit2+
7579      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7580      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7581
7582 C now the Czebyshev polinominal sum
7583 c        do k=1,nterm_kcc_Tb(itori,itori1)
7584 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7585 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7586 C         thybt1(k)=0.0
7587 C         thybt2(k)=0.0
7588 c        enddo
7589 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7590 C     &         gradtschebyshev
7591 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7592 C     &         dcos(theti22)**2),
7593 C     &         dsin(theti22)
7594
7595 C now overal sumation
7596 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7597         enddo ! j
7598         etors=etors+etori
7599 C derivative over gamma
7600         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7601 C derivative over theta1
7602         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7603 C now derivative over theta2
7604         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7605         if (lprn)
7606      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7607      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7608       enddo
7609 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7610 ! 6/20/98 - dihedral angle constraints
7611       if (tor_mode.ne.2) then
7612       edihcnstr=0.0d0
7613 c      do i=1,ndih_constr
7614       do i=idihconstr_start,idihconstr_end
7615         itori=idih_constr(i)
7616         phii=phi(itori)
7617         difi=pinorm(phii-phi0(i))
7618         if (difi.gt.drange(i)) then
7619           difi=difi-drange(i)
7620           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7621           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7622         else if (difi.lt.-drange(i)) then
7623           difi=difi+drange(i)
7624           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7625           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7626         else
7627           difi=0.0
7628         endif
7629        enddo
7630        endif
7631       return
7632       end
7633
7634 C The rigorous attempt to derive energy function
7635       subroutine ebend_kcc(etheta,ethetacnstr)
7636
7637       implicit real*8 (a-h,o-z)
7638       include 'DIMENSIONS'
7639       include 'COMMON.VAR'
7640       include 'COMMON.GEO'
7641       include 'COMMON.LOCAL'
7642       include 'COMMON.TORSION'
7643       include 'COMMON.INTERACT'
7644       include 'COMMON.DERIV'
7645       include 'COMMON.CHAIN'
7646       include 'COMMON.NAMES'
7647       include 'COMMON.IOUNITS'
7648       include 'COMMON.FFIELD'
7649       include 'COMMON.TORCNSTR'
7650       include 'COMMON.CONTROL'
7651       logical lprn
7652       double precision thybt1(maxtermkcc)
7653 C Set lprn=.true. for debugging
7654       lprn=.false.
7655 c     lprn=.true.
7656 C      print *,"wchodze kcc"
7657       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7658       if (tor_mode.ne.2) etheta=0.0D0
7659       do i=ithet_start,ithet_end
7660 c        print *,i,itype(i-1),itype(i),itype(i-2)
7661         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7662      &  .or.itype(i).eq.ntyp1) cycle
7663          iti=itortyp_kcc(itype(i-1))
7664         sinthet=dsin(theta(i)/2.0d0)
7665         costhet=dcos(theta(i)/2.0d0)
7666          do j=1,nbend_kcc_Tb(iti)
7667           thybt1(j)=v1bend_chyb(j,iti)
7668          enddo
7669          sumth1thyb=tschebyshev
7670      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7671         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7672      &    sumth1thyb
7673         ihelp=nbend_kcc_Tb(iti)-1
7674         gradthybt1=gradtschebyshev
7675      &         (0,ihelp,thybt1(1),costhet)
7676         etheta=etheta+sumth1thyb
7677 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7678         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7679      &   gradthybt1*sinthet*(-0.5d0)
7680       enddo
7681       if (tor_mode.ne.2) then
7682       ethetacnstr=0.0d0
7683 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7684       do i=ithetaconstr_start,ithetaconstr_end
7685         itheta=itheta_constr(i)
7686         thetiii=theta(itheta)
7687         difi=pinorm(thetiii-theta_constr0(i))
7688         if (difi.gt.theta_drange(i)) then
7689           difi=difi-theta_drange(i)
7690           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7691           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7692      &    +for_thet_constr(i)*difi**3
7693         else if (difi.lt.-drange(i)) then
7694           difi=difi+drange(i)
7695           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7696           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7697      &    +for_thet_constr(i)*difi**3
7698         else
7699           difi=0.0
7700         endif
7701        if (energy_dec) then
7702         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7703      &    i,itheta,rad2deg*thetiii,
7704      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7705      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7706      &    gloc(itheta+nphi-2,icg)
7707         endif
7708       enddo
7709       endif
7710       return
7711       end
7712 c------------------------------------------------------------------------------
7713       subroutine eback_sc_corr(esccor)
7714 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7715 c        conformational states; temporarily implemented as differences
7716 c        between UNRES torsional potentials (dependent on three types of
7717 c        residues) and the torsional potentials dependent on all 20 types
7718 c        of residues computed from AM1  energy surfaces of terminally-blocked
7719 c        amino-acid residues.
7720       implicit real*8 (a-h,o-z)
7721       include 'DIMENSIONS'
7722       include 'COMMON.VAR'
7723       include 'COMMON.GEO'
7724       include 'COMMON.LOCAL'
7725       include 'COMMON.TORSION'
7726       include 'COMMON.SCCOR'
7727       include 'COMMON.INTERACT'
7728       include 'COMMON.DERIV'
7729       include 'COMMON.CHAIN'
7730       include 'COMMON.NAMES'
7731       include 'COMMON.IOUNITS'
7732       include 'COMMON.FFIELD'
7733       include 'COMMON.CONTROL'
7734       logical lprn
7735 C Set lprn=.true. for debugging
7736       lprn=.false.
7737 c      lprn=.true.
7738 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7739       esccor=0.0D0
7740       do i=itau_start,itau_end
7741         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7742         esccor_ii=0.0D0
7743         isccori=isccortyp(itype(i-2))
7744         isccori1=isccortyp(itype(i-1))
7745 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7746         phii=phi(i)
7747         do intertyp=1,3 !intertyp
7748 cc Added 09 May 2012 (Adasko)
7749 cc  Intertyp means interaction type of backbone mainchain correlation:
7750 c   1 = SC...Ca...Ca...Ca
7751 c   2 = Ca...Ca...Ca...SC
7752 c   3 = SC...Ca...Ca...SCi
7753         gloci=0.0D0
7754         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7755      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7756      &      (itype(i-1).eq.ntyp1)))
7757      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7758      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7759      &     .or.(itype(i).eq.ntyp1)))
7760      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7761      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7762      &      (itype(i-3).eq.ntyp1)))) cycle
7763         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7764         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7765      & cycle
7766        do j=1,nterm_sccor(isccori,isccori1)
7767           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7768           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7769           cosphi=dcos(j*tauangle(intertyp,i))
7770           sinphi=dsin(j*tauangle(intertyp,i))
7771           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7772           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7773         enddo
7774 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7775         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7776         if (lprn)
7777      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7778      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7779      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7780      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7781         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7782        enddo !intertyp
7783       enddo
7784
7785       return
7786       end
7787 c----------------------------------------------------------------------------
7788       subroutine multibody(ecorr)
7789 C This subroutine calculates multi-body contributions to energy following
7790 C the idea of Skolnick et al. If side chains I and J make a contact and
7791 C at the same time side chains I+1 and J+1 make a contact, an extra
7792 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7793       implicit real*8 (a-h,o-z)
7794       include 'DIMENSIONS'
7795       include 'COMMON.IOUNITS'
7796       include 'COMMON.DERIV'
7797       include 'COMMON.INTERACT'
7798       include 'COMMON.CONTACTS'
7799       double precision gx(3),gx1(3)
7800       logical lprn
7801
7802 C Set lprn=.true. for debugging
7803       lprn=.false.
7804
7805       if (lprn) then
7806         write (iout,'(a)') 'Contact function values:'
7807         do i=nnt,nct-2
7808           write (iout,'(i2,20(1x,i2,f10.5))')
7809      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7810         enddo
7811       endif
7812       ecorr=0.0D0
7813       do i=nnt,nct
7814         do j=1,3
7815           gradcorr(j,i)=0.0D0
7816           gradxorr(j,i)=0.0D0
7817         enddo
7818       enddo
7819       do i=nnt,nct-2
7820
7821         DO ISHIFT = 3,4
7822
7823         i1=i+ishift
7824         num_conti=num_cont(i)
7825         num_conti1=num_cont(i1)
7826         do jj=1,num_conti
7827           j=jcont(jj,i)
7828           do kk=1,num_conti1
7829             j1=jcont(kk,i1)
7830             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7831 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7832 cd   &                   ' ishift=',ishift
7833 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7834 C The system gains extra energy.
7835               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7836             endif   ! j1==j+-ishift
7837           enddo     ! kk
7838         enddo       ! jj
7839
7840         ENDDO ! ISHIFT
7841
7842       enddo         ! i
7843       return
7844       end
7845 c------------------------------------------------------------------------------
7846       double precision function esccorr(i,j,k,l,jj,kk)
7847       implicit real*8 (a-h,o-z)
7848       include 'DIMENSIONS'
7849       include 'COMMON.IOUNITS'
7850       include 'COMMON.DERIV'
7851       include 'COMMON.INTERACT'
7852       include 'COMMON.CONTACTS'
7853       include 'COMMON.SHIELD'
7854       double precision gx(3),gx1(3)
7855       logical lprn
7856       lprn=.false.
7857       eij=facont(jj,i)
7858       ekl=facont(kk,k)
7859 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7860 C Calculate the multi-body contribution to energy.
7861 C Calculate multi-body contributions to the gradient.
7862 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7863 cd   & k,l,(gacont(m,kk,k),m=1,3)
7864       do m=1,3
7865         gx(m) =ekl*gacont(m,jj,i)
7866         gx1(m)=eij*gacont(m,kk,k)
7867         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7868         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7869         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7870         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7871       enddo
7872       do m=i,j-1
7873         do ll=1,3
7874           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7875         enddo
7876       enddo
7877       do m=k,l-1
7878         do ll=1,3
7879           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7880         enddo
7881       enddo
7882       esccorr=-eij*ekl
7883       return
7884       end
7885 c------------------------------------------------------------------------------
7886       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7887 C This subroutine calculates multi-body contributions to hydrogen-bonding
7888       implicit real*8 (a-h,o-z)
7889       include 'DIMENSIONS'
7890       include 'COMMON.IOUNITS'
7891 #ifdef MPI
7892       include "mpif.h"
7893       parameter (max_cont=maxconts)
7894       parameter (max_dim=26)
7895       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7896       double precision zapas(max_dim,maxconts,max_fg_procs),
7897      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7898       common /przechowalnia/ zapas
7899       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7900      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7901 #endif
7902       include 'COMMON.SETUP'
7903       include 'COMMON.FFIELD'
7904       include 'COMMON.DERIV'
7905       include 'COMMON.INTERACT'
7906       include 'COMMON.CONTACTS'
7907       include 'COMMON.CONTROL'
7908       include 'COMMON.LOCAL'
7909       double precision gx(3),gx1(3),time00
7910       logical lprn,ldone
7911
7912 C Set lprn=.true. for debugging
7913       lprn=.false.
7914 #ifdef MPI
7915       n_corr=0
7916       n_corr1=0
7917       if (nfgtasks.le.1) goto 30
7918       if (lprn) then
7919         write (iout,'(a)') 'Contact function values before RECEIVE:'
7920         do i=nnt,nct-2
7921           write (iout,'(2i3,50(1x,i2,f5.2))')
7922      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7923      &    j=1,num_cont_hb(i))
7924         enddo
7925       endif
7926       call flush(iout)
7927       do i=1,ntask_cont_from
7928         ncont_recv(i)=0
7929       enddo
7930       do i=1,ntask_cont_to
7931         ncont_sent(i)=0
7932       enddo
7933 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7934 c     & ntask_cont_to
7935 C Make the list of contacts to send to send to other procesors
7936 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7937 c      call flush(iout)
7938       do i=iturn3_start,iturn3_end
7939 c        write (iout,*) "make contact list turn3",i," num_cont",
7940 c     &    num_cont_hb(i)
7941         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7942       enddo
7943       do i=iturn4_start,iturn4_end
7944 c        write (iout,*) "make contact list turn4",i," num_cont",
7945 c     &   num_cont_hb(i)
7946         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7947       enddo
7948       do ii=1,nat_sent
7949         i=iat_sent(ii)
7950 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7951 c     &    num_cont_hb(i)
7952         do j=1,num_cont_hb(i)
7953         do k=1,4
7954           jjc=jcont_hb(j,i)
7955           iproc=iint_sent_local(k,jjc,ii)
7956 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7957           if (iproc.gt.0) then
7958             ncont_sent(iproc)=ncont_sent(iproc)+1
7959             nn=ncont_sent(iproc)
7960             zapas(1,nn,iproc)=i
7961             zapas(2,nn,iproc)=jjc
7962             zapas(3,nn,iproc)=facont_hb(j,i)
7963             zapas(4,nn,iproc)=ees0p(j,i)
7964             zapas(5,nn,iproc)=ees0m(j,i)
7965             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7966             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7967             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7968             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7969             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7970             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7971             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7972             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7973             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7974             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7975             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7976             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7977             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7978             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7979             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7980             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7981             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7982             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7983             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7984             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7985             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7986           endif
7987         enddo
7988         enddo
7989       enddo
7990       if (lprn) then
7991       write (iout,*)
7992      &  "Numbers of contacts to be sent to other processors",
7993      &  (ncont_sent(i),i=1,ntask_cont_to)
7994       write (iout,*) "Contacts sent"
7995       do ii=1,ntask_cont_to
7996         nn=ncont_sent(ii)
7997         iproc=itask_cont_to(ii)
7998         write (iout,*) nn," contacts to processor",iproc,
7999      &   " of CONT_TO_COMM group"
8000         do i=1,nn
8001           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8002         enddo
8003       enddo
8004       call flush(iout)
8005       endif
8006       CorrelType=477
8007       CorrelID=fg_rank+1
8008       CorrelType1=478
8009       CorrelID1=nfgtasks+fg_rank+1
8010       ireq=0
8011 C Receive the numbers of needed contacts from other processors
8012       do ii=1,ntask_cont_from
8013         iproc=itask_cont_from(ii)
8014         ireq=ireq+1
8015         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8016      &    FG_COMM,req(ireq),IERR)
8017       enddo
8018 c      write (iout,*) "IRECV ended"
8019 c      call flush(iout)
8020 C Send the number of contacts needed by other processors
8021       do ii=1,ntask_cont_to
8022         iproc=itask_cont_to(ii)
8023         ireq=ireq+1
8024         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8025      &    FG_COMM,req(ireq),IERR)
8026       enddo
8027 c      write (iout,*) "ISEND ended"
8028 c      write (iout,*) "number of requests (nn)",ireq
8029       call flush(iout)
8030       if (ireq.gt.0)
8031      &  call MPI_Waitall(ireq,req,status_array,ierr)
8032 c      write (iout,*)
8033 c     &  "Numbers of contacts to be received from other processors",
8034 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8035 c      call flush(iout)
8036 C Receive contacts
8037       ireq=0
8038       do ii=1,ntask_cont_from
8039         iproc=itask_cont_from(ii)
8040         nn=ncont_recv(ii)
8041 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8042 c     &   " of CONT_TO_COMM group"
8043         call flush(iout)
8044         if (nn.gt.0) then
8045           ireq=ireq+1
8046           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8047      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8048 c          write (iout,*) "ireq,req",ireq,req(ireq)
8049         endif
8050       enddo
8051 C Send the contacts to processors that need them
8052       do ii=1,ntask_cont_to
8053         iproc=itask_cont_to(ii)
8054         nn=ncont_sent(ii)
8055 c        write (iout,*) nn," contacts to processor",iproc,
8056 c     &   " of CONT_TO_COMM group"
8057         if (nn.gt.0) then
8058           ireq=ireq+1
8059           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8060      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8061 c          write (iout,*) "ireq,req",ireq,req(ireq)
8062 c          do i=1,nn
8063 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8064 c          enddo
8065         endif
8066       enddo
8067 c      write (iout,*) "number of requests (contacts)",ireq
8068 c      write (iout,*) "req",(req(i),i=1,4)
8069 c      call flush(iout)
8070       if (ireq.gt.0)
8071      & call MPI_Waitall(ireq,req,status_array,ierr)
8072       do iii=1,ntask_cont_from
8073         iproc=itask_cont_from(iii)
8074         nn=ncont_recv(iii)
8075         if (lprn) then
8076         write (iout,*) "Received",nn," contacts from processor",iproc,
8077      &   " of CONT_FROM_COMM group"
8078         call flush(iout)
8079         do i=1,nn
8080           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8081         enddo
8082         call flush(iout)
8083         endif
8084         do i=1,nn
8085           ii=zapas_recv(1,i,iii)
8086 c Flag the received contacts to prevent double-counting
8087           jj=-zapas_recv(2,i,iii)
8088 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8089 c          call flush(iout)
8090           nnn=num_cont_hb(ii)+1
8091           num_cont_hb(ii)=nnn
8092           jcont_hb(nnn,ii)=jj
8093           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8094           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8095           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8096           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8097           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8098           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8099           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8100           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8101           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8102           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8103           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8104           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8105           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8106           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8107           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8108           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8109           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8110           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8111           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8112           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8113           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8114           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8115           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8116           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8117         enddo
8118       enddo
8119       call flush(iout)
8120       if (lprn) then
8121         write (iout,'(a)') 'Contact function values after receive:'
8122         do i=nnt,nct-2
8123           write (iout,'(2i3,50(1x,i3,f5.2))')
8124      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8125      &    j=1,num_cont_hb(i))
8126         enddo
8127         call flush(iout)
8128       endif
8129    30 continue
8130 #endif
8131       if (lprn) then
8132         write (iout,'(a)') 'Contact function values:'
8133         do i=nnt,nct-2
8134           write (iout,'(2i3,50(1x,i3,f5.2))')
8135      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8136      &    j=1,num_cont_hb(i))
8137         enddo
8138       endif
8139       ecorr=0.0D0
8140 C Remove the loop below after debugging !!!
8141       do i=nnt,nct
8142         do j=1,3
8143           gradcorr(j,i)=0.0D0
8144           gradxorr(j,i)=0.0D0
8145         enddo
8146       enddo
8147 C Calculate the local-electrostatic correlation terms
8148       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8149         i1=i+1
8150         num_conti=num_cont_hb(i)
8151         num_conti1=num_cont_hb(i+1)
8152         do jj=1,num_conti
8153           j=jcont_hb(jj,i)
8154           jp=iabs(j)
8155           do kk=1,num_conti1
8156             j1=jcont_hb(kk,i1)
8157             jp1=iabs(j1)
8158 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8159 c     &         ' jj=',jj,' kk=',kk
8160             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8161      &          .or. j.lt.0 .and. j1.gt.0) .and.
8162      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8163 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8164 C The system gains extra energy.
8165               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8166               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8167      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8168               n_corr=n_corr+1
8169             else if (j1.eq.j) then
8170 C Contacts I-J and I-(J+1) occur simultaneously.
8171 C The system loses extra energy.
8172 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8173             endif
8174           enddo ! kk
8175           do kk=1,num_conti
8176             j1=jcont_hb(kk,i)
8177 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8178 c    &         ' jj=',jj,' kk=',kk
8179             if (j1.eq.j+1) then
8180 C Contacts I-J and (I+1)-J occur simultaneously.
8181 C The system loses extra energy.
8182 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8183             endif ! j1==j+1
8184           enddo ! kk
8185         enddo ! jj
8186       enddo ! i
8187       return
8188       end
8189 c------------------------------------------------------------------------------
8190       subroutine add_hb_contact(ii,jj,itask)
8191       implicit real*8 (a-h,o-z)
8192       include "DIMENSIONS"
8193       include "COMMON.IOUNITS"
8194       integer max_cont
8195       integer max_dim
8196       parameter (max_cont=maxconts)
8197       parameter (max_dim=26)
8198       include "COMMON.CONTACTS"
8199       double precision zapas(max_dim,maxconts,max_fg_procs),
8200      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8201       common /przechowalnia/ zapas
8202       integer i,j,ii,jj,iproc,itask(4),nn
8203 c      write (iout,*) "itask",itask
8204       do i=1,2
8205         iproc=itask(i)
8206         if (iproc.gt.0) then
8207           do j=1,num_cont_hb(ii)
8208             jjc=jcont_hb(j,ii)
8209 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8210             if (jjc.eq.jj) then
8211               ncont_sent(iproc)=ncont_sent(iproc)+1
8212               nn=ncont_sent(iproc)
8213               zapas(1,nn,iproc)=ii
8214               zapas(2,nn,iproc)=jjc
8215               zapas(3,nn,iproc)=facont_hb(j,ii)
8216               zapas(4,nn,iproc)=ees0p(j,ii)
8217               zapas(5,nn,iproc)=ees0m(j,ii)
8218               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8219               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8220               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8221               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8222               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8223               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8224               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8225               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8226               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8227               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8228               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8229               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8230               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8231               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8232               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8233               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8234               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8235               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8236               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8237               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8238               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8239               exit
8240             endif
8241           enddo
8242         endif
8243       enddo
8244       return
8245       end
8246 c------------------------------------------------------------------------------
8247       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8248      &  n_corr1)
8249 C This subroutine calculates multi-body contributions to hydrogen-bonding
8250       implicit real*8 (a-h,o-z)
8251       include 'DIMENSIONS'
8252       include 'COMMON.IOUNITS'
8253 #ifdef MPI
8254       include "mpif.h"
8255       parameter (max_cont=maxconts)
8256       parameter (max_dim=70)
8257       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8258       double precision zapas(max_dim,maxconts,max_fg_procs),
8259      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8260       common /przechowalnia/ zapas
8261       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8262      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8263 #endif
8264       include 'COMMON.SETUP'
8265       include 'COMMON.FFIELD'
8266       include 'COMMON.DERIV'
8267       include 'COMMON.LOCAL'
8268       include 'COMMON.INTERACT'
8269       include 'COMMON.CONTACTS'
8270       include 'COMMON.CHAIN'
8271       include 'COMMON.CONTROL'
8272       include 'COMMON.SHIELD'
8273       double precision gx(3),gx1(3)
8274       integer num_cont_hb_old(maxres)
8275       logical lprn,ldone
8276       double precision eello4,eello5,eelo6,eello_turn6
8277       external eello4,eello5,eello6,eello_turn6
8278 C Set lprn=.true. for debugging
8279       lprn=.false.
8280       eturn6=0.0d0
8281 #ifdef MPI
8282       do i=1,nres
8283         num_cont_hb_old(i)=num_cont_hb(i)
8284       enddo
8285       n_corr=0
8286       n_corr1=0
8287       if (nfgtasks.le.1) goto 30
8288       if (lprn) then
8289         write (iout,'(a)') 'Contact function values before RECEIVE:'
8290         do i=nnt,nct-2
8291           write (iout,'(2i3,50(1x,i2,f5.2))')
8292      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8293      &    j=1,num_cont_hb(i))
8294         enddo
8295       endif
8296       call flush(iout)
8297       do i=1,ntask_cont_from
8298         ncont_recv(i)=0
8299       enddo
8300       do i=1,ntask_cont_to
8301         ncont_sent(i)=0
8302       enddo
8303 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8304 c     & ntask_cont_to
8305 C Make the list of contacts to send to send to other procesors
8306       do i=iturn3_start,iturn3_end
8307 c        write (iout,*) "make contact list turn3",i," num_cont",
8308 c     &    num_cont_hb(i)
8309         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8310       enddo
8311       do i=iturn4_start,iturn4_end
8312 c        write (iout,*) "make contact list turn4",i," num_cont",
8313 c     &   num_cont_hb(i)
8314         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8315       enddo
8316       do ii=1,nat_sent
8317         i=iat_sent(ii)
8318 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8319 c     &    num_cont_hb(i)
8320         do j=1,num_cont_hb(i)
8321         do k=1,4
8322           jjc=jcont_hb(j,i)
8323           iproc=iint_sent_local(k,jjc,ii)
8324 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8325           if (iproc.ne.0) then
8326             ncont_sent(iproc)=ncont_sent(iproc)+1
8327             nn=ncont_sent(iproc)
8328             zapas(1,nn,iproc)=i
8329             zapas(2,nn,iproc)=jjc
8330             zapas(3,nn,iproc)=d_cont(j,i)
8331             ind=3
8332             do kk=1,3
8333               ind=ind+1
8334               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8335             enddo
8336             do kk=1,2
8337               do ll=1,2
8338                 ind=ind+1
8339                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8340               enddo
8341             enddo
8342             do jj=1,5
8343               do kk=1,3
8344                 do ll=1,2
8345                   do mm=1,2
8346                     ind=ind+1
8347                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8348                   enddo
8349                 enddo
8350               enddo
8351             enddo
8352           endif
8353         enddo
8354         enddo
8355       enddo
8356       if (lprn) then
8357       write (iout,*)
8358      &  "Numbers of contacts to be sent to other processors",
8359      &  (ncont_sent(i),i=1,ntask_cont_to)
8360       write (iout,*) "Contacts sent"
8361       do ii=1,ntask_cont_to
8362         nn=ncont_sent(ii)
8363         iproc=itask_cont_to(ii)
8364         write (iout,*) nn," contacts to processor",iproc,
8365      &   " of CONT_TO_COMM group"
8366         do i=1,nn
8367           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8368         enddo
8369       enddo
8370       call flush(iout)
8371       endif
8372       CorrelType=477
8373       CorrelID=fg_rank+1
8374       CorrelType1=478
8375       CorrelID1=nfgtasks+fg_rank+1
8376       ireq=0
8377 C Receive the numbers of needed contacts from other processors
8378       do ii=1,ntask_cont_from
8379         iproc=itask_cont_from(ii)
8380         ireq=ireq+1
8381         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8382      &    FG_COMM,req(ireq),IERR)
8383       enddo
8384 c      write (iout,*) "IRECV ended"
8385 c      call flush(iout)
8386 C Send the number of contacts needed by other processors
8387       do ii=1,ntask_cont_to
8388         iproc=itask_cont_to(ii)
8389         ireq=ireq+1
8390         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8391      &    FG_COMM,req(ireq),IERR)
8392       enddo
8393 c      write (iout,*) "ISEND ended"
8394 c      write (iout,*) "number of requests (nn)",ireq
8395       call flush(iout)
8396       if (ireq.gt.0)
8397      &  call MPI_Waitall(ireq,req,status_array,ierr)
8398 c      write (iout,*)
8399 c     &  "Numbers of contacts to be received from other processors",
8400 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8401 c      call flush(iout)
8402 C Receive contacts
8403       ireq=0
8404       do ii=1,ntask_cont_from
8405         iproc=itask_cont_from(ii)
8406         nn=ncont_recv(ii)
8407 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8408 c     &   " of CONT_TO_COMM group"
8409         call flush(iout)
8410         if (nn.gt.0) then
8411           ireq=ireq+1
8412           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8413      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8414 c          write (iout,*) "ireq,req",ireq,req(ireq)
8415         endif
8416       enddo
8417 C Send the contacts to processors that need them
8418       do ii=1,ntask_cont_to
8419         iproc=itask_cont_to(ii)
8420         nn=ncont_sent(ii)
8421 c        write (iout,*) nn," contacts to processor",iproc,
8422 c     &   " of CONT_TO_COMM group"
8423         if (nn.gt.0) then
8424           ireq=ireq+1
8425           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8426      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8427 c          write (iout,*) "ireq,req",ireq,req(ireq)
8428 c          do i=1,nn
8429 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8430 c          enddo
8431         endif
8432       enddo
8433 c      write (iout,*) "number of requests (contacts)",ireq
8434 c      write (iout,*) "req",(req(i),i=1,4)
8435 c      call flush(iout)
8436       if (ireq.gt.0)
8437      & call MPI_Waitall(ireq,req,status_array,ierr)
8438       do iii=1,ntask_cont_from
8439         iproc=itask_cont_from(iii)
8440         nn=ncont_recv(iii)
8441         if (lprn) then
8442         write (iout,*) "Received",nn," contacts from processor",iproc,
8443      &   " of CONT_FROM_COMM group"
8444         call flush(iout)
8445         do i=1,nn
8446           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8447         enddo
8448         call flush(iout)
8449         endif
8450         do i=1,nn
8451           ii=zapas_recv(1,i,iii)
8452 c Flag the received contacts to prevent double-counting
8453           jj=-zapas_recv(2,i,iii)
8454 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8455 c          call flush(iout)
8456           nnn=num_cont_hb(ii)+1
8457           num_cont_hb(ii)=nnn
8458           jcont_hb(nnn,ii)=jj
8459           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8460           ind=3
8461           do kk=1,3
8462             ind=ind+1
8463             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8464           enddo
8465           do kk=1,2
8466             do ll=1,2
8467               ind=ind+1
8468               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8469             enddo
8470           enddo
8471           do jj=1,5
8472             do kk=1,3
8473               do ll=1,2
8474                 do mm=1,2
8475                   ind=ind+1
8476                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8477                 enddo
8478               enddo
8479             enddo
8480           enddo
8481         enddo
8482       enddo
8483       call flush(iout)
8484       if (lprn) then
8485         write (iout,'(a)') 'Contact function values after receive:'
8486         do i=nnt,nct-2
8487           write (iout,'(2i3,50(1x,i3,5f6.3))')
8488      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8489      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8490         enddo
8491         call flush(iout)
8492       endif
8493    30 continue
8494 #endif
8495       if (lprn) then
8496         write (iout,'(a)') 'Contact function values:'
8497         do i=nnt,nct-2
8498           write (iout,'(2i3,50(1x,i2,5f6.3))')
8499      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8500      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8501         enddo
8502       endif
8503       ecorr=0.0D0
8504       ecorr5=0.0d0
8505       ecorr6=0.0d0
8506 C Remove the loop below after debugging !!!
8507       do i=nnt,nct
8508         do j=1,3
8509           gradcorr(j,i)=0.0D0
8510           gradxorr(j,i)=0.0D0
8511         enddo
8512       enddo
8513 C Calculate the dipole-dipole interaction energies
8514       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8515       do i=iatel_s,iatel_e+1
8516         num_conti=num_cont_hb(i)
8517         do jj=1,num_conti
8518           j=jcont_hb(jj,i)
8519 #ifdef MOMENT
8520           call dipole(i,j,jj)
8521 #endif
8522         enddo
8523       enddo
8524       endif
8525 C Calculate the local-electrostatic correlation terms
8526 c                write (iout,*) "gradcorr5 in eello5 before loop"
8527 c                do iii=1,nres
8528 c                  write (iout,'(i5,3f10.5)')
8529 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8530 c                enddo
8531       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8532 c        write (iout,*) "corr loop i",i
8533         i1=i+1
8534         num_conti=num_cont_hb(i)
8535         num_conti1=num_cont_hb(i+1)
8536         do jj=1,num_conti
8537           j=jcont_hb(jj,i)
8538           jp=iabs(j)
8539           do kk=1,num_conti1
8540             j1=jcont_hb(kk,i1)
8541             jp1=iabs(j1)
8542 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8543 c     &         ' jj=',jj,' kk=',kk
8544 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8545             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8546      &          .or. j.lt.0 .and. j1.gt.0) .and.
8547      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8548 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8549 C The system gains extra energy.
8550               n_corr=n_corr+1
8551               sqd1=dsqrt(d_cont(jj,i))
8552               sqd2=dsqrt(d_cont(kk,i1))
8553               sred_geom = sqd1*sqd2
8554               IF (sred_geom.lt.cutoff_corr) THEN
8555                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8556      &            ekont,fprimcont)
8557 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8558 cd     &         ' jj=',jj,' kk=',kk
8559                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8560                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8561                 do l=1,3
8562                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8563                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8564                 enddo
8565                 n_corr1=n_corr1+1
8566 cd               write (iout,*) 'sred_geom=',sred_geom,
8567 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8568 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8569 cd               write (iout,*) "g_contij",g_contij
8570 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8571 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8572                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8573                 if (wcorr4.gt.0.0d0)
8574      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8575 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8576                   if (energy_dec.and.wcorr4.gt.0.0d0)
8577      1                 write (iout,'(a6,4i5,0pf7.3)')
8578      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8579 c                write (iout,*) "gradcorr5 before eello5"
8580 c                do iii=1,nres
8581 c                  write (iout,'(i5,3f10.5)')
8582 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8583 c                enddo
8584                 if (wcorr5.gt.0.0d0)
8585      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8586 c                write (iout,*) "gradcorr5 after eello5"
8587 c                do iii=1,nres
8588 c                  write (iout,'(i5,3f10.5)')
8589 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8590 c                enddo
8591                   if (energy_dec.and.wcorr5.gt.0.0d0)
8592      1                 write (iout,'(a6,4i5,0pf7.3)')
8593      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8594 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8595 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8596                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8597      &               .or. wturn6.eq.0.0d0))then
8598 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8599                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8600                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8601      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8602 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8603 cd     &            'ecorr6=',ecorr6
8604 cd                write (iout,'(4e15.5)') sred_geom,
8605 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8606 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8607 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8608                 else if (wturn6.gt.0.0d0
8609      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8610 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8611                   eturn6=eturn6+eello_turn6(i,jj,kk)
8612                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8613      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8614 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8615                 endif
8616               ENDIF
8617 1111          continue
8618             endif
8619           enddo ! kk
8620         enddo ! jj
8621       enddo ! i
8622       do i=1,nres
8623         num_cont_hb(i)=num_cont_hb_old(i)
8624       enddo
8625 c                write (iout,*) "gradcorr5 in eello5"
8626 c                do iii=1,nres
8627 c                  write (iout,'(i5,3f10.5)')
8628 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8629 c                enddo
8630       return
8631       end
8632 c------------------------------------------------------------------------------
8633       subroutine add_hb_contact_eello(ii,jj,itask)
8634       implicit real*8 (a-h,o-z)
8635       include "DIMENSIONS"
8636       include "COMMON.IOUNITS"
8637       integer max_cont
8638       integer max_dim
8639       parameter (max_cont=maxconts)
8640       parameter (max_dim=70)
8641       include "COMMON.CONTACTS"
8642       double precision zapas(max_dim,maxconts,max_fg_procs),
8643      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8644       common /przechowalnia/ zapas
8645       integer i,j,ii,jj,iproc,itask(4),nn
8646 c      write (iout,*) "itask",itask
8647       do i=1,2
8648         iproc=itask(i)
8649         if (iproc.gt.0) then
8650           do j=1,num_cont_hb(ii)
8651             jjc=jcont_hb(j,ii)
8652 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8653             if (jjc.eq.jj) then
8654               ncont_sent(iproc)=ncont_sent(iproc)+1
8655               nn=ncont_sent(iproc)
8656               zapas(1,nn,iproc)=ii
8657               zapas(2,nn,iproc)=jjc
8658               zapas(3,nn,iproc)=d_cont(j,ii)
8659               ind=3
8660               do kk=1,3
8661                 ind=ind+1
8662                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8663               enddo
8664               do kk=1,2
8665                 do ll=1,2
8666                   ind=ind+1
8667                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8668                 enddo
8669               enddo
8670               do jj=1,5
8671                 do kk=1,3
8672                   do ll=1,2
8673                     do mm=1,2
8674                       ind=ind+1
8675                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8676                     enddo
8677                   enddo
8678                 enddo
8679               enddo
8680               exit
8681             endif
8682           enddo
8683         endif
8684       enddo
8685       return
8686       end
8687 c------------------------------------------------------------------------------
8688       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8689       implicit real*8 (a-h,o-z)
8690       include 'DIMENSIONS'
8691       include 'COMMON.IOUNITS'
8692       include 'COMMON.DERIV'
8693       include 'COMMON.INTERACT'
8694       include 'COMMON.CONTACTS'
8695       include 'COMMON.SHIELD'
8696       include 'COMMON.CONTROL'
8697       double precision gx(3),gx1(3)
8698       logical lprn
8699       lprn=.false.
8700 C      print *,"wchodze",fac_shield(i),shield_mode
8701       eij=facont_hb(jj,i)
8702       ekl=facont_hb(kk,k)
8703       ees0pij=ees0p(jj,i)
8704       ees0pkl=ees0p(kk,k)
8705       ees0mij=ees0m(jj,i)
8706       ees0mkl=ees0m(kk,k)
8707       ekont=eij*ekl
8708       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8709 C*
8710 C     & fac_shield(i)**2*fac_shield(j)**2
8711 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8712 C Following 4 lines for diagnostics.
8713 cd    ees0pkl=0.0D0
8714 cd    ees0pij=1.0D0
8715 cd    ees0mkl=0.0D0
8716 cd    ees0mij=1.0D0
8717 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8718 c     & 'Contacts ',i,j,
8719 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8720 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8721 c     & 'gradcorr_long'
8722 C Calculate the multi-body contribution to energy.
8723 c      ecorr=ecorr+ekont*ees
8724 C Calculate multi-body contributions to the gradient.
8725       coeffpees0pij=coeffp*ees0pij
8726       coeffmees0mij=coeffm*ees0mij
8727       coeffpees0pkl=coeffp*ees0pkl
8728       coeffmees0mkl=coeffm*ees0mkl
8729       do ll=1,3
8730 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8731         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8732      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8733      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8734         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8735      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8736      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8737 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8738         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8739      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8740      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8741         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8742      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8743      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8744         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8745      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8746      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8747         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8748         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8749         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8750      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8751      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8752         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8753         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8754 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8755       enddo
8756 c      write (iout,*)
8757 cgrad      do m=i+1,j-1
8758 cgrad        do ll=1,3
8759 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8760 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8761 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8762 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8763 cgrad        enddo
8764 cgrad      enddo
8765 cgrad      do m=k+1,l-1
8766 cgrad        do ll=1,3
8767 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8768 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8769 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8770 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8771 cgrad        enddo
8772 cgrad      enddo
8773 c      write (iout,*) "ehbcorr",ekont*ees
8774 C      print *,ekont,ees,i,k
8775       ehbcorr=ekont*ees
8776 C now gradient over shielding
8777 C      return
8778       if (shield_mode.gt.0) then
8779        j=ees0plist(jj,i)
8780        l=ees0plist(kk,k)
8781 C        print *,i,j,fac_shield(i),fac_shield(j),
8782 C     &fac_shield(k),fac_shield(l)
8783         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8784      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8785           do ilist=1,ishield_list(i)
8786            iresshield=shield_list(ilist,i)
8787            do m=1,3
8788            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8789 C     &      *2.0
8790            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8791      &              rlocshield
8792      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8793             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8794      &+rlocshield
8795            enddo
8796           enddo
8797           do ilist=1,ishield_list(j)
8798            iresshield=shield_list(ilist,j)
8799            do m=1,3
8800            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8801 C     &     *2.0
8802            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8803      &              rlocshield
8804      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8805            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8806      &     +rlocshield
8807            enddo
8808           enddo
8809
8810           do ilist=1,ishield_list(k)
8811            iresshield=shield_list(ilist,k)
8812            do m=1,3
8813            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8814 C     &     *2.0
8815            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8816      &              rlocshield
8817      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8818            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8819      &     +rlocshield
8820            enddo
8821           enddo
8822           do ilist=1,ishield_list(l)
8823            iresshield=shield_list(ilist,l)
8824            do m=1,3
8825            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8826 C     &     *2.0
8827            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8828      &              rlocshield
8829      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8830            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8831      &     +rlocshield
8832            enddo
8833           enddo
8834 C          print *,gshieldx(m,iresshield)
8835           do m=1,3
8836             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8837      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8838             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8839      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8840             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8841      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8842             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8843      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8844
8845             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8846      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8847             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8848      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8849             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8850      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8851             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8852      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8853
8854            enddo
8855       endif
8856       endif
8857       return
8858       end
8859 #ifdef MOMENT
8860 C---------------------------------------------------------------------------
8861       subroutine dipole(i,j,jj)
8862       implicit real*8 (a-h,o-z)
8863       include 'DIMENSIONS'
8864       include 'COMMON.IOUNITS'
8865       include 'COMMON.CHAIN'
8866       include 'COMMON.FFIELD'
8867       include 'COMMON.DERIV'
8868       include 'COMMON.INTERACT'
8869       include 'COMMON.CONTACTS'
8870       include 'COMMON.TORSION'
8871       include 'COMMON.VAR'
8872       include 'COMMON.GEO'
8873       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8874      &  auxmat(2,2)
8875       iti1 = itortyp(itype(i+1))
8876       if (j.lt.nres-1) then
8877         itj1 = itype2loc(itype(j+1))
8878       else
8879         itj1=nloctyp
8880       endif
8881       do iii=1,2
8882         dipi(iii,1)=Ub2(iii,i)
8883         dipderi(iii)=Ub2der(iii,i)
8884         dipi(iii,2)=b1(iii,i+1)
8885         dipj(iii,1)=Ub2(iii,j)
8886         dipderj(iii)=Ub2der(iii,j)
8887         dipj(iii,2)=b1(iii,j+1)
8888       enddo
8889       kkk=0
8890       do iii=1,2
8891         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8892         do jjj=1,2
8893           kkk=kkk+1
8894           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8895         enddo
8896       enddo
8897       do kkk=1,5
8898         do lll=1,3
8899           mmm=0
8900           do iii=1,2
8901             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8902      &        auxvec(1))
8903             do jjj=1,2
8904               mmm=mmm+1
8905               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8906             enddo
8907           enddo
8908         enddo
8909       enddo
8910       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8911       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8912       do iii=1,2
8913         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8914       enddo
8915       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8916       do iii=1,2
8917         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8918       enddo
8919       return
8920       end
8921 #endif
8922 C---------------------------------------------------------------------------
8923       subroutine calc_eello(i,j,k,l,jj,kk)
8924 C
8925 C This subroutine computes matrices and vectors needed to calculate
8926 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8927 C
8928       implicit real*8 (a-h,o-z)
8929       include 'DIMENSIONS'
8930       include 'COMMON.IOUNITS'
8931       include 'COMMON.CHAIN'
8932       include 'COMMON.DERIV'
8933       include 'COMMON.INTERACT'
8934       include 'COMMON.CONTACTS'
8935       include 'COMMON.TORSION'
8936       include 'COMMON.VAR'
8937       include 'COMMON.GEO'
8938       include 'COMMON.FFIELD'
8939       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8940      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8941       logical lprn
8942       common /kutas/ lprn
8943 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8944 cd     & ' jj=',jj,' kk=',kk
8945 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8946 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8947 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8948       do iii=1,2
8949         do jjj=1,2
8950           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8951           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8952         enddo
8953       enddo
8954       call transpose2(aa1(1,1),aa1t(1,1))
8955       call transpose2(aa2(1,1),aa2t(1,1))
8956       do kkk=1,5
8957         do lll=1,3
8958           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8959      &      aa1tder(1,1,lll,kkk))
8960           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8961      &      aa2tder(1,1,lll,kkk))
8962         enddo
8963       enddo
8964       if (l.eq.j+1) then
8965 C parallel orientation of the two CA-CA-CA frames.
8966         if (i.gt.1) then
8967           iti=itype2loc(itype(i))
8968         else
8969           iti=nloctyp
8970         endif
8971         itk1=itype2loc(itype(k+1))
8972         itj=itype2loc(itype(j))
8973         if (l.lt.nres-1) then
8974           itl1=itype2loc(itype(l+1))
8975         else
8976           itl1=nloctyp
8977         endif
8978 C A1 kernel(j+1) A2T
8979 cd        do iii=1,2
8980 cd          write (iout,'(3f10.5,5x,3f10.5)')
8981 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8982 cd        enddo
8983         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8984      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8985      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8986 C Following matrices are needed only for 6-th order cumulants
8987         IF (wcorr6.gt.0.0d0) THEN
8988         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8989      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8990      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8991         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8992      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8993      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8994      &   ADtEAderx(1,1,1,1,1,1))
8995         lprn=.false.
8996         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8997      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8998      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8999      &   ADtEA1derx(1,1,1,1,1,1))
9000         ENDIF
9001 C End 6-th order cumulants
9002 cd        lprn=.false.
9003 cd        if (lprn) then
9004 cd        write (2,*) 'In calc_eello6'
9005 cd        do iii=1,2
9006 cd          write (2,*) 'iii=',iii
9007 cd          do kkk=1,5
9008 cd            write (2,*) 'kkk=',kkk
9009 cd            do jjj=1,2
9010 cd              write (2,'(3(2f10.5),5x)')
9011 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9012 cd            enddo
9013 cd          enddo
9014 cd        enddo
9015 cd        endif
9016         call transpose2(EUgder(1,1,k),auxmat(1,1))
9017         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9018         call transpose2(EUg(1,1,k),auxmat(1,1))
9019         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9020         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9021         do iii=1,2
9022           do kkk=1,5
9023             do lll=1,3
9024               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9025      &          EAEAderx(1,1,lll,kkk,iii,1))
9026             enddo
9027           enddo
9028         enddo
9029 C A1T kernel(i+1) A2
9030         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9031      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9032      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9033 C Following matrices are needed only for 6-th order cumulants
9034         IF (wcorr6.gt.0.0d0) THEN
9035         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9036      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9037      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9038         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9039      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9040      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9041      &   ADtEAderx(1,1,1,1,1,2))
9042         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9043      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9044      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9045      &   ADtEA1derx(1,1,1,1,1,2))
9046         ENDIF
9047 C End 6-th order cumulants
9048         call transpose2(EUgder(1,1,l),auxmat(1,1))
9049         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9050         call transpose2(EUg(1,1,l),auxmat(1,1))
9051         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9052         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9053         do iii=1,2
9054           do kkk=1,5
9055             do lll=1,3
9056               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9057      &          EAEAderx(1,1,lll,kkk,iii,2))
9058             enddo
9059           enddo
9060         enddo
9061 C AEAb1 and AEAb2
9062 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9063 C They are needed only when the fifth- or the sixth-order cumulants are
9064 C indluded.
9065         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9066         call transpose2(AEA(1,1,1),auxmat(1,1))
9067         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9068         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9069         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9070         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9071         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9072         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9073         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9074         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9075         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9076         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9077         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9078         call transpose2(AEA(1,1,2),auxmat(1,1))
9079         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9080         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9081         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9082         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9083         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9084         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9085         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9086         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9087         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9088         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9089         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9090 C Calculate the Cartesian derivatives of the vectors.
9091         do iii=1,2
9092           do kkk=1,5
9093             do lll=1,3
9094               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9095               call matvec2(auxmat(1,1),b1(1,i),
9096      &          AEAb1derx(1,lll,kkk,iii,1,1))
9097               call matvec2(auxmat(1,1),Ub2(1,i),
9098      &          AEAb2derx(1,lll,kkk,iii,1,1))
9099               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9100      &          AEAb1derx(1,lll,kkk,iii,2,1))
9101               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9102      &          AEAb2derx(1,lll,kkk,iii,2,1))
9103               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9104               call matvec2(auxmat(1,1),b1(1,j),
9105      &          AEAb1derx(1,lll,kkk,iii,1,2))
9106               call matvec2(auxmat(1,1),Ub2(1,j),
9107      &          AEAb2derx(1,lll,kkk,iii,1,2))
9108               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9109      &          AEAb1derx(1,lll,kkk,iii,2,2))
9110               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9111      &          AEAb2derx(1,lll,kkk,iii,2,2))
9112             enddo
9113           enddo
9114         enddo
9115         ENDIF
9116 C End vectors
9117       else
9118 C Antiparallel orientation of the two CA-CA-CA frames.
9119         if (i.gt.1) then
9120           iti=itype2loc(itype(i))
9121         else
9122           iti=nloctyp
9123         endif
9124         itk1=itype2loc(itype(k+1))
9125         itl=itype2loc(itype(l))
9126         itj=itype2loc(itype(j))
9127         if (j.lt.nres-1) then
9128           itj1=itype2loc(itype(j+1))
9129         else
9130           itj1=nloctyp
9131         endif
9132 C A2 kernel(j-1)T A1T
9133         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9134      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9135      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9136 C Following matrices are needed only for 6-th order cumulants
9137         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9138      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9139         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9140      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9141      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9142         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9143      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9144      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9145      &   ADtEAderx(1,1,1,1,1,1))
9146         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9147      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9148      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9149      &   ADtEA1derx(1,1,1,1,1,1))
9150         ENDIF
9151 C End 6-th order cumulants
9152         call transpose2(EUgder(1,1,k),auxmat(1,1))
9153         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9154         call transpose2(EUg(1,1,k),auxmat(1,1))
9155         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9156         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9157         do iii=1,2
9158           do kkk=1,5
9159             do lll=1,3
9160               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9161      &          EAEAderx(1,1,lll,kkk,iii,1))
9162             enddo
9163           enddo
9164         enddo
9165 C A2T kernel(i+1)T A1
9166         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9167      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9168      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9169 C Following matrices are needed only for 6-th order cumulants
9170         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9171      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9172         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9173      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9174      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9175         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9176      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9177      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9178      &   ADtEAderx(1,1,1,1,1,2))
9179         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9180      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9181      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9182      &   ADtEA1derx(1,1,1,1,1,2))
9183         ENDIF
9184 C End 6-th order cumulants
9185         call transpose2(EUgder(1,1,j),auxmat(1,1))
9186         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9187         call transpose2(EUg(1,1,j),auxmat(1,1))
9188         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9189         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9190         do iii=1,2
9191           do kkk=1,5
9192             do lll=1,3
9193               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9194      &          EAEAderx(1,1,lll,kkk,iii,2))
9195             enddo
9196           enddo
9197         enddo
9198 C AEAb1 and AEAb2
9199 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9200 C They are needed only when the fifth- or the sixth-order cumulants are
9201 C indluded.
9202         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9203      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9204         call transpose2(AEA(1,1,1),auxmat(1,1))
9205         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9206         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9207         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9208         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9209         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9210         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9211         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9212         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9213         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9214         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9215         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9216         call transpose2(AEA(1,1,2),auxmat(1,1))
9217         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9218         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9219         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9220         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9221         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9222         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9223         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9224         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9225         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9226         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9227         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9228 C Calculate the Cartesian derivatives of the vectors.
9229         do iii=1,2
9230           do kkk=1,5
9231             do lll=1,3
9232               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9233               call matvec2(auxmat(1,1),b1(1,i),
9234      &          AEAb1derx(1,lll,kkk,iii,1,1))
9235               call matvec2(auxmat(1,1),Ub2(1,i),
9236      &          AEAb2derx(1,lll,kkk,iii,1,1))
9237               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9238      &          AEAb1derx(1,lll,kkk,iii,2,1))
9239               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9240      &          AEAb2derx(1,lll,kkk,iii,2,1))
9241               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9242               call matvec2(auxmat(1,1),b1(1,l),
9243      &          AEAb1derx(1,lll,kkk,iii,1,2))
9244               call matvec2(auxmat(1,1),Ub2(1,l),
9245      &          AEAb2derx(1,lll,kkk,iii,1,2))
9246               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9247      &          AEAb1derx(1,lll,kkk,iii,2,2))
9248               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9249      &          AEAb2derx(1,lll,kkk,iii,2,2))
9250             enddo
9251           enddo
9252         enddo
9253         ENDIF
9254 C End vectors
9255       endif
9256       return
9257       end
9258 C---------------------------------------------------------------------------
9259       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9260      &  KK,KKderg,AKA,AKAderg,AKAderx)
9261       implicit none
9262       integer nderg
9263       logical transp
9264       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9265      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9266      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9267       integer iii,kkk,lll
9268       integer jjj,mmm
9269       logical lprn
9270       common /kutas/ lprn
9271       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9272       do iii=1,nderg
9273         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9274      &    AKAderg(1,1,iii))
9275       enddo
9276 cd      if (lprn) write (2,*) 'In kernel'
9277       do kkk=1,5
9278 cd        if (lprn) write (2,*) 'kkk=',kkk
9279         do lll=1,3
9280           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9281      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9282 cd          if (lprn) then
9283 cd            write (2,*) 'lll=',lll
9284 cd            write (2,*) 'iii=1'
9285 cd            do jjj=1,2
9286 cd              write (2,'(3(2f10.5),5x)')
9287 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9288 cd            enddo
9289 cd          endif
9290           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9291      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9292 cd          if (lprn) then
9293 cd            write (2,*) 'lll=',lll
9294 cd            write (2,*) 'iii=2'
9295 cd            do jjj=1,2
9296 cd              write (2,'(3(2f10.5),5x)')
9297 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9298 cd            enddo
9299 cd          endif
9300         enddo
9301       enddo
9302       return
9303       end
9304 C---------------------------------------------------------------------------
9305       double precision function eello4(i,j,k,l,jj,kk)
9306       implicit real*8 (a-h,o-z)
9307       include 'DIMENSIONS'
9308       include 'COMMON.IOUNITS'
9309       include 'COMMON.CHAIN'
9310       include 'COMMON.DERIV'
9311       include 'COMMON.INTERACT'
9312       include 'COMMON.CONTACTS'
9313       include 'COMMON.TORSION'
9314       include 'COMMON.VAR'
9315       include 'COMMON.GEO'
9316       double precision pizda(2,2),ggg1(3),ggg2(3)
9317 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9318 cd        eello4=0.0d0
9319 cd        return
9320 cd      endif
9321 cd      print *,'eello4:',i,j,k,l,jj,kk
9322 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9323 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9324 cold      eij=facont_hb(jj,i)
9325 cold      ekl=facont_hb(kk,k)
9326 cold      ekont=eij*ekl
9327       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9328 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9329       gcorr_loc(k-1)=gcorr_loc(k-1)
9330      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9331       if (l.eq.j+1) then
9332         gcorr_loc(l-1)=gcorr_loc(l-1)
9333      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9334       else
9335         gcorr_loc(j-1)=gcorr_loc(j-1)
9336      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9337       endif
9338       do iii=1,2
9339         do kkk=1,5
9340           do lll=1,3
9341             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9342      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9343 cd            derx(lll,kkk,iii)=0.0d0
9344           enddo
9345         enddo
9346       enddo
9347 cd      gcorr_loc(l-1)=0.0d0
9348 cd      gcorr_loc(j-1)=0.0d0
9349 cd      gcorr_loc(k-1)=0.0d0
9350 cd      eel4=1.0d0
9351 cd      write (iout,*)'Contacts have occurred for peptide groups',
9352 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9353 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9354       if (j.lt.nres-1) then
9355         j1=j+1
9356         j2=j-1
9357       else
9358         j1=j-1
9359         j2=j-2
9360       endif
9361       if (l.lt.nres-1) then
9362         l1=l+1
9363         l2=l-1
9364       else
9365         l1=l-1
9366         l2=l-2
9367       endif
9368       do ll=1,3
9369 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9370 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9371         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9372         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9373 cgrad        ghalf=0.5d0*ggg1(ll)
9374         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9375         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9376         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9377         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9378         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9379         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9380 cgrad        ghalf=0.5d0*ggg2(ll)
9381         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9382         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9383         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9384         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9385         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9386         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9387       enddo
9388 cgrad      do m=i+1,j-1
9389 cgrad        do ll=1,3
9390 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9391 cgrad        enddo
9392 cgrad      enddo
9393 cgrad      do m=k+1,l-1
9394 cgrad        do ll=1,3
9395 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9396 cgrad        enddo
9397 cgrad      enddo
9398 cgrad      do m=i+2,j2
9399 cgrad        do ll=1,3
9400 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9401 cgrad        enddo
9402 cgrad      enddo
9403 cgrad      do m=k+2,l2
9404 cgrad        do ll=1,3
9405 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9406 cgrad        enddo
9407 cgrad      enddo
9408 cd      do iii=1,nres-3
9409 cd        write (2,*) iii,gcorr_loc(iii)
9410 cd      enddo
9411       eello4=ekont*eel4
9412 cd      write (2,*) 'ekont',ekont
9413 cd      write (iout,*) 'eello4',ekont*eel4
9414       return
9415       end
9416 C---------------------------------------------------------------------------
9417       double precision function eello5(i,j,k,l,jj,kk)
9418       implicit real*8 (a-h,o-z)
9419       include 'DIMENSIONS'
9420       include 'COMMON.IOUNITS'
9421       include 'COMMON.CHAIN'
9422       include 'COMMON.DERIV'
9423       include 'COMMON.INTERACT'
9424       include 'COMMON.CONTACTS'
9425       include 'COMMON.TORSION'
9426       include 'COMMON.VAR'
9427       include 'COMMON.GEO'
9428       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9429       double precision ggg1(3),ggg2(3)
9430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9431 C                                                                              C
9432 C                            Parallel chains                                   C
9433 C                                                                              C
9434 C          o             o                   o             o                   C
9435 C         /l\           / \             \   / \           / \   /              C
9436 C        /   \         /   \             \ /   \         /   \ /               C
9437 C       j| o |l1       | o |              o| o |         | o |o                C
9438 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9439 C      \i/   \         /   \ /             /   \         /   \                 C
9440 C       o    k1             o                                                  C
9441 C         (I)          (II)                (III)          (IV)                 C
9442 C                                                                              C
9443 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9444 C                                                                              C
9445 C                            Antiparallel chains                               C
9446 C                                                                              C
9447 C          o             o                   o             o                   C
9448 C         /j\           / \             \   / \           / \   /              C
9449 C        /   \         /   \             \ /   \         /   \ /               C
9450 C      j1| o |l        | o |              o| o |         | o |o                C
9451 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9452 C      \i/   \         /   \ /             /   \         /   \                 C
9453 C       o     k1            o                                                  C
9454 C         (I)          (II)                (III)          (IV)                 C
9455 C                                                                              C
9456 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9457 C                                                                              C
9458 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9459 C                                                                              C
9460 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9461 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9462 cd        eello5=0.0d0
9463 cd        return
9464 cd      endif
9465 cd      write (iout,*)
9466 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9467 cd     &   ' and',k,l
9468       itk=itype2loc(itype(k))
9469       itl=itype2loc(itype(l))
9470       itj=itype2loc(itype(j))
9471       eello5_1=0.0d0
9472       eello5_2=0.0d0
9473       eello5_3=0.0d0
9474       eello5_4=0.0d0
9475 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9476 cd     &   eel5_3_num,eel5_4_num)
9477       do iii=1,2
9478         do kkk=1,5
9479           do lll=1,3
9480             derx(lll,kkk,iii)=0.0d0
9481           enddo
9482         enddo
9483       enddo
9484 cd      eij=facont_hb(jj,i)
9485 cd      ekl=facont_hb(kk,k)
9486 cd      ekont=eij*ekl
9487 cd      write (iout,*)'Contacts have occurred for peptide groups',
9488 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9489 cd      goto 1111
9490 C Contribution from the graph I.
9491 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9492 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9493       call transpose2(EUg(1,1,k),auxmat(1,1))
9494       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9495       vv(1)=pizda(1,1)-pizda(2,2)
9496       vv(2)=pizda(1,2)+pizda(2,1)
9497       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9498      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9499 C Explicit gradient in virtual-dihedral angles.
9500       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9501      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9502      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9503       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9504       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9505       vv(1)=pizda(1,1)-pizda(2,2)
9506       vv(2)=pizda(1,2)+pizda(2,1)
9507       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9508      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9509      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9510       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9511       vv(1)=pizda(1,1)-pizda(2,2)
9512       vv(2)=pizda(1,2)+pizda(2,1)
9513       if (l.eq.j+1) then
9514         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9515      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9517       else
9518         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9519      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9521       endif
9522 C Cartesian gradient
9523       do iii=1,2
9524         do kkk=1,5
9525           do lll=1,3
9526             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9527      &        pizda(1,1))
9528             vv(1)=pizda(1,1)-pizda(2,2)
9529             vv(2)=pizda(1,2)+pizda(2,1)
9530             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9531      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9532      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9533           enddo
9534         enddo
9535       enddo
9536 c      goto 1112
9537 c1111  continue
9538 C Contribution from graph II
9539       call transpose2(EE(1,1,k),auxmat(1,1))
9540       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9541       vv(1)=pizda(1,1)+pizda(2,2)
9542       vv(2)=pizda(2,1)-pizda(1,2)
9543       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9544      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9545 C Explicit gradient in virtual-dihedral angles.
9546       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9547      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9548       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9549       vv(1)=pizda(1,1)+pizda(2,2)
9550       vv(2)=pizda(2,1)-pizda(1,2)
9551       if (l.eq.j+1) then
9552         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9553      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9554      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9555       else
9556         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9557      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9558      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9559       endif
9560 C Cartesian gradient
9561       do iii=1,2
9562         do kkk=1,5
9563           do lll=1,3
9564             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9565      &        pizda(1,1))
9566             vv(1)=pizda(1,1)+pizda(2,2)
9567             vv(2)=pizda(2,1)-pizda(1,2)
9568             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9569      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9570      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9571           enddo
9572         enddo
9573       enddo
9574 cd      goto 1112
9575 cd1111  continue
9576       if (l.eq.j+1) then
9577 cd        goto 1110
9578 C Parallel orientation
9579 C Contribution from graph III
9580         call transpose2(EUg(1,1,l),auxmat(1,1))
9581         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9582         vv(1)=pizda(1,1)-pizda(2,2)
9583         vv(2)=pizda(1,2)+pizda(2,1)
9584         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9585      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9586 C Explicit gradient in virtual-dihedral angles.
9587         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9588      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9589      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9590         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9591         vv(1)=pizda(1,1)-pizda(2,2)
9592         vv(2)=pizda(1,2)+pizda(2,1)
9593         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9594      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9595      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9596         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9597         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9598         vv(1)=pizda(1,1)-pizda(2,2)
9599         vv(2)=pizda(1,2)+pizda(2,1)
9600         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9601      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9602      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9603 C Cartesian gradient
9604         do iii=1,2
9605           do kkk=1,5
9606             do lll=1,3
9607               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9608      &          pizda(1,1))
9609               vv(1)=pizda(1,1)-pizda(2,2)
9610               vv(2)=pizda(1,2)+pizda(2,1)
9611               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9612      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9613      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9614             enddo
9615           enddo
9616         enddo
9617 cd        goto 1112
9618 C Contribution from graph IV
9619 cd1110    continue
9620         call transpose2(EE(1,1,l),auxmat(1,1))
9621         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9622         vv(1)=pizda(1,1)+pizda(2,2)
9623         vv(2)=pizda(2,1)-pizda(1,2)
9624         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9625      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9626 C Explicit gradient in virtual-dihedral angles.
9627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9628      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9629         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9630         vv(1)=pizda(1,1)+pizda(2,2)
9631         vv(2)=pizda(2,1)-pizda(1,2)
9632         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9633      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9634      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9635 C Cartesian gradient
9636         do iii=1,2
9637           do kkk=1,5
9638             do lll=1,3
9639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9640      &          pizda(1,1))
9641               vv(1)=pizda(1,1)+pizda(2,2)
9642               vv(2)=pizda(2,1)-pizda(1,2)
9643               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9644      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9645      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9646             enddo
9647           enddo
9648         enddo
9649       else
9650 C Antiparallel orientation
9651 C Contribution from graph III
9652 c        goto 1110
9653         call transpose2(EUg(1,1,j),auxmat(1,1))
9654         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9655         vv(1)=pizda(1,1)-pizda(2,2)
9656         vv(2)=pizda(1,2)+pizda(2,1)
9657         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9659 C Explicit gradient in virtual-dihedral angles.
9660         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9661      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9662      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9663         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9664         vv(1)=pizda(1,1)-pizda(2,2)
9665         vv(2)=pizda(1,2)+pizda(2,1)
9666         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9667      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9668      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9669         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9670         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9671         vv(1)=pizda(1,1)-pizda(2,2)
9672         vv(2)=pizda(1,2)+pizda(2,1)
9673         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9674      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9675      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9676 C Cartesian gradient
9677         do iii=1,2
9678           do kkk=1,5
9679             do lll=1,3
9680               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9681      &          pizda(1,1))
9682               vv(1)=pizda(1,1)-pizda(2,2)
9683               vv(2)=pizda(1,2)+pizda(2,1)
9684               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9685      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9686      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9687             enddo
9688           enddo
9689         enddo
9690 cd        goto 1112
9691 C Contribution from graph IV
9692 1110    continue
9693         call transpose2(EE(1,1,j),auxmat(1,1))
9694         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9695         vv(1)=pizda(1,1)+pizda(2,2)
9696         vv(2)=pizda(2,1)-pizda(1,2)
9697         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9698      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9699 C Explicit gradient in virtual-dihedral angles.
9700         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9701      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9702         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9703         vv(1)=pizda(1,1)+pizda(2,2)
9704         vv(2)=pizda(2,1)-pizda(1,2)
9705         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9706      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9707      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9708 C Cartesian gradient
9709         do iii=1,2
9710           do kkk=1,5
9711             do lll=1,3
9712               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9713      &          pizda(1,1))
9714               vv(1)=pizda(1,1)+pizda(2,2)
9715               vv(2)=pizda(2,1)-pizda(1,2)
9716               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9717      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9718      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9719             enddo
9720           enddo
9721         enddo
9722       endif
9723 1112  continue
9724       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9725 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9726 cd        write (2,*) 'ijkl',i,j,k,l
9727 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9728 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9729 cd      endif
9730 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9731 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9732 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9733 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9734       if (j.lt.nres-1) then
9735         j1=j+1
9736         j2=j-1
9737       else
9738         j1=j-1
9739         j2=j-2
9740       endif
9741       if (l.lt.nres-1) then
9742         l1=l+1
9743         l2=l-1
9744       else
9745         l1=l-1
9746         l2=l-2
9747       endif
9748 cd      eij=1.0d0
9749 cd      ekl=1.0d0
9750 cd      ekont=1.0d0
9751 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9752 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9753 C        summed up outside the subrouine as for the other subroutines
9754 C        handling long-range interactions. The old code is commented out
9755 C        with "cgrad" to keep track of changes.
9756       do ll=1,3
9757 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9758 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9759         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9760         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9761 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9762 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9763 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9764 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9765 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9766 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9767 c     &   gradcorr5ij,
9768 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9769 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9770 cgrad        ghalf=0.5d0*ggg1(ll)
9771 cd        ghalf=0.0d0
9772         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9773         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9774         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9775         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9776         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9777         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9778 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9779 cgrad        ghalf=0.5d0*ggg2(ll)
9780 cd        ghalf=0.0d0
9781         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9782         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9783         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9784         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9785         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9786         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9787       enddo
9788 cd      goto 1112
9789 cgrad      do m=i+1,j-1
9790 cgrad        do ll=1,3
9791 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9792 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9793 cgrad        enddo
9794 cgrad      enddo
9795 cgrad      do m=k+1,l-1
9796 cgrad        do ll=1,3
9797 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9798 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9799 cgrad        enddo
9800 cgrad      enddo
9801 c1112  continue
9802 cgrad      do m=i+2,j2
9803 cgrad        do ll=1,3
9804 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9805 cgrad        enddo
9806 cgrad      enddo
9807 cgrad      do m=k+2,l2
9808 cgrad        do ll=1,3
9809 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9810 cgrad        enddo
9811 cgrad      enddo
9812 cd      do iii=1,nres-3
9813 cd        write (2,*) iii,g_corr5_loc(iii)
9814 cd      enddo
9815       eello5=ekont*eel5
9816 cd      write (2,*) 'ekont',ekont
9817 cd      write (iout,*) 'eello5',ekont*eel5
9818       return
9819       end
9820 c--------------------------------------------------------------------------
9821       double precision function eello6(i,j,k,l,jj,kk)
9822       implicit real*8 (a-h,o-z)
9823       include 'DIMENSIONS'
9824       include 'COMMON.IOUNITS'
9825       include 'COMMON.CHAIN'
9826       include 'COMMON.DERIV'
9827       include 'COMMON.INTERACT'
9828       include 'COMMON.CONTACTS'
9829       include 'COMMON.TORSION'
9830       include 'COMMON.VAR'
9831       include 'COMMON.GEO'
9832       include 'COMMON.FFIELD'
9833       double precision ggg1(3),ggg2(3)
9834 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9835 cd        eello6=0.0d0
9836 cd        return
9837 cd      endif
9838 cd      write (iout,*)
9839 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9840 cd     &   ' and',k,l
9841       eello6_1=0.0d0
9842       eello6_2=0.0d0
9843       eello6_3=0.0d0
9844       eello6_4=0.0d0
9845       eello6_5=0.0d0
9846       eello6_6=0.0d0
9847 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9848 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9849       do iii=1,2
9850         do kkk=1,5
9851           do lll=1,3
9852             derx(lll,kkk,iii)=0.0d0
9853           enddo
9854         enddo
9855       enddo
9856 cd      eij=facont_hb(jj,i)
9857 cd      ekl=facont_hb(kk,k)
9858 cd      ekont=eij*ekl
9859 cd      eij=1.0d0
9860 cd      ekl=1.0d0
9861 cd      ekont=1.0d0
9862       if (l.eq.j+1) then
9863         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9864         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9865         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9866         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9867         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9868         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9869       else
9870         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9871         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9872         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9873         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9874         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9875           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9876         else
9877           eello6_5=0.0d0
9878         endif
9879         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9880       endif
9881 C If turn contributions are considered, they will be handled separately.
9882       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9883 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9884 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9885 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9886 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9887 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9888 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9889 cd      goto 1112
9890       if (j.lt.nres-1) then
9891         j1=j+1
9892         j2=j-1
9893       else
9894         j1=j-1
9895         j2=j-2
9896       endif
9897       if (l.lt.nres-1) then
9898         l1=l+1
9899         l2=l-1
9900       else
9901         l1=l-1
9902         l2=l-2
9903       endif
9904       do ll=1,3
9905 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9906 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9907 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9908 cgrad        ghalf=0.5d0*ggg1(ll)
9909 cd        ghalf=0.0d0
9910         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9911         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9912         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9913         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9914         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9915         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9916         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9917         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9918 cgrad        ghalf=0.5d0*ggg2(ll)
9919 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9920 cd        ghalf=0.0d0
9921         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9922         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9923         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9924         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9925         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9926         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9927       enddo
9928 cd      goto 1112
9929 cgrad      do m=i+1,j-1
9930 cgrad        do ll=1,3
9931 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9932 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9933 cgrad        enddo
9934 cgrad      enddo
9935 cgrad      do m=k+1,l-1
9936 cgrad        do ll=1,3
9937 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9938 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9939 cgrad        enddo
9940 cgrad      enddo
9941 cgrad1112  continue
9942 cgrad      do m=i+2,j2
9943 cgrad        do ll=1,3
9944 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9945 cgrad        enddo
9946 cgrad      enddo
9947 cgrad      do m=k+2,l2
9948 cgrad        do ll=1,3
9949 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9950 cgrad        enddo
9951 cgrad      enddo
9952 cd      do iii=1,nres-3
9953 cd        write (2,*) iii,g_corr6_loc(iii)
9954 cd      enddo
9955       eello6=ekont*eel6
9956 cd      write (2,*) 'ekont',ekont
9957 cd      write (iout,*) 'eello6',ekont*eel6
9958       return
9959       end
9960 c--------------------------------------------------------------------------
9961       double precision function eello6_graph1(i,j,k,l,imat,swap)
9962       implicit real*8 (a-h,o-z)
9963       include 'DIMENSIONS'
9964       include 'COMMON.IOUNITS'
9965       include 'COMMON.CHAIN'
9966       include 'COMMON.DERIV'
9967       include 'COMMON.INTERACT'
9968       include 'COMMON.CONTACTS'
9969       include 'COMMON.TORSION'
9970       include 'COMMON.VAR'
9971       include 'COMMON.GEO'
9972       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9973       logical swap
9974       logical lprn
9975       common /kutas/ lprn
9976 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9977 C                                                                              C
9978 C      Parallel       Antiparallel                                             C
9979 C                                                                              C
9980 C          o             o                                                     C
9981 C         /l\           /j\                                                    C
9982 C        /   \         /   \                                                   C
9983 C       /| o |         | o |\                                                  C
9984 C     \ j|/k\|  /   \  |/k\|l /                                                C
9985 C      \ /   \ /     \ /   \ /                                                 C
9986 C       o     o       o     o                                                  C
9987 C       i             i                                                        C
9988 C                                                                              C
9989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9990       itk=itype2loc(itype(k))
9991       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9992       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9993       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9994       call transpose2(EUgC(1,1,k),auxmat(1,1))
9995       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9996       vv1(1)=pizda1(1,1)-pizda1(2,2)
9997       vv1(2)=pizda1(1,2)+pizda1(2,1)
9998       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9999       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10000       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10001       s5=scalar2(vv(1),Dtobr2(1,i))
10002 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10003       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10004       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10005      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10006      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10007      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10008      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10009      & +scalar2(vv(1),Dtobr2der(1,i)))
10010       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10011       vv1(1)=pizda1(1,1)-pizda1(2,2)
10012       vv1(2)=pizda1(1,2)+pizda1(2,1)
10013       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10014       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10015       if (l.eq.j+1) then
10016         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10017      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10018      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10019      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10020      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10021       else
10022         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10023      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10024      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10025      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10026      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10027       endif
10028       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10029       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10030       vv1(1)=pizda1(1,1)-pizda1(2,2)
10031       vv1(2)=pizda1(1,2)+pizda1(2,1)
10032       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10033      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10034      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10035      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10036       do iii=1,2
10037         if (swap) then
10038           ind=3-iii
10039         else
10040           ind=iii
10041         endif
10042         do kkk=1,5
10043           do lll=1,3
10044             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10045             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10046             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10047             call transpose2(EUgC(1,1,k),auxmat(1,1))
10048             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10049      &        pizda1(1,1))
10050             vv1(1)=pizda1(1,1)-pizda1(2,2)
10051             vv1(2)=pizda1(1,2)+pizda1(2,1)
10052             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10053             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10054      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10055             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10056      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10057             s5=scalar2(vv(1),Dtobr2(1,i))
10058             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10059           enddo
10060         enddo
10061       enddo
10062       return
10063       end
10064 c----------------------------------------------------------------------------
10065       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10066       implicit real*8 (a-h,o-z)
10067       include 'DIMENSIONS'
10068       include 'COMMON.IOUNITS'
10069       include 'COMMON.CHAIN'
10070       include 'COMMON.DERIV'
10071       include 'COMMON.INTERACT'
10072       include 'COMMON.CONTACTS'
10073       include 'COMMON.TORSION'
10074       include 'COMMON.VAR'
10075       include 'COMMON.GEO'
10076       logical swap
10077       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10078      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10079       logical lprn
10080       common /kutas/ lprn
10081 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10082 C                                                                              C
10083 C      Parallel       Antiparallel                                             C
10084 C                                                                              C
10085 C          o             o                                                     C
10086 C     \   /l\           /j\   /                                                C
10087 C      \ /   \         /   \ /                                                 C
10088 C       o| o |         | o |o                                                  C
10089 C     \ j|/k\|      \  |/k\|l                                                  C
10090 C      \ /   \       \ /   \                                                   C
10091 C       o             o                                                        C
10092 C       i             i                                                        C
10093 C                                                                              C
10094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10095 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10096 C AL 7/4/01 s1 would occur in the sixth-order moment,
10097 C           but not in a cluster cumulant
10098 #ifdef MOMENT
10099       s1=dip(1,jj,i)*dip(1,kk,k)
10100 #endif
10101       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10102       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10103       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10104       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10105       call transpose2(EUg(1,1,k),auxmat(1,1))
10106       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10107       vv(1)=pizda(1,1)-pizda(2,2)
10108       vv(2)=pizda(1,2)+pizda(2,1)
10109       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10110 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10111 #ifdef MOMENT
10112       eello6_graph2=-(s1+s2+s3+s4)
10113 #else
10114       eello6_graph2=-(s2+s3+s4)
10115 #endif
10116 c      eello6_graph2=-s3
10117 C Derivatives in gamma(i-1)
10118       if (i.gt.1) then
10119 #ifdef MOMENT
10120         s1=dipderg(1,jj,i)*dip(1,kk,k)
10121 #endif
10122         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10123         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10124         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10125         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10126 #ifdef MOMENT
10127         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10128 #else
10129         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10130 #endif
10131 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10132       endif
10133 C Derivatives in gamma(k-1)
10134 #ifdef MOMENT
10135       s1=dip(1,jj,i)*dipderg(1,kk,k)
10136 #endif
10137       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10138       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10139       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10140       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10141       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10142       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10143       vv(1)=pizda(1,1)-pizda(2,2)
10144       vv(2)=pizda(1,2)+pizda(2,1)
10145       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10146 #ifdef MOMENT
10147       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10148 #else
10149       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10150 #endif
10151 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10152 C Derivatives in gamma(j-1) or gamma(l-1)
10153       if (j.gt.1) then
10154 #ifdef MOMENT
10155         s1=dipderg(3,jj,i)*dip(1,kk,k)
10156 #endif
10157         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10158         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10159         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10160         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10161         vv(1)=pizda(1,1)-pizda(2,2)
10162         vv(2)=pizda(1,2)+pizda(2,1)
10163         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10164 #ifdef MOMENT
10165         if (swap) then
10166           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10167         else
10168           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10169         endif
10170 #endif
10171         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10172 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10173       endif
10174 C Derivatives in gamma(l-1) or gamma(j-1)
10175       if (l.gt.1) then
10176 #ifdef MOMENT
10177         s1=dip(1,jj,i)*dipderg(3,kk,k)
10178 #endif
10179         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10180         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10181         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10182         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10183         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10184         vv(1)=pizda(1,1)-pizda(2,2)
10185         vv(2)=pizda(1,2)+pizda(2,1)
10186         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10187 #ifdef MOMENT
10188         if (swap) then
10189           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10190         else
10191           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10192         endif
10193 #endif
10194         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10195 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10196       endif
10197 C Cartesian derivatives.
10198       if (lprn) then
10199         write (2,*) 'In eello6_graph2'
10200         do iii=1,2
10201           write (2,*) 'iii=',iii
10202           do kkk=1,5
10203             write (2,*) 'kkk=',kkk
10204             do jjj=1,2
10205               write (2,'(3(2f10.5),5x)')
10206      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10207             enddo
10208           enddo
10209         enddo
10210       endif
10211       do iii=1,2
10212         do kkk=1,5
10213           do lll=1,3
10214 #ifdef MOMENT
10215             if (iii.eq.1) then
10216               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10217             else
10218               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10219             endif
10220 #endif
10221             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10222      &        auxvec(1))
10223             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10224             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10225      &        auxvec(1))
10226             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10227             call transpose2(EUg(1,1,k),auxmat(1,1))
10228             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10229      &        pizda(1,1))
10230             vv(1)=pizda(1,1)-pizda(2,2)
10231             vv(2)=pizda(1,2)+pizda(2,1)
10232             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10233 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10234 #ifdef MOMENT
10235             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10236 #else
10237             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10238 #endif
10239             if (swap) then
10240               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10241             else
10242               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10243             endif
10244           enddo
10245         enddo
10246       enddo
10247       return
10248       end
10249 c----------------------------------------------------------------------------
10250       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10251       implicit real*8 (a-h,o-z)
10252       include 'DIMENSIONS'
10253       include 'COMMON.IOUNITS'
10254       include 'COMMON.CHAIN'
10255       include 'COMMON.DERIV'
10256       include 'COMMON.INTERACT'
10257       include 'COMMON.CONTACTS'
10258       include 'COMMON.TORSION'
10259       include 'COMMON.VAR'
10260       include 'COMMON.GEO'
10261       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10262       logical swap
10263 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10264 C                                                                              C
10265 C      Parallel       Antiparallel                                             C
10266 C                                                                              C
10267 C          o             o                                                     C
10268 C         /l\   /   \   /j\                                                    C
10269 C        /   \ /     \ /   \                                                   C
10270 C       /| o |o       o| o |\                                                  C
10271 C       j|/k\|  /      |/k\|l /                                                C
10272 C        /   \ /       /   \ /                                                 C
10273 C       /     o       /     o                                                  C
10274 C       i             i                                                        C
10275 C                                                                              C
10276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10277 C
10278 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10279 C           energy moment and not to the cluster cumulant.
10280       iti=itortyp(itype(i))
10281       if (j.lt.nres-1) then
10282         itj1=itype2loc(itype(j+1))
10283       else
10284         itj1=nloctyp
10285       endif
10286       itk=itype2loc(itype(k))
10287       itk1=itype2loc(itype(k+1))
10288       if (l.lt.nres-1) then
10289         itl1=itype2loc(itype(l+1))
10290       else
10291         itl1=nloctyp
10292       endif
10293 #ifdef MOMENT
10294       s1=dip(4,jj,i)*dip(4,kk,k)
10295 #endif
10296       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10297       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10298       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10299       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10300       call transpose2(EE(1,1,k),auxmat(1,1))
10301       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10302       vv(1)=pizda(1,1)+pizda(2,2)
10303       vv(2)=pizda(2,1)-pizda(1,2)
10304       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10305 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10306 cd     & "sum",-(s2+s3+s4)
10307 #ifdef MOMENT
10308       eello6_graph3=-(s1+s2+s3+s4)
10309 #else
10310       eello6_graph3=-(s2+s3+s4)
10311 #endif
10312 c      eello6_graph3=-s4
10313 C Derivatives in gamma(k-1)
10314       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10315       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10316       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10317       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10318 C Derivatives in gamma(l-1)
10319       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10320       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10321       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10322       vv(1)=pizda(1,1)+pizda(2,2)
10323       vv(2)=pizda(2,1)-pizda(1,2)
10324       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10325       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10326 C Cartesian derivatives.
10327       do iii=1,2
10328         do kkk=1,5
10329           do lll=1,3
10330 #ifdef MOMENT
10331             if (iii.eq.1) then
10332               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10333             else
10334               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10335             endif
10336 #endif
10337             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10338      &        auxvec(1))
10339             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10340             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10341      &        auxvec(1))
10342             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10343             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10344      &        pizda(1,1))
10345             vv(1)=pizda(1,1)+pizda(2,2)
10346             vv(2)=pizda(2,1)-pizda(1,2)
10347             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10348 #ifdef MOMENT
10349             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10350 #else
10351             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10352 #endif
10353             if (swap) then
10354               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10355             else
10356               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10357             endif
10358 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10359           enddo
10360         enddo
10361       enddo
10362       return
10363       end
10364 c----------------------------------------------------------------------------
10365       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10366       implicit real*8 (a-h,o-z)
10367       include 'DIMENSIONS'
10368       include 'COMMON.IOUNITS'
10369       include 'COMMON.CHAIN'
10370       include 'COMMON.DERIV'
10371       include 'COMMON.INTERACT'
10372       include 'COMMON.CONTACTS'
10373       include 'COMMON.TORSION'
10374       include 'COMMON.VAR'
10375       include 'COMMON.GEO'
10376       include 'COMMON.FFIELD'
10377       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10378      & auxvec1(2),auxmat1(2,2)
10379       logical swap
10380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10381 C                                                                              C
10382 C      Parallel       Antiparallel                                             C
10383 C                                                                              C
10384 C          o             o                                                     C
10385 C         /l\   /   \   /j\                                                    C
10386 C        /   \ /     \ /   \                                                   C
10387 C       /| o |o       o| o |\                                                  C
10388 C     \ j|/k\|      \  |/k\|l                                                  C
10389 C      \ /   \       \ /   \                                                   C
10390 C       o     \       o     \                                                  C
10391 C       i             i                                                        C
10392 C                                                                              C
10393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10394 C
10395 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10396 C           energy moment and not to the cluster cumulant.
10397 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10398       iti=itype2loc(itype(i))
10399       itj=itype2loc(itype(j))
10400       if (j.lt.nres-1) then
10401         itj1=itype2loc(itype(j+1))
10402       else
10403         itj1=nloctyp
10404       endif
10405       itk=itype2loc(itype(k))
10406       if (k.lt.nres-1) then
10407         itk1=itype2loc(itype(k+1))
10408       else
10409         itk1=nloctyp
10410       endif
10411       itl=itype2loc(itype(l))
10412       if (l.lt.nres-1) then
10413         itl1=itype2loc(itype(l+1))
10414       else
10415         itl1=nloctyp
10416       endif
10417 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10418 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10419 cd     & ' itl',itl,' itl1',itl1
10420 #ifdef MOMENT
10421       if (imat.eq.1) then
10422         s1=dip(3,jj,i)*dip(3,kk,k)
10423       else
10424         s1=dip(2,jj,j)*dip(2,kk,l)
10425       endif
10426 #endif
10427       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10428       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10429       if (j.eq.l+1) then
10430         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10431         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10432       else
10433         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10434         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10435       endif
10436       call transpose2(EUg(1,1,k),auxmat(1,1))
10437       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10438       vv(1)=pizda(1,1)-pizda(2,2)
10439       vv(2)=pizda(2,1)+pizda(1,2)
10440       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10441 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10442 #ifdef MOMENT
10443       eello6_graph4=-(s1+s2+s3+s4)
10444 #else
10445       eello6_graph4=-(s2+s3+s4)
10446 #endif
10447 C Derivatives in gamma(i-1)
10448       if (i.gt.1) then
10449 #ifdef MOMENT
10450         if (imat.eq.1) then
10451           s1=dipderg(2,jj,i)*dip(3,kk,k)
10452         else
10453           s1=dipderg(4,jj,j)*dip(2,kk,l)
10454         endif
10455 #endif
10456         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10457         if (j.eq.l+1) then
10458           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10459           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10460         else
10461           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10462           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10463         endif
10464         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10465         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10466 cd          write (2,*) 'turn6 derivatives'
10467 #ifdef MOMENT
10468           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10469 #else
10470           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10471 #endif
10472         else
10473 #ifdef MOMENT
10474           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10475 #else
10476           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10477 #endif
10478         endif
10479       endif
10480 C Derivatives in gamma(k-1)
10481 #ifdef MOMENT
10482       if (imat.eq.1) then
10483         s1=dip(3,jj,i)*dipderg(2,kk,k)
10484       else
10485         s1=dip(2,jj,j)*dipderg(4,kk,l)
10486       endif
10487 #endif
10488       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10489       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10490       if (j.eq.l+1) then
10491         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10492         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10493       else
10494         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10495         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10496       endif
10497       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10498       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10499       vv(1)=pizda(1,1)-pizda(2,2)
10500       vv(2)=pizda(2,1)+pizda(1,2)
10501       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10502       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10503 #ifdef MOMENT
10504         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10505 #else
10506         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10507 #endif
10508       else
10509 #ifdef MOMENT
10510         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10511 #else
10512         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10513 #endif
10514       endif
10515 C Derivatives in gamma(j-1) or gamma(l-1)
10516       if (l.eq.j+1 .and. l.gt.1) then
10517         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10518         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10519         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10520         vv(1)=pizda(1,1)-pizda(2,2)
10521         vv(2)=pizda(2,1)+pizda(1,2)
10522         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10523         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10524       else if (j.gt.1) then
10525         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10526         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10527         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10528         vv(1)=pizda(1,1)-pizda(2,2)
10529         vv(2)=pizda(2,1)+pizda(1,2)
10530         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10531         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10532           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10533         else
10534           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10535         endif
10536       endif
10537 C Cartesian derivatives.
10538       do iii=1,2
10539         do kkk=1,5
10540           do lll=1,3
10541 #ifdef MOMENT
10542             if (iii.eq.1) then
10543               if (imat.eq.1) then
10544                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10545               else
10546                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10547               endif
10548             else
10549               if (imat.eq.1) then
10550                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10551               else
10552                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10553               endif
10554             endif
10555 #endif
10556             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10557      &        auxvec(1))
10558             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10559             if (j.eq.l+1) then
10560               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10561      &          b1(1,j+1),auxvec(1))
10562               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10563             else
10564               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10565      &          b1(1,l+1),auxvec(1))
10566               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10567             endif
10568             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10569      &        pizda(1,1))
10570             vv(1)=pizda(1,1)-pizda(2,2)
10571             vv(2)=pizda(2,1)+pizda(1,2)
10572             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10573             if (swap) then
10574               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10575 #ifdef MOMENT
10576                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10577      &             -(s1+s2+s4)
10578 #else
10579                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10580      &             -(s2+s4)
10581 #endif
10582                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10583               else
10584 #ifdef MOMENT
10585                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10586 #else
10587                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10588 #endif
10589                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10590               endif
10591             else
10592 #ifdef MOMENT
10593               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10594 #else
10595               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10596 #endif
10597               if (l.eq.j+1) then
10598                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10599               else
10600                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10601               endif
10602             endif
10603           enddo
10604         enddo
10605       enddo
10606       return
10607       end
10608 c----------------------------------------------------------------------------
10609       double precision function eello_turn6(i,jj,kk)
10610       implicit real*8 (a-h,o-z)
10611       include 'DIMENSIONS'
10612       include 'COMMON.IOUNITS'
10613       include 'COMMON.CHAIN'
10614       include 'COMMON.DERIV'
10615       include 'COMMON.INTERACT'
10616       include 'COMMON.CONTACTS'
10617       include 'COMMON.TORSION'
10618       include 'COMMON.VAR'
10619       include 'COMMON.GEO'
10620       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10621      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10622      &  ggg1(3),ggg2(3)
10623       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10624      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10625 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10626 C           the respective energy moment and not to the cluster cumulant.
10627       s1=0.0d0
10628       s8=0.0d0
10629       s13=0.0d0
10630 c
10631       eello_turn6=0.0d0
10632       j=i+4
10633       k=i+1
10634       l=i+3
10635       iti=itype2loc(itype(i))
10636       itk=itype2loc(itype(k))
10637       itk1=itype2loc(itype(k+1))
10638       itl=itype2loc(itype(l))
10639       itj=itype2loc(itype(j))
10640 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10641 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10642 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10643 cd        eello6=0.0d0
10644 cd        return
10645 cd      endif
10646 cd      write (iout,*)
10647 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10648 cd     &   ' and',k,l
10649 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10650       do iii=1,2
10651         do kkk=1,5
10652           do lll=1,3
10653             derx_turn(lll,kkk,iii)=0.0d0
10654           enddo
10655         enddo
10656       enddo
10657 cd      eij=1.0d0
10658 cd      ekl=1.0d0
10659 cd      ekont=1.0d0
10660       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10661 cd      eello6_5=0.0d0
10662 cd      write (2,*) 'eello6_5',eello6_5
10663 #ifdef MOMENT
10664       call transpose2(AEA(1,1,1),auxmat(1,1))
10665       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10666       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10667       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10668 #endif
10669       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10670       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10671       s2 = scalar2(b1(1,k),vtemp1(1))
10672 #ifdef MOMENT
10673       call transpose2(AEA(1,1,2),atemp(1,1))
10674       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10675       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10676       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10677 #endif
10678       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10679       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10680       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10681 #ifdef MOMENT
10682       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10683       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10684       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10685       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10686       ss13 = scalar2(b1(1,k),vtemp4(1))
10687       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10688 #endif
10689 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10690 c      s1=0.0d0
10691 c      s2=0.0d0
10692 c      s8=0.0d0
10693 c      s12=0.0d0
10694 c      s13=0.0d0
10695       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10696 C Derivatives in gamma(i+2)
10697       s1d =0.0d0
10698       s8d =0.0d0
10699 #ifdef MOMENT
10700       call transpose2(AEA(1,1,1),auxmatd(1,1))
10701       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10702       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10703       call transpose2(AEAderg(1,1,2),atempd(1,1))
10704       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10705       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10706 #endif
10707       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10708       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10709       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10710 c      s1d=0.0d0
10711 c      s2d=0.0d0
10712 c      s8d=0.0d0
10713 c      s12d=0.0d0
10714 c      s13d=0.0d0
10715       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10716 C Derivatives in gamma(i+3)
10717 #ifdef MOMENT
10718       call transpose2(AEA(1,1,1),auxmatd(1,1))
10719       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10720       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10721       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10722 #endif
10723       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10724       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10725       s2d = scalar2(b1(1,k),vtemp1d(1))
10726 #ifdef MOMENT
10727       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10728       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10729 #endif
10730       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10731 #ifdef MOMENT
10732       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10733       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10734       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10735 #endif
10736 c      s1d=0.0d0
10737 c      s2d=0.0d0
10738 c      s8d=0.0d0
10739 c      s12d=0.0d0
10740 c      s13d=0.0d0
10741 #ifdef MOMENT
10742       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10743      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10744 #else
10745       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10746      &               -0.5d0*ekont*(s2d+s12d)
10747 #endif
10748 C Derivatives in gamma(i+4)
10749       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10750       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10751       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10752 #ifdef MOMENT
10753       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10754       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10755       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10756 #endif
10757 c      s1d=0.0d0
10758 c      s2d=0.0d0
10759 c      s8d=0.0d0
10760 C      s12d=0.0d0
10761 c      s13d=0.0d0
10762 #ifdef MOMENT
10763       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10764 #else
10765       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10766 #endif
10767 C Derivatives in gamma(i+5)
10768 #ifdef MOMENT
10769       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10770       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10771       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10772 #endif
10773       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10774       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10775       s2d = scalar2(b1(1,k),vtemp1d(1))
10776 #ifdef MOMENT
10777       call transpose2(AEA(1,1,2),atempd(1,1))
10778       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10779       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10780 #endif
10781       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10782       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10783 #ifdef MOMENT
10784       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10785       ss13d = scalar2(b1(1,k),vtemp4d(1))
10786       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10787 #endif
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       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10795      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10796 #else
10797       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10798      &               -0.5d0*ekont*(s2d+s12d)
10799 #endif
10800 C Cartesian derivatives
10801       do iii=1,2
10802         do kkk=1,5
10803           do lll=1,3
10804 #ifdef MOMENT
10805             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10806             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10807             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10808 #endif
10809             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10810             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10811      &          vtemp1d(1))
10812             s2d = scalar2(b1(1,k),vtemp1d(1))
10813 #ifdef MOMENT
10814             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10815             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10816             s8d = -(atempd(1,1)+atempd(2,2))*
10817      &           scalar2(cc(1,1,itl),vtemp2(1))
10818 #endif
10819             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10820      &           auxmatd(1,1))
10821             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10822             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10823 c      s1d=0.0d0
10824 c      s2d=0.0d0
10825 c      s8d=0.0d0
10826 c      s12d=0.0d0
10827 c      s13d=0.0d0
10828 #ifdef MOMENT
10829             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10830      &        - 0.5d0*(s1d+s2d)
10831 #else
10832             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10833      &        - 0.5d0*s2d
10834 #endif
10835 #ifdef MOMENT
10836             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10837      &        - 0.5d0*(s8d+s12d)
10838 #else
10839             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10840      &        - 0.5d0*s12d
10841 #endif
10842           enddo
10843         enddo
10844       enddo
10845 #ifdef MOMENT
10846       do kkk=1,5
10847         do lll=1,3
10848           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10849      &      achuj_tempd(1,1))
10850           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10851           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10852           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10853           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10854           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10855      &      vtemp4d(1))
10856           ss13d = scalar2(b1(1,k),vtemp4d(1))
10857           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10858           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10859         enddo
10860       enddo
10861 #endif
10862 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10863 cd     &  16*eel_turn6_num
10864 cd      goto 1112
10865       if (j.lt.nres-1) then
10866         j1=j+1
10867         j2=j-1
10868       else
10869         j1=j-1
10870         j2=j-2
10871       endif
10872       if (l.lt.nres-1) then
10873         l1=l+1
10874         l2=l-1
10875       else
10876         l1=l-1
10877         l2=l-2
10878       endif
10879       do ll=1,3
10880 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10881 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10882 cgrad        ghalf=0.5d0*ggg1(ll)
10883 cd        ghalf=0.0d0
10884         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10885         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10886         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10887      &    +ekont*derx_turn(ll,2,1)
10888         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10889         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10890      &    +ekont*derx_turn(ll,4,1)
10891         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10892         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10893         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10894 cgrad        ghalf=0.5d0*ggg2(ll)
10895 cd        ghalf=0.0d0
10896         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10897      &    +ekont*derx_turn(ll,2,2)
10898         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10899         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10900      &    +ekont*derx_turn(ll,4,2)
10901         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10902         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10903         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10904       enddo
10905 cd      goto 1112
10906 cgrad      do m=i+1,j-1
10907 cgrad        do ll=1,3
10908 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10909 cgrad        enddo
10910 cgrad      enddo
10911 cgrad      do m=k+1,l-1
10912 cgrad        do ll=1,3
10913 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10914 cgrad        enddo
10915 cgrad      enddo
10916 cgrad1112  continue
10917 cgrad      do m=i+2,j2
10918 cgrad        do ll=1,3
10919 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10920 cgrad        enddo
10921 cgrad      enddo
10922 cgrad      do m=k+2,l2
10923 cgrad        do ll=1,3
10924 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10925 cgrad        enddo
10926 cgrad      enddo
10927 cd      do iii=1,nres-3
10928 cd        write (2,*) iii,g_corr6_loc(iii)
10929 cd      enddo
10930       eello_turn6=ekont*eel_turn6
10931 cd      write (2,*) 'ekont',ekont
10932 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10933       return
10934       end
10935
10936 C-----------------------------------------------------------------------------
10937       double precision function scalar(u,v)
10938 !DIR$ INLINEALWAYS scalar
10939 #ifndef OSF
10940 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10941 #endif
10942       implicit none
10943       double precision u(3),v(3)
10944 cd      double precision sc
10945 cd      integer i
10946 cd      sc=0.0d0
10947 cd      do i=1,3
10948 cd        sc=sc+u(i)*v(i)
10949 cd      enddo
10950 cd      scalar=sc
10951
10952       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10953       return
10954       end
10955 crc-------------------------------------------------
10956       SUBROUTINE MATVEC2(A1,V1,V2)
10957 !DIR$ INLINEALWAYS MATVEC2
10958 #ifndef OSF
10959 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10960 #endif
10961       implicit real*8 (a-h,o-z)
10962       include 'DIMENSIONS'
10963       DIMENSION A1(2,2),V1(2),V2(2)
10964 c      DO 1 I=1,2
10965 c        VI=0.0
10966 c        DO 3 K=1,2
10967 c    3     VI=VI+A1(I,K)*V1(K)
10968 c        Vaux(I)=VI
10969 c    1 CONTINUE
10970
10971       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10972       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10973
10974       v2(1)=vaux1
10975       v2(2)=vaux2
10976       END
10977 C---------------------------------------
10978       SUBROUTINE MATMAT2(A1,A2,A3)
10979 #ifndef OSF
10980 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10981 #endif
10982       implicit real*8 (a-h,o-z)
10983       include 'DIMENSIONS'
10984       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10985 c      DIMENSION AI3(2,2)
10986 c        DO  J=1,2
10987 c          A3IJ=0.0
10988 c          DO K=1,2
10989 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10990 c          enddo
10991 c          A3(I,J)=A3IJ
10992 c       enddo
10993 c      enddo
10994
10995       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10996       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10997       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10998       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10999
11000       A3(1,1)=AI3_11
11001       A3(2,1)=AI3_21
11002       A3(1,2)=AI3_12
11003       A3(2,2)=AI3_22
11004       END
11005
11006 c-------------------------------------------------------------------------
11007       double precision function scalar2(u,v)
11008 !DIR$ INLINEALWAYS scalar2
11009       implicit none
11010       double precision u(2),v(2)
11011       double precision sc
11012       integer i
11013       scalar2=u(1)*v(1)+u(2)*v(2)
11014       return
11015       end
11016
11017 C-----------------------------------------------------------------------------
11018
11019       subroutine transpose2(a,at)
11020 !DIR$ INLINEALWAYS transpose2
11021 #ifndef OSF
11022 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11023 #endif
11024       implicit none
11025       double precision a(2,2),at(2,2)
11026       at(1,1)=a(1,1)
11027       at(1,2)=a(2,1)
11028       at(2,1)=a(1,2)
11029       at(2,2)=a(2,2)
11030       return
11031       end
11032 c--------------------------------------------------------------------------
11033       subroutine transpose(n,a,at)
11034       implicit none
11035       integer n,i,j
11036       double precision a(n,n),at(n,n)
11037       do i=1,n
11038         do j=1,n
11039           at(j,i)=a(i,j)
11040         enddo
11041       enddo
11042       return
11043       end
11044 C---------------------------------------------------------------------------
11045       subroutine prodmat3(a1,a2,kk,transp,prod)
11046 !DIR$ INLINEALWAYS prodmat3
11047 #ifndef OSF
11048 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11049 #endif
11050       implicit none
11051       integer i,j
11052       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11053       logical transp
11054 crc      double precision auxmat(2,2),prod_(2,2)
11055
11056       if (transp) then
11057 crc        call transpose2(kk(1,1),auxmat(1,1))
11058 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11059 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11060
11061            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11062      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11063            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11064      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11065            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11066      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11067            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11068      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11069
11070       else
11071 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11072 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11073
11074            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11075      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11076            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11077      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11078            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11079      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11080            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11081      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11082
11083       endif
11084 c      call transpose2(a2(1,1),a2t(1,1))
11085
11086 crc      print *,transp
11087 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11088 crc      print *,((prod(i,j),i=1,2),j=1,2)
11089
11090       return
11091       end
11092 CCC----------------------------------------------
11093       subroutine Eliptransfer(eliptran)
11094       implicit real*8 (a-h,o-z)
11095       include 'DIMENSIONS'
11096       include 'COMMON.GEO'
11097       include 'COMMON.VAR'
11098       include 'COMMON.LOCAL'
11099       include 'COMMON.CHAIN'
11100       include 'COMMON.DERIV'
11101       include 'COMMON.NAMES'
11102       include 'COMMON.INTERACT'
11103       include 'COMMON.IOUNITS'
11104       include 'COMMON.CALC'
11105       include 'COMMON.CONTROL'
11106       include 'COMMON.SPLITELE'
11107       include 'COMMON.SBRIDGE'
11108 C this is done by Adasko
11109 C      print *,"wchodze"
11110 C structure of box:
11111 C      water
11112 C--bordliptop-- buffore starts
11113 C--bufliptop--- here true lipid starts
11114 C      lipid
11115 C--buflipbot--- lipid ends buffore starts
11116 C--bordlipbot--buffore ends
11117       eliptran=0.0
11118       do i=ilip_start,ilip_end
11119 C       do i=1,1
11120         if (itype(i).eq.ntyp1) cycle
11121
11122         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11123         if (positi.le.0) positi=positi+boxzsize
11124 C        print *,i
11125 C first for peptide groups
11126 c for each residue check if it is in lipid or lipid water border area
11127        if ((positi.gt.bordlipbot)
11128      &.and.(positi.lt.bordliptop)) then
11129 C the energy transfer exist
11130         if (positi.lt.buflipbot) then
11131 C what fraction I am in
11132          fracinbuf=1.0d0-
11133      &        ((positi-bordlipbot)/lipbufthick)
11134 C lipbufthick is thickenes of lipid buffore
11135          sslip=sscalelip(fracinbuf)
11136          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11137          eliptran=eliptran+sslip*pepliptran
11138          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11139          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11140 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11141
11142 C        print *,"doing sccale for lower part"
11143 C         print *,i,sslip,fracinbuf,ssgradlip
11144         elseif (positi.gt.bufliptop) then
11145          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11146          sslip=sscalelip(fracinbuf)
11147          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11148          eliptran=eliptran+sslip*pepliptran
11149          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11150          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11151 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11152 C          print *, "doing sscalefor top part"
11153 C         print *,i,sslip,fracinbuf,ssgradlip
11154         else
11155          eliptran=eliptran+pepliptran
11156 C         print *,"I am in true lipid"
11157         endif
11158 C       else
11159 C       eliptran=elpitran+0.0 ! I am in water
11160        endif
11161        enddo
11162 C       print *, "nic nie bylo w lipidzie?"
11163 C now multiply all by the peptide group transfer factor
11164 C       eliptran=eliptran*pepliptran
11165 C now the same for side chains
11166 CV       do i=1,1
11167        do i=ilip_start,ilip_end
11168         if (itype(i).eq.ntyp1) cycle
11169         positi=(mod(c(3,i+nres),boxzsize))
11170         if (positi.le.0) positi=positi+boxzsize
11171 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11172 c for each residue check if it is in lipid or lipid water border area
11173 C       respos=mod(c(3,i+nres),boxzsize)
11174 C       print *,positi,bordlipbot,buflipbot
11175        if ((positi.gt.bordlipbot)
11176      & .and.(positi.lt.bordliptop)) then
11177 C the energy transfer exist
11178         if (positi.lt.buflipbot) then
11179          fracinbuf=1.0d0-
11180      &     ((positi-bordlipbot)/lipbufthick)
11181 C lipbufthick is thickenes of lipid buffore
11182          sslip=sscalelip(fracinbuf)
11183          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11184          eliptran=eliptran+sslip*liptranene(itype(i))
11185          gliptranx(3,i)=gliptranx(3,i)
11186      &+ssgradlip*liptranene(itype(i))
11187          gliptranc(3,i-1)= gliptranc(3,i-1)
11188      &+ssgradlip*liptranene(itype(i))
11189 C         print *,"doing sccale for lower part"
11190         elseif (positi.gt.bufliptop) then
11191          fracinbuf=1.0d0-
11192      &((bordliptop-positi)/lipbufthick)
11193          sslip=sscalelip(fracinbuf)
11194          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11195          eliptran=eliptran+sslip*liptranene(itype(i))
11196          gliptranx(3,i)=gliptranx(3,i)
11197      &+ssgradlip*liptranene(itype(i))
11198          gliptranc(3,i-1)= gliptranc(3,i-1)
11199      &+ssgradlip*liptranene(itype(i))
11200 C          print *, "doing sscalefor top part",sslip,fracinbuf
11201         else
11202          eliptran=eliptran+liptranene(itype(i))
11203 C         print *,"I am in true lipid"
11204         endif
11205         endif ! if in lipid or buffor
11206 C       else
11207 C       eliptran=elpitran+0.0 ! I am in water
11208        enddo
11209        return
11210        end
11211 C---------------------------------------------------------
11212 C AFM soubroutine for constant force
11213        subroutine AFMforce(Eafmforce)
11214        implicit real*8 (a-h,o-z)
11215       include 'DIMENSIONS'
11216       include 'COMMON.GEO'
11217       include 'COMMON.VAR'
11218       include 'COMMON.LOCAL'
11219       include 'COMMON.CHAIN'
11220       include 'COMMON.DERIV'
11221       include 'COMMON.NAMES'
11222       include 'COMMON.INTERACT'
11223       include 'COMMON.IOUNITS'
11224       include 'COMMON.CALC'
11225       include 'COMMON.CONTROL'
11226       include 'COMMON.SPLITELE'
11227       include 'COMMON.SBRIDGE'
11228       real*8 diffafm(3)
11229       dist=0.0d0
11230       Eafmforce=0.0d0
11231       do i=1,3
11232       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11233       dist=dist+diffafm(i)**2
11234       enddo
11235       dist=dsqrt(dist)
11236       Eafmforce=-forceAFMconst*(dist-distafminit)
11237       do i=1,3
11238       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11239       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11240       enddo
11241 C      print *,'AFM',Eafmforce
11242       return
11243       end
11244 C---------------------------------------------------------
11245 C AFM subroutine with pseudoconstant velocity
11246        subroutine AFMvel(Eafmforce)
11247        implicit real*8 (a-h,o-z)
11248       include 'DIMENSIONS'
11249       include 'COMMON.GEO'
11250       include 'COMMON.VAR'
11251       include 'COMMON.LOCAL'
11252       include 'COMMON.CHAIN'
11253       include 'COMMON.DERIV'
11254       include 'COMMON.NAMES'
11255       include 'COMMON.INTERACT'
11256       include 'COMMON.IOUNITS'
11257       include 'COMMON.CALC'
11258       include 'COMMON.CONTROL'
11259       include 'COMMON.SPLITELE'
11260       include 'COMMON.SBRIDGE'
11261       real*8 diffafm(3)
11262 C Only for check grad COMMENT if not used for checkgrad
11263 C      totT=3.0d0
11264 C--------------------------------------------------------
11265 C      print *,"wchodze"
11266       dist=0.0d0
11267       Eafmforce=0.0d0
11268       do i=1,3
11269       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11270       dist=dist+diffafm(i)**2
11271       enddo
11272       dist=dsqrt(dist)
11273       Eafmforce=0.5d0*forceAFMconst
11274      & *(distafminit+totTafm*velAFMconst-dist)**2
11275 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11276       do i=1,3
11277       gradafm(i,afmend-1)=-forceAFMconst*
11278      &(distafminit+totTafm*velAFMconst-dist)
11279      &*diffafm(i)/dist
11280       gradafm(i,afmbeg-1)=forceAFMconst*
11281      &(distafminit+totTafm*velAFMconst-dist)
11282      &*diffafm(i)/dist
11283       enddo
11284 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11285       return
11286       end
11287 C-----------------------------------------------------------
11288 C first for shielding is setting of function of side-chains
11289        subroutine set_shield_fac
11290       implicit real*8 (a-h,o-z)
11291       include 'DIMENSIONS'
11292       include 'COMMON.CHAIN'
11293       include 'COMMON.DERIV'
11294       include 'COMMON.IOUNITS'
11295       include 'COMMON.SHIELD'
11296       include 'COMMON.INTERACT'
11297 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11298       double precision div77_81/0.974996043d0/,
11299      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11300
11301 C the vector between center of side_chain and peptide group
11302        double precision pep_side(3),long,side_calf(3),
11303      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11304      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11305 C the line belowe needs to be changed for FGPROC>1
11306       do i=1,nres-1
11307       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11308       ishield_list(i)=0
11309 Cif there two consequtive dummy atoms there is no peptide group between them
11310 C the line below has to be changed for FGPROC>1
11311       VolumeTotal=0.0
11312       do k=1,nres
11313        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11314        dist_pep_side=0.0
11315        dist_side_calf=0.0
11316        do j=1,3
11317 C first lets set vector conecting the ithe side-chain with kth side-chain
11318       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11319 C      pep_side(j)=2.0d0
11320 C and vector conecting the side-chain with its proper calfa
11321       side_calf(j)=c(j,k+nres)-c(j,k)
11322 C      side_calf(j)=2.0d0
11323       pept_group(j)=c(j,i)-c(j,i+1)
11324 C lets have their lenght
11325       dist_pep_side=pep_side(j)**2+dist_pep_side
11326       dist_side_calf=dist_side_calf+side_calf(j)**2
11327       dist_pept_group=dist_pept_group+pept_group(j)**2
11328       enddo
11329        dist_pep_side=dsqrt(dist_pep_side)
11330        dist_pept_group=dsqrt(dist_pept_group)
11331        dist_side_calf=dsqrt(dist_side_calf)
11332       do j=1,3
11333         pep_side_norm(j)=pep_side(j)/dist_pep_side
11334         side_calf_norm(j)=dist_side_calf
11335       enddo
11336 C now sscale fraction
11337        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11338 C       print *,buff_shield,"buff"
11339 C now sscale
11340         if (sh_frac_dist.le.0.0) cycle
11341 C If we reach here it means that this side chain reaches the shielding sphere
11342 C Lets add him to the list for gradient
11343         ishield_list(i)=ishield_list(i)+1
11344 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11345 C this list is essential otherwise problem would be O3
11346         shield_list(ishield_list(i),i)=k
11347 C Lets have the sscale value
11348         if (sh_frac_dist.gt.1.0) then
11349          scale_fac_dist=1.0d0
11350          do j=1,3
11351          sh_frac_dist_grad(j)=0.0d0
11352          enddo
11353         else
11354          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11355      &                   *(2.0*sh_frac_dist-3.0d0)
11356          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11357      &                  /dist_pep_side/buff_shield*0.5
11358 C remember for the final gradient multiply sh_frac_dist_grad(j)
11359 C for side_chain by factor -2 !
11360          do j=1,3
11361          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11362 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11363 C     &                    sh_frac_dist_grad(j)
11364          enddo
11365         endif
11366 C        if ((i.eq.3).and.(k.eq.2)) then
11367 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11368 C     & ,"TU"
11369 C        endif
11370
11371 C this is what is now we have the distance scaling now volume...
11372       short=short_r_sidechain(itype(k))
11373       long=long_r_sidechain(itype(k))
11374       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11375 C now costhet_grad
11376 C       costhet=0.0d0
11377        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11378 C       costhet_fac=0.0d0
11379        do j=1,3
11380          costhet_grad(j)=costhet_fac*pep_side(j)
11381        enddo
11382 C remember for the final gradient multiply costhet_grad(j)
11383 C for side_chain by factor -2 !
11384 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11385 C pep_side0pept_group is vector multiplication
11386       pep_side0pept_group=0.0
11387       do j=1,3
11388       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11389       enddo
11390       cosalfa=(pep_side0pept_group/
11391      & (dist_pep_side*dist_side_calf))
11392       fac_alfa_sin=1.0-cosalfa**2
11393       fac_alfa_sin=dsqrt(fac_alfa_sin)
11394       rkprim=fac_alfa_sin*(long-short)+short
11395 C now costhet_grad
11396        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11397        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11398
11399        do j=1,3
11400          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11401      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11402      &*(long-short)/fac_alfa_sin*cosalfa/
11403      &((dist_pep_side*dist_side_calf))*
11404      &((side_calf(j))-cosalfa*
11405      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11406
11407         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11408      &*(long-short)/fac_alfa_sin*cosalfa
11409      &/((dist_pep_side*dist_side_calf))*
11410      &(pep_side(j)-
11411      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11412        enddo
11413
11414       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11415      &                    /VSolvSphere_div
11416      &                    *wshield
11417 C now the gradient...
11418 C grad_shield is gradient of Calfa for peptide groups
11419 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11420 C     &               costhet,cosphi
11421 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11422 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11423       do j=1,3
11424       grad_shield(j,i)=grad_shield(j,i)
11425 C gradient po skalowaniu
11426      &                +(sh_frac_dist_grad(j)
11427 C  gradient po costhet
11428      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11429      &-scale_fac_dist*(cosphi_grad_long(j))
11430      &/(1.0-cosphi) )*div77_81
11431      &*VofOverlap
11432 C grad_shield_side is Cbeta sidechain gradient
11433       grad_shield_side(j,ishield_list(i),i)=
11434      &        (sh_frac_dist_grad(j)*-2.0d0
11435      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11436      &       +scale_fac_dist*(cosphi_grad_long(j))
11437      &        *2.0d0/(1.0-cosphi))
11438      &        *div77_81*VofOverlap
11439
11440        grad_shield_loc(j,ishield_list(i),i)=
11441      &   scale_fac_dist*cosphi_grad_loc(j)
11442      &        *2.0d0/(1.0-cosphi)
11443      &        *div77_81*VofOverlap
11444       enddo
11445       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11446       enddo
11447       fac_shield(i)=VolumeTotal*div77_81+div4_81
11448 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11449       enddo
11450       return
11451       end
11452 C--------------------------------------------------------------------------
11453       double precision function tschebyshev(m,n,x,y)
11454       implicit none
11455       include "DIMENSIONS"
11456       integer i,m,n
11457       double precision x(n),y,yy(0:maxvar),aux
11458 c Tschebyshev polynomial. Note that the first term is omitted
11459 c m=0: the constant term is included
11460 c m=1: the constant term is not included
11461       yy(0)=1.0d0
11462       yy(1)=y
11463       do i=2,n
11464         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11465       enddo
11466       aux=0.0d0
11467       do i=m,n
11468         aux=aux+x(i)*yy(i)
11469       enddo
11470       tschebyshev=aux
11471       return
11472       end
11473 C--------------------------------------------------------------------------
11474       double precision function gradtschebyshev(m,n,x,y)
11475       implicit none
11476       include "DIMENSIONS"
11477       integer i,m,n
11478       double precision x(n+1),y,yy(0:maxvar),aux
11479 c Tschebyshev polynomial. Note that the first term is omitted
11480 c m=0: the constant term is included
11481 c m=1: the constant term is not included
11482       yy(0)=1.0d0
11483       yy(1)=2.0d0*y
11484       do i=2,n
11485         yy(i)=2*y*yy(i-1)-yy(i-2)
11486       enddo
11487       aux=0.0d0
11488       do i=m,n
11489         aux=aux+x(i+1)*yy(i)*(i+1)
11490 C        print *, x(i+1),yy(i),i
11491       enddo
11492       gradtschebyshev=aux
11493       return
11494       end
11495 C------------------------------------------------------------------------
11496 C first for shielding is setting of function of side-chains
11497        subroutine set_shield_fac2
11498       implicit real*8 (a-h,o-z)
11499       include 'DIMENSIONS'
11500       include 'COMMON.CHAIN'
11501       include 'COMMON.DERIV'
11502       include 'COMMON.IOUNITS'
11503       include 'COMMON.SHIELD'
11504       include 'COMMON.INTERACT'
11505 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11506       double precision div77_81/0.974996043d0/,
11507      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11508
11509 C the vector between center of side_chain and peptide group
11510        double precision pep_side(3),long,side_calf(3),
11511      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11512      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11513 C the line belowe needs to be changed for FGPROC>1
11514       do i=1,nres-1
11515       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11516       ishield_list(i)=0
11517 Cif there two consequtive dummy atoms there is no peptide group between them
11518 C the line below has to be changed for FGPROC>1
11519       VolumeTotal=0.0
11520       do k=1,nres
11521        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11522        dist_pep_side=0.0
11523        dist_side_calf=0.0
11524        do j=1,3
11525 C first lets set vector conecting the ithe side-chain with kth side-chain
11526       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11527 C      pep_side(j)=2.0d0
11528 C and vector conecting the side-chain with its proper calfa
11529       side_calf(j)=c(j,k+nres)-c(j,k)
11530 C      side_calf(j)=2.0d0
11531       pept_group(j)=c(j,i)-c(j,i+1)
11532 C lets have their lenght
11533       dist_pep_side=pep_side(j)**2+dist_pep_side
11534       dist_side_calf=dist_side_calf+side_calf(j)**2
11535       dist_pept_group=dist_pept_group+pept_group(j)**2
11536       enddo
11537        dist_pep_side=dsqrt(dist_pep_side)
11538        dist_pept_group=dsqrt(dist_pept_group)
11539        dist_side_calf=dsqrt(dist_side_calf)
11540       do j=1,3
11541         pep_side_norm(j)=pep_side(j)/dist_pep_side
11542         side_calf_norm(j)=dist_side_calf
11543       enddo
11544 C now sscale fraction
11545        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11546 C       print *,buff_shield,"buff"
11547 C now sscale
11548         if (sh_frac_dist.le.0.0) cycle
11549 C If we reach here it means that this side chain reaches the shielding sphere
11550 C Lets add him to the list for gradient
11551         ishield_list(i)=ishield_list(i)+1
11552 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11553 C this list is essential otherwise problem would be O3
11554         shield_list(ishield_list(i),i)=k
11555 C Lets have the sscale value
11556         if (sh_frac_dist.gt.1.0) then
11557          scale_fac_dist=1.0d0
11558          do j=1,3
11559          sh_frac_dist_grad(j)=0.0d0
11560          enddo
11561         else
11562          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11563      &                   *(2.0d0*sh_frac_dist-3.0d0)
11564          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11565      &                  /dist_pep_side/buff_shield*0.5d0
11566 C remember for the final gradient multiply sh_frac_dist_grad(j)
11567 C for side_chain by factor -2 !
11568          do j=1,3
11569          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11570 C         sh_frac_dist_grad(j)=0.0d0
11571 C         scale_fac_dist=1.0d0
11572 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11573 C     &                    sh_frac_dist_grad(j)
11574          enddo
11575         endif
11576 C this is what is now we have the distance scaling now volume...
11577       short=short_r_sidechain(itype(k))
11578       long=long_r_sidechain(itype(k))
11579       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11580       sinthet=short/dist_pep_side*costhet
11581 C now costhet_grad
11582 C       costhet=0.6d0
11583 C       sinthet=0.8
11584        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11585 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11586 C     &             -short/dist_pep_side**2/costhet)
11587 C       costhet_fac=0.0d0
11588        do j=1,3
11589          costhet_grad(j)=costhet_fac*pep_side(j)
11590        enddo
11591 C remember for the final gradient multiply costhet_grad(j)
11592 C for side_chain by factor -2 !
11593 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11594 C pep_side0pept_group is vector multiplication
11595       pep_side0pept_group=0.0d0
11596       do j=1,3
11597       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11598       enddo
11599       cosalfa=(pep_side0pept_group/
11600      & (dist_pep_side*dist_side_calf))
11601       fac_alfa_sin=1.0d0-cosalfa**2
11602       fac_alfa_sin=dsqrt(fac_alfa_sin)
11603       rkprim=fac_alfa_sin*(long-short)+short
11604 C      rkprim=short
11605
11606 C now costhet_grad
11607        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11608 C       cosphi=0.6
11609        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11610        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11611      &      dist_pep_side**2)
11612 C       sinphi=0.8
11613        do j=1,3
11614          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11615      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11616      &*(long-short)/fac_alfa_sin*cosalfa/
11617      &((dist_pep_side*dist_side_calf))*
11618      &((side_calf(j))-cosalfa*
11619      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11620 C       cosphi_grad_long(j)=0.0d0
11621         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11622      &*(long-short)/fac_alfa_sin*cosalfa
11623      &/((dist_pep_side*dist_side_calf))*
11624      &(pep_side(j)-
11625      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11626 C       cosphi_grad_loc(j)=0.0d0
11627        enddo
11628 C      print *,sinphi,sinthet
11629       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11630      &                    /VSolvSphere_div
11631 C     &                    *wshield
11632 C now the gradient...
11633       do j=1,3
11634       grad_shield(j,i)=grad_shield(j,i)
11635 C gradient po skalowaniu
11636      &                +(sh_frac_dist_grad(j)*VofOverlap
11637 C  gradient po costhet
11638      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11639      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11640      &       sinphi/sinthet*costhet*costhet_grad(j)
11641      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11642      & )*wshield
11643 C grad_shield_side is Cbeta sidechain gradient
11644       grad_shield_side(j,ishield_list(i),i)=
11645      &        (sh_frac_dist_grad(j)*-2.0d0
11646      &        *VofOverlap
11647      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11648      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11649      &       sinphi/sinthet*costhet*costhet_grad(j)
11650      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11651      &       )*wshield
11652
11653        grad_shield_loc(j,ishield_list(i),i)=
11654      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11655      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11656      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11657      &        ))
11658      &        *wshield
11659       enddo
11660       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11661       enddo
11662       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11663 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11664       enddo
11665       return
11666       end
11667