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       double precision kfac /2.4d0/
1010       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1011 c      facT=temp0/t_bath
1012 c      facT=2*temp0/(t_bath+temp0)
1013       if (rescale_mode.eq.0) then
1014         facT=1.0d0
1015         facT2=1.0d0
1016         facT3=1.0d0
1017         facT4=1.0d0
1018         facT5=1.0d0
1019       else if (rescale_mode.eq.1) then
1020         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1021         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1022         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1023         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1024         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1025       else if (rescale_mode.eq.2) then
1026         x=t_bath/temp0
1027         x2=x*x
1028         x3=x2*x
1029         x4=x3*x
1030         x5=x4*x
1031         facT=licznik/dlog(dexp(x)+dexp(-x))
1032         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1033         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1034         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1035         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1036       else
1037         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1038         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1039 #ifdef MPI
1040        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1041 #endif
1042        stop 555
1043       endif
1044       welec=weights(3)*fact
1045       wcorr=weights(4)*fact3
1046       wcorr5=weights(5)*fact4
1047       wcorr6=weights(6)*fact5
1048       wel_loc=weights(7)*fact2
1049       wturn3=weights(8)*fact2
1050       wturn4=weights(9)*fact3
1051       wturn6=weights(10)*fact5
1052       wtor=weights(13)*fact
1053       wtor_d=weights(14)*fact2
1054       wsccor=weights(21)*fact
1055
1056       return
1057       end
1058 C------------------------------------------------------------------------
1059       subroutine enerprint(energia)
1060       implicit real*8 (a-h,o-z)
1061       include 'DIMENSIONS'
1062       include 'COMMON.IOUNITS'
1063       include 'COMMON.FFIELD'
1064       include 'COMMON.SBRIDGE'
1065       include 'COMMON.MD'
1066       double precision energia(0:n_ene)
1067       etot=energia(0)
1068       evdw=energia(1)
1069       evdw2=energia(2)
1070 #ifdef SCP14
1071       evdw2=energia(2)+energia(18)
1072 #else
1073       evdw2=energia(2)
1074 #endif
1075       ees=energia(3)
1076 #ifdef SPLITELE
1077       evdw1=energia(16)
1078 #endif
1079       ecorr=energia(4)
1080       ecorr5=energia(5)
1081       ecorr6=energia(6)
1082       eel_loc=energia(7)
1083       eello_turn3=energia(8)
1084       eello_turn4=energia(9)
1085       eello_turn6=energia(10)
1086       ebe=energia(11)
1087       escloc=energia(12)
1088       etors=energia(13)
1089       etors_d=energia(14)
1090       ehpb=energia(15)
1091       edihcnstr=energia(19)
1092       estr=energia(17)
1093       Uconst=energia(20)
1094       esccor=energia(21)
1095       eliptran=energia(22)
1096       Eafmforce=energia(23)
1097       ethetacnstr=energia(24)
1098 #ifdef SPLITELE
1099       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1100      &  estr,wbond,ebe,wang,
1101      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1102      &  ecorr,wcorr,
1103      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1104      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1105      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1106      &  etot
1107    10 format (/'Virtual-chain energies:'//
1108      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1109      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1110      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1111      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1112      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1113      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1114      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1115      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1116      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1117      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1118      & ' (SS bridges & dist. cnstr.)'/
1119      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1121      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1122      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1123      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1124      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1125      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1126      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1127      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1128      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1129      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1130      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1131      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1132      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1133      & 'ETOT=  ',1pE16.6,' (total)')
1134
1135 #else
1136       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1137      &  estr,wbond,ebe,wang,
1138      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1139      &  ecorr,wcorr,
1140      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1141      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1142      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1143      &  etot
1144    10 format (/'Virtual-chain energies:'//
1145      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1146      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1147      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1148      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1149      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1150      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1151      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1152      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1153      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1154      & ' (SS bridges & dist. cnstr.)'/
1155      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1156      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1157      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1158      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1159      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1160      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1161      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1162      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1163      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1164      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1165      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1166      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1167      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1168      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1169      & 'ETOT=  ',1pE16.6,' (total)')
1170 #endif
1171       return
1172       end
1173 C-----------------------------------------------------------------------
1174       subroutine elj(evdw)
1175 C
1176 C This subroutine calculates the interaction energy of nonbonded side chains
1177 C assuming the LJ potential of interaction.
1178 C
1179       implicit real*8 (a-h,o-z)
1180       include 'DIMENSIONS'
1181       parameter (accur=1.0d-10)
1182       include 'COMMON.GEO'
1183       include 'COMMON.VAR'
1184       include 'COMMON.LOCAL'
1185       include 'COMMON.CHAIN'
1186       include 'COMMON.DERIV'
1187       include 'COMMON.INTERACT'
1188       include 'COMMON.TORSION'
1189       include 'COMMON.SBRIDGE'
1190       include 'COMMON.NAMES'
1191       include 'COMMON.IOUNITS'
1192       include 'COMMON.CONTACTS'
1193       dimension gg(3)
1194 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1195       evdw=0.0D0
1196       do i=iatsc_s,iatsc_e
1197         itypi=iabs(itype(i))
1198         if (itypi.eq.ntyp1) cycle
1199         itypi1=iabs(itype(i+1))
1200         xi=c(1,nres+i)
1201         yi=c(2,nres+i)
1202         zi=c(3,nres+i)
1203 C Change 12/1/95
1204         num_conti=0
1205 C
1206 C Calculate SC interaction energy.
1207 C
1208         do iint=1,nint_gr(i)
1209 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1210 cd   &                  'iend=',iend(i,iint)
1211           do j=istart(i,iint),iend(i,iint)
1212             itypj=iabs(itype(j))
1213             if (itypj.eq.ntyp1) cycle
1214             xj=c(1,nres+j)-xi
1215             yj=c(2,nres+j)-yi
1216             zj=c(3,nres+j)-zi
1217 C Change 12/1/95 to calculate four-body interactions
1218             rij=xj*xj+yj*yj+zj*zj
1219             rrij=1.0D0/rij
1220 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1221             eps0ij=eps(itypi,itypj)
1222             fac=rrij**expon2
1223 C have you changed here?
1224             e1=fac*fac*aa
1225             e2=fac*bb
1226             evdwij=e1+e2
1227 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1228 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1229 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1230 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1231 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1232 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1233             evdw=evdw+evdwij
1234 C
1235 C Calculate the components of the gradient in DC and X
1236 C
1237             fac=-rrij*(e1+evdwij)
1238             gg(1)=xj*fac
1239             gg(2)=yj*fac
1240             gg(3)=zj*fac
1241             do k=1,3
1242               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1243               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1244               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1245               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1246             enddo
1247 cgrad            do k=i,j-1
1248 cgrad              do l=1,3
1249 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1250 cgrad              enddo
1251 cgrad            enddo
1252 C
1253 C 12/1/95, revised on 5/20/97
1254 C
1255 C Calculate the contact function. The ith column of the array JCONT will
1256 C contain the numbers of atoms that make contacts with the atom I (of numbers
1257 C greater than I). The arrays FACONT and GACONT will contain the values of
1258 C the contact function and its derivative.
1259 C
1260 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1261 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1262 C Uncomment next line, if the correlation interactions are contact function only
1263             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1264               rij=dsqrt(rij)
1265               sigij=sigma(itypi,itypj)
1266               r0ij=rs0(itypi,itypj)
1267 C
1268 C Check whether the SC's are not too far to make a contact.
1269 C
1270               rcut=1.5d0*r0ij
1271               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1272 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1273 C
1274               if (fcont.gt.0.0D0) then
1275 C If the SC-SC distance if close to sigma, apply spline.
1276 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1277 cAdam &             fcont1,fprimcont1)
1278 cAdam           fcont1=1.0d0-fcont1
1279 cAdam           if (fcont1.gt.0.0d0) then
1280 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1281 cAdam             fcont=fcont*fcont1
1282 cAdam           endif
1283 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1284 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1285 cga             do k=1,3
1286 cga               gg(k)=gg(k)*eps0ij
1287 cga             enddo
1288 cga             eps0ij=-evdwij*eps0ij
1289 C Uncomment for AL's type of SC correlation interactions.
1290 cadam           eps0ij=-evdwij
1291                 num_conti=num_conti+1
1292                 jcont(num_conti,i)=j
1293                 facont(num_conti,i)=fcont*eps0ij
1294                 fprimcont=eps0ij*fprimcont/rij
1295                 fcont=expon*fcont
1296 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1297 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1298 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1299 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1300                 gacont(1,num_conti,i)=-fprimcont*xj
1301                 gacont(2,num_conti,i)=-fprimcont*yj
1302                 gacont(3,num_conti,i)=-fprimcont*zj
1303 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1304 cd              write (iout,'(2i3,3f10.5)')
1305 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1306               endif
1307             endif
1308           enddo      ! j
1309         enddo        ! iint
1310 C Change 12/1/95
1311         num_cont(i)=num_conti
1312       enddo          ! i
1313       do i=1,nct
1314         do j=1,3
1315           gvdwc(j,i)=expon*gvdwc(j,i)
1316           gvdwx(j,i)=expon*gvdwx(j,i)
1317         enddo
1318       enddo
1319 C******************************************************************************
1320 C
1321 C                              N O T E !!!
1322 C
1323 C To save time, the factor of EXPON has been extracted from ALL components
1324 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1325 C use!
1326 C
1327 C******************************************************************************
1328       return
1329       end
1330 C-----------------------------------------------------------------------------
1331       subroutine eljk(evdw)
1332 C
1333 C This subroutine calculates the interaction energy of nonbonded side chains
1334 C assuming the LJK potential of interaction.
1335 C
1336       implicit real*8 (a-h,o-z)
1337       include 'DIMENSIONS'
1338       include 'COMMON.GEO'
1339       include 'COMMON.VAR'
1340       include 'COMMON.LOCAL'
1341       include 'COMMON.CHAIN'
1342       include 'COMMON.DERIV'
1343       include 'COMMON.INTERACT'
1344       include 'COMMON.IOUNITS'
1345       include 'COMMON.NAMES'
1346       dimension gg(3)
1347       logical scheck
1348 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1349       evdw=0.0D0
1350       do i=iatsc_s,iatsc_e
1351         itypi=iabs(itype(i))
1352         if (itypi.eq.ntyp1) cycle
1353         itypi1=iabs(itype(i+1))
1354         xi=c(1,nres+i)
1355         yi=c(2,nres+i)
1356         zi=c(3,nres+i)
1357 C
1358 C Calculate SC interaction energy.
1359 C
1360         do iint=1,nint_gr(i)
1361           do j=istart(i,iint),iend(i,iint)
1362             itypj=iabs(itype(j))
1363             if (itypj.eq.ntyp1) cycle
1364             xj=c(1,nres+j)-xi
1365             yj=c(2,nres+j)-yi
1366             zj=c(3,nres+j)-zi
1367             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368             fac_augm=rrij**expon
1369             e_augm=augm(itypi,itypj)*fac_augm
1370             r_inv_ij=dsqrt(rrij)
1371             rij=1.0D0/r_inv_ij
1372             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1373             fac=r_shift_inv**expon
1374 C have you changed here?
1375             e1=fac*fac*aa
1376             e2=fac*bb
1377             evdwij=e_augm+e1+e2
1378 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1379 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1380 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1381 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1382 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1383 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1384 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1385             evdw=evdw+evdwij
1386 C
1387 C Calculate the components of the gradient in DC and X
1388 C
1389             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1390             gg(1)=xj*fac
1391             gg(2)=yj*fac
1392             gg(3)=zj*fac
1393             do k=1,3
1394               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1395               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1396               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1397               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1398             enddo
1399 cgrad            do k=i,j-1
1400 cgrad              do l=1,3
1401 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1402 cgrad              enddo
1403 cgrad            enddo
1404           enddo      ! j
1405         enddo        ! iint
1406       enddo          ! i
1407       do i=1,nct
1408         do j=1,3
1409           gvdwc(j,i)=expon*gvdwc(j,i)
1410           gvdwx(j,i)=expon*gvdwx(j,i)
1411         enddo
1412       enddo
1413       return
1414       end
1415 C-----------------------------------------------------------------------------
1416       subroutine ebp(evdw)
1417 C
1418 C This subroutine calculates the interaction energy of nonbonded side chains
1419 C assuming the Berne-Pechukas potential of interaction.
1420 C
1421       implicit real*8 (a-h,o-z)
1422       include 'DIMENSIONS'
1423       include 'COMMON.GEO'
1424       include 'COMMON.VAR'
1425       include 'COMMON.LOCAL'
1426       include 'COMMON.CHAIN'
1427       include 'COMMON.DERIV'
1428       include 'COMMON.NAMES'
1429       include 'COMMON.INTERACT'
1430       include 'COMMON.IOUNITS'
1431       include 'COMMON.CALC'
1432       common /srutu/ icall
1433 c     double precision rrsave(maxdim)
1434       logical lprn
1435       evdw=0.0D0
1436 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1437       evdw=0.0D0
1438 c     if (icall.eq.0) then
1439 c       lprn=.true.
1440 c     else
1441         lprn=.false.
1442 c     endif
1443       ind=0
1444       do i=iatsc_s,iatsc_e
1445         itypi=iabs(itype(i))
1446         if (itypi.eq.ntyp1) cycle
1447         itypi1=iabs(itype(i+1))
1448         xi=c(1,nres+i)
1449         yi=c(2,nres+i)
1450         zi=c(3,nres+i)
1451         dxi=dc_norm(1,nres+i)
1452         dyi=dc_norm(2,nres+i)
1453         dzi=dc_norm(3,nres+i)
1454 c        dsci_inv=dsc_inv(itypi)
1455         dsci_inv=vbld_inv(i+nres)
1456 C
1457 C Calculate SC interaction energy.
1458 C
1459         do iint=1,nint_gr(i)
1460           do j=istart(i,iint),iend(i,iint)
1461             ind=ind+1
1462             itypj=iabs(itype(j))
1463             if (itypj.eq.ntyp1) cycle
1464 c            dscj_inv=dsc_inv(itypj)
1465             dscj_inv=vbld_inv(j+nres)
1466             chi1=chi(itypi,itypj)
1467             chi2=chi(itypj,itypi)
1468             chi12=chi1*chi2
1469             chip1=chip(itypi)
1470             chip2=chip(itypj)
1471             chip12=chip1*chip2
1472             alf1=alp(itypi)
1473             alf2=alp(itypj)
1474             alf12=0.5D0*(alf1+alf2)
1475 C For diagnostics only!!!
1476 c           chi1=0.0D0
1477 c           chi2=0.0D0
1478 c           chi12=0.0D0
1479 c           chip1=0.0D0
1480 c           chip2=0.0D0
1481 c           chip12=0.0D0
1482 c           alf1=0.0D0
1483 c           alf2=0.0D0
1484 c           alf12=0.0D0
1485             xj=c(1,nres+j)-xi
1486             yj=c(2,nres+j)-yi
1487             zj=c(3,nres+j)-zi
1488             dxj=dc_norm(1,nres+j)
1489             dyj=dc_norm(2,nres+j)
1490             dzj=dc_norm(3,nres+j)
1491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492 cd          if (icall.eq.0) then
1493 cd            rrsave(ind)=rrij
1494 cd          else
1495 cd            rrij=rrsave(ind)
1496 cd          endif
1497             rij=dsqrt(rrij)
1498 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1499             call sc_angular
1500 C Calculate whole angle-dependent part of epsilon and contributions
1501 C to its derivatives
1502 C have you changed here?
1503             fac=(rrij*sigsq)**expon2
1504             e1=fac*fac*aa
1505             e2=fac*bb
1506             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1507             eps2der=evdwij*eps3rt
1508             eps3der=evdwij*eps2rt
1509             evdwij=evdwij*eps2rt*eps3rt
1510             evdw=evdw+evdwij
1511             if (lprn) then
1512             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1513             epsi=bb**2/aa
1514 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1515 cd     &        restyp(itypi),i,restyp(itypj),j,
1516 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1517 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1518 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1519 cd     &        evdwij
1520             endif
1521 C Calculate gradient components.
1522             e1=e1*eps1*eps2rt**2*eps3rt**2
1523             fac=-expon*(e1+evdwij)
1524             sigder=fac/sigsq
1525             fac=rrij*fac
1526 C Calculate radial part of the gradient
1527             gg(1)=xj*fac
1528             gg(2)=yj*fac
1529             gg(3)=zj*fac
1530 C Calculate the angular part of the gradient and sum add the contributions
1531 C to the appropriate components of the Cartesian gradient.
1532             call sc_grad
1533           enddo      ! j
1534         enddo        ! iint
1535       enddo          ! i
1536 c     stop
1537       return
1538       end
1539 C-----------------------------------------------------------------------------
1540       subroutine egb(evdw)
1541 C
1542 C This subroutine calculates the interaction energy of nonbonded side chains
1543 C assuming the Gay-Berne potential of interaction.
1544 C
1545       implicit real*8 (a-h,o-z)
1546       include 'DIMENSIONS'
1547       include 'COMMON.GEO'
1548       include 'COMMON.VAR'
1549       include 'COMMON.LOCAL'
1550       include 'COMMON.CHAIN'
1551       include 'COMMON.DERIV'
1552       include 'COMMON.NAMES'
1553       include 'COMMON.INTERACT'
1554       include 'COMMON.IOUNITS'
1555       include 'COMMON.CALC'
1556       include 'COMMON.CONTROL'
1557       include 'COMMON.SPLITELE'
1558       include 'COMMON.SBRIDGE'
1559       logical lprn
1560       integer xshift,yshift,zshift
1561
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1570 C we have the original box)
1571 C      do xshift=-1,1
1572 C      do yshift=-1,1
1573 C      do zshift=-1,1
1574       do i=iatsc_s,iatsc_e
1575         itypi=iabs(itype(i))
1576         if (itypi.eq.ntyp1) cycle
1577         itypi1=iabs(itype(i+1))
1578         xi=c(1,nres+i)
1579         yi=c(2,nres+i)
1580         zi=c(3,nres+i)
1581 C Return atom into box, boxxsize is size of box in x dimension
1582 c  134   continue
1583 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1584 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1585 C Condition for being inside the proper box
1586 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1587 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1588 c        go to 134
1589 c        endif
1590 c  135   continue
1591 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1592 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1593 C Condition for being inside the proper box
1594 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1595 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1596 c        go to 135
1597 c        endif
1598 c  136   continue
1599 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1600 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1601 C Condition for being inside the proper box
1602 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1603 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1604 c        go to 136
1605 c        endif
1606           xi=mod(xi,boxxsize)
1607           if (xi.lt.0) xi=xi+boxxsize
1608           yi=mod(yi,boxysize)
1609           if (yi.lt.0) yi=yi+boxysize
1610           zi=mod(zi,boxzsize)
1611           if (zi.lt.0) zi=zi+boxzsize
1612 C define scaling factor for lipids
1613
1614 C        if (positi.le.0) positi=positi+boxzsize
1615 C        print *,i
1616 C first for peptide groups
1617 c for each residue check if it is in lipid or lipid water border area
1618        if ((zi.gt.bordlipbot)
1619      &.and.(zi.lt.bordliptop)) then
1620 C the energy transfer exist
1621         if (zi.lt.buflipbot) then
1622 C what fraction I am in
1623          fracinbuf=1.0d0-
1624      &        ((zi-bordlipbot)/lipbufthick)
1625 C lipbufthick is thickenes of lipid buffore
1626          sslipi=sscalelip(fracinbuf)
1627          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1628         elseif (zi.gt.bufliptop) then
1629          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1630          sslipi=sscalelip(fracinbuf)
1631          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1632         else
1633          sslipi=1.0d0
1634          ssgradlipi=0.0
1635         endif
1636        else
1637          sslipi=0.0d0
1638          ssgradlipi=0.0
1639        endif
1640
1641 C          xi=xi+xshift*boxxsize
1642 C          yi=yi+yshift*boxysize
1643 C          zi=zi+zshift*boxzsize
1644
1645         dxi=dc_norm(1,nres+i)
1646         dyi=dc_norm(2,nres+i)
1647         dzi=dc_norm(3,nres+i)
1648 c        dsci_inv=dsc_inv(itypi)
1649         dsci_inv=vbld_inv(i+nres)
1650 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1651 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1652 C
1653 C Calculate SC interaction energy.
1654 C
1655         do iint=1,nint_gr(i)
1656           do j=istart(i,iint),iend(i,iint)
1657             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1658
1659 c              write(iout,*) "PRZED ZWYKLE", evdwij
1660               call dyn_ssbond_ene(i,j,evdwij)
1661 c              write(iout,*) "PO ZWYKLE", evdwij
1662
1663               evdw=evdw+evdwij
1664               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1665      &                        'evdw',i,j,evdwij,' ss'
1666 C triple bond artifac removal
1667              do k=j+1,iend(i,iint)
1668 C search over all next residues
1669               if (dyn_ss_mask(k)) then
1670 C check if they are cysteins
1671 C              write(iout,*) 'k=',k
1672
1673 c              write(iout,*) "PRZED TRI", evdwij
1674                evdwij_przed_tri=evdwij
1675               call triple_ssbond_ene(i,j,k,evdwij)
1676 c               if(evdwij_przed_tri.ne.evdwij) then
1677 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1678 c               endif
1679
1680 c              write(iout,*) "PO TRI", evdwij
1681 C call the energy function that removes the artifical triple disulfide
1682 C bond the soubroutine is located in ssMD.F
1683               evdw=evdw+evdwij
1684               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1685      &                        'evdw',i,j,evdwij,'tss'
1686               endif!dyn_ss_mask(k)
1687              enddo! k
1688             ELSE
1689             ind=ind+1
1690             itypj=iabs(itype(j))
1691             if (itypj.eq.ntyp1) cycle
1692 c            dscj_inv=dsc_inv(itypj)
1693             dscj_inv=vbld_inv(j+nres)
1694 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1695 c     &       1.0d0/vbld(j+nres)
1696 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1697             sig0ij=sigma(itypi,itypj)
1698             chi1=chi(itypi,itypj)
1699             chi2=chi(itypj,itypi)
1700             chi12=chi1*chi2
1701             chip1=chip(itypi)
1702             chip2=chip(itypj)
1703             chip12=chip1*chip2
1704             alf1=alp(itypi)
1705             alf2=alp(itypj)
1706             alf12=0.5D0*(alf1+alf2)
1707 C For diagnostics only!!!
1708 c           chi1=0.0D0
1709 c           chi2=0.0D0
1710 c           chi12=0.0D0
1711 c           chip1=0.0D0
1712 c           chip2=0.0D0
1713 c           chip12=0.0D0
1714 c           alf1=0.0D0
1715 c           alf2=0.0D0
1716 c           alf12=0.0D0
1717             xj=c(1,nres+j)
1718             yj=c(2,nres+j)
1719             zj=c(3,nres+j)
1720 C Return atom J into box the original box
1721 c  137   continue
1722 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1723 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1724 C Condition for being inside the proper box
1725 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1726 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1727 c        go to 137
1728 c        endif
1729 c  138   continue
1730 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1731 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1732 C Condition for being inside the proper box
1733 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1734 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1735 c        go to 138
1736 c        endif
1737 c  139   continue
1738 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1739 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1740 C Condition for being inside the proper box
1741 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1742 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1743 c        go to 139
1744 c        endif
1745           xj=mod(xj,boxxsize)
1746           if (xj.lt.0) xj=xj+boxxsize
1747           yj=mod(yj,boxysize)
1748           if (yj.lt.0) yj=yj+boxysize
1749           zj=mod(zj,boxzsize)
1750           if (zj.lt.0) zj=zj+boxzsize
1751        if ((zj.gt.bordlipbot)
1752      &.and.(zj.lt.bordliptop)) then
1753 C the energy transfer exist
1754         if (zj.lt.buflipbot) then
1755 C what fraction I am in
1756          fracinbuf=1.0d0-
1757      &        ((zj-bordlipbot)/lipbufthick)
1758 C lipbufthick is thickenes of lipid buffore
1759          sslipj=sscalelip(fracinbuf)
1760          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1761         elseif (zj.gt.bufliptop) then
1762          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1763          sslipj=sscalelip(fracinbuf)
1764          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1765         else
1766          sslipj=1.0d0
1767          ssgradlipj=0.0
1768         endif
1769        else
1770          sslipj=0.0d0
1771          ssgradlipj=0.0
1772        endif
1773       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1774      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1775       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1776      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1777 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1778 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1779 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1780 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1781       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1782       xj_safe=xj
1783       yj_safe=yj
1784       zj_safe=zj
1785       subchap=0
1786       do xshift=-1,1
1787       do yshift=-1,1
1788       do zshift=-1,1
1789           xj=xj_safe+xshift*boxxsize
1790           yj=yj_safe+yshift*boxysize
1791           zj=zj_safe+zshift*boxzsize
1792           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1793           if(dist_temp.lt.dist_init) then
1794             dist_init=dist_temp
1795             xj_temp=xj
1796             yj_temp=yj
1797             zj_temp=zj
1798             subchap=1
1799           endif
1800        enddo
1801        enddo
1802        enddo
1803        if (subchap.eq.1) then
1804           xj=xj_temp-xi
1805           yj=yj_temp-yi
1806           zj=zj_temp-zi
1807        else
1808           xj=xj_safe-xi
1809           yj=yj_safe-yi
1810           zj=zj_safe-zi
1811        endif
1812             dxj=dc_norm(1,nres+j)
1813             dyj=dc_norm(2,nres+j)
1814             dzj=dc_norm(3,nres+j)
1815 C            xj=xj-xi
1816 C            yj=yj-yi
1817 C            zj=zj-zi
1818 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1819 c            write (iout,*) "j",j," dc_norm",
1820 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1821             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1822             rij=dsqrt(rrij)
1823             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1824             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1825
1826 c            write (iout,'(a7,4f8.3)')
1827 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1828             if (sss.gt.0.0d0) then
1829 C Calculate angle-dependent terms of energy and contributions to their
1830 C derivatives.
1831             call sc_angular
1832             sigsq=1.0D0/sigsq
1833             sig=sig0ij*dsqrt(sigsq)
1834             rij_shift=1.0D0/rij-sig+sig0ij
1835 c for diagnostics; uncomment
1836 c            rij_shift=1.2*sig0ij
1837 C I hate to put IF's in the loops, but here don't have another choice!!!!
1838             if (rij_shift.le.0.0D0) then
1839               evdw=1.0D20
1840 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1841 cd     &        restyp(itypi),i,restyp(itypj),j,
1842 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1843               return
1844             endif
1845             sigder=-sig*sigsq
1846 c---------------------------------------------------------------
1847             rij_shift=1.0D0/rij_shift
1848             fac=rij_shift**expon
1849 C here to start with
1850 C            if (c(i,3).gt.
1851             faclip=fac
1852             e1=fac*fac*aa
1853             e2=fac*bb
1854             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1855             eps2der=evdwij*eps3rt
1856             eps3der=evdwij*eps2rt
1857 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1858 C     &((sslipi+sslipj)/2.0d0+
1859 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1860 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1861 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1862             evdwij=evdwij*eps2rt*eps3rt
1863             evdw=evdw+evdwij*sss
1864             if (lprn) then
1865             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1866             epsi=bb**2/aa
1867             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1868      &        restyp(itypi),i,restyp(itypj),j,
1869      &        epsi,sigm,chi1,chi2,chip1,chip2,
1870      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1871      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1872      &        evdwij
1873             endif
1874
1875             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1876      &                        'evdw',i,j,evdwij
1877
1878 C Calculate gradient components.
1879             e1=e1*eps1*eps2rt**2*eps3rt**2
1880             fac=-expon*(e1+evdwij)*rij_shift
1881             sigder=fac*sigder
1882             fac=rij*fac
1883 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1884 c     &      evdwij,fac,sigma(itypi,itypj),expon
1885             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1886 c            fac=0.0d0
1887 C Calculate the radial part of the gradient
1888             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1889      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1890      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1891      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1892             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1893             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1894 C            gg_lipi(3)=0.0d0
1895 C            gg_lipj(3)=0.0d0
1896             gg(1)=xj*fac
1897             gg(2)=yj*fac
1898             gg(3)=zj*fac
1899 C Calculate angular part of the gradient.
1900             call sc_grad
1901             endif
1902             ENDIF    ! dyn_ss
1903           enddo      ! j
1904         enddo        ! iint
1905       enddo          ! i
1906 C      enddo          ! zshift
1907 C      enddo          ! yshift
1908 C      enddo          ! xshift
1909 c      write (iout,*) "Number of loop steps in EGB:",ind
1910 cccc      energy_dec=.false.
1911       return
1912       end
1913 C-----------------------------------------------------------------------------
1914       subroutine egbv(evdw)
1915 C
1916 C This subroutine calculates the interaction energy of nonbonded side chains
1917 C assuming the Gay-Berne-Vorobjev potential of interaction.
1918 C
1919       implicit real*8 (a-h,o-z)
1920       include 'DIMENSIONS'
1921       include 'COMMON.GEO'
1922       include 'COMMON.VAR'
1923       include 'COMMON.LOCAL'
1924       include 'COMMON.CHAIN'
1925       include 'COMMON.DERIV'
1926       include 'COMMON.NAMES'
1927       include 'COMMON.INTERACT'
1928       include 'COMMON.IOUNITS'
1929       include 'COMMON.CALC'
1930       common /srutu/ icall
1931       logical lprn
1932       evdw=0.0D0
1933 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1934       evdw=0.0D0
1935       lprn=.false.
1936 c     if (icall.eq.0) lprn=.true.
1937       ind=0
1938       do i=iatsc_s,iatsc_e
1939         itypi=iabs(itype(i))
1940         if (itypi.eq.ntyp1) cycle
1941         itypi1=iabs(itype(i+1))
1942         xi=c(1,nres+i)
1943         yi=c(2,nres+i)
1944         zi=c(3,nres+i)
1945           xi=mod(xi,boxxsize)
1946           if (xi.lt.0) xi=xi+boxxsize
1947           yi=mod(yi,boxysize)
1948           if (yi.lt.0) yi=yi+boxysize
1949           zi=mod(zi,boxzsize)
1950           if (zi.lt.0) zi=zi+boxzsize
1951 C define scaling factor for lipids
1952
1953 C        if (positi.le.0) positi=positi+boxzsize
1954 C        print *,i
1955 C first for peptide groups
1956 c for each residue check if it is in lipid or lipid water border area
1957        if ((zi.gt.bordlipbot)
1958      &.and.(zi.lt.bordliptop)) then
1959 C the energy transfer exist
1960         if (zi.lt.buflipbot) then
1961 C what fraction I am in
1962          fracinbuf=1.0d0-
1963      &        ((zi-bordlipbot)/lipbufthick)
1964 C lipbufthick is thickenes of lipid buffore
1965          sslipi=sscalelip(fracinbuf)
1966          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1967         elseif (zi.gt.bufliptop) then
1968          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1969          sslipi=sscalelip(fracinbuf)
1970          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1971         else
1972          sslipi=1.0d0
1973          ssgradlipi=0.0
1974         endif
1975        else
1976          sslipi=0.0d0
1977          ssgradlipi=0.0
1978        endif
1979
1980         dxi=dc_norm(1,nres+i)
1981         dyi=dc_norm(2,nres+i)
1982         dzi=dc_norm(3,nres+i)
1983 c        dsci_inv=dsc_inv(itypi)
1984         dsci_inv=vbld_inv(i+nres)
1985 C
1986 C Calculate SC interaction energy.
1987 C
1988         do iint=1,nint_gr(i)
1989           do j=istart(i,iint),iend(i,iint)
1990             ind=ind+1
1991             itypj=iabs(itype(j))
1992             if (itypj.eq.ntyp1) cycle
1993 c            dscj_inv=dsc_inv(itypj)
1994             dscj_inv=vbld_inv(j+nres)
1995             sig0ij=sigma(itypi,itypj)
1996             r0ij=r0(itypi,itypj)
1997             chi1=chi(itypi,itypj)
1998             chi2=chi(itypj,itypi)
1999             chi12=chi1*chi2
2000             chip1=chip(itypi)
2001             chip2=chip(itypj)
2002             chip12=chip1*chip2
2003             alf1=alp(itypi)
2004             alf2=alp(itypj)
2005             alf12=0.5D0*(alf1+alf2)
2006 C For diagnostics only!!!
2007 c           chi1=0.0D0
2008 c           chi2=0.0D0
2009 c           chi12=0.0D0
2010 c           chip1=0.0D0
2011 c           chip2=0.0D0
2012 c           chip12=0.0D0
2013 c           alf1=0.0D0
2014 c           alf2=0.0D0
2015 c           alf12=0.0D0
2016 C            xj=c(1,nres+j)-xi
2017 C            yj=c(2,nres+j)-yi
2018 C            zj=c(3,nres+j)-zi
2019           xj=mod(xj,boxxsize)
2020           if (xj.lt.0) xj=xj+boxxsize
2021           yj=mod(yj,boxysize)
2022           if (yj.lt.0) yj=yj+boxysize
2023           zj=mod(zj,boxzsize)
2024           if (zj.lt.0) zj=zj+boxzsize
2025        if ((zj.gt.bordlipbot)
2026      &.and.(zj.lt.bordliptop)) then
2027 C the energy transfer exist
2028         if (zj.lt.buflipbot) then
2029 C what fraction I am in
2030          fracinbuf=1.0d0-
2031      &        ((zj-bordlipbot)/lipbufthick)
2032 C lipbufthick is thickenes of lipid buffore
2033          sslipj=sscalelip(fracinbuf)
2034          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2035         elseif (zj.gt.bufliptop) then
2036          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2037          sslipj=sscalelip(fracinbuf)
2038          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2039         else
2040          sslipj=1.0d0
2041          ssgradlipj=0.0
2042         endif
2043        else
2044          sslipj=0.0d0
2045          ssgradlipj=0.0
2046        endif
2047       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2048      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2049       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2050      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2051 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2052 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2053       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2054       xj_safe=xj
2055       yj_safe=yj
2056       zj_safe=zj
2057       subchap=0
2058       do xshift=-1,1
2059       do yshift=-1,1
2060       do zshift=-1,1
2061           xj=xj_safe+xshift*boxxsize
2062           yj=yj_safe+yshift*boxysize
2063           zj=zj_safe+zshift*boxzsize
2064           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2065           if(dist_temp.lt.dist_init) then
2066             dist_init=dist_temp
2067             xj_temp=xj
2068             yj_temp=yj
2069             zj_temp=zj
2070             subchap=1
2071           endif
2072        enddo
2073        enddo
2074        enddo
2075        if (subchap.eq.1) then
2076           xj=xj_temp-xi
2077           yj=yj_temp-yi
2078           zj=zj_temp-zi
2079        else
2080           xj=xj_safe-xi
2081           yj=yj_safe-yi
2082           zj=zj_safe-zi
2083        endif
2084             dxj=dc_norm(1,nres+j)
2085             dyj=dc_norm(2,nres+j)
2086             dzj=dc_norm(3,nres+j)
2087             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2088             rij=dsqrt(rrij)
2089 C Calculate angle-dependent terms of energy and contributions to their
2090 C derivatives.
2091             call sc_angular
2092             sigsq=1.0D0/sigsq
2093             sig=sig0ij*dsqrt(sigsq)
2094             rij_shift=1.0D0/rij-sig+r0ij
2095 C I hate to put IF's in the loops, but here don't have another choice!!!!
2096             if (rij_shift.le.0.0D0) then
2097               evdw=1.0D20
2098               return
2099             endif
2100             sigder=-sig*sigsq
2101 c---------------------------------------------------------------
2102             rij_shift=1.0D0/rij_shift
2103             fac=rij_shift**expon
2104             e1=fac*fac*aa
2105             e2=fac*bb
2106             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2107             eps2der=evdwij*eps3rt
2108             eps3der=evdwij*eps2rt
2109             fac_augm=rrij**expon
2110             e_augm=augm(itypi,itypj)*fac_augm
2111             evdwij=evdwij*eps2rt*eps3rt
2112             evdw=evdw+evdwij+e_augm
2113             if (lprn) then
2114             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2115             epsi=bb**2/aa
2116             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2117      &        restyp(itypi),i,restyp(itypj),j,
2118      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2119      &        chi1,chi2,chip1,chip2,
2120      &        eps1,eps2rt**2,eps3rt**2,
2121      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2122      &        evdwij+e_augm
2123             endif
2124 C Calculate gradient components.
2125             e1=e1*eps1*eps2rt**2*eps3rt**2
2126             fac=-expon*(e1+evdwij)*rij_shift
2127             sigder=fac*sigder
2128             fac=rij*fac-2*expon*rrij*e_augm
2129             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2130 C Calculate the radial part of the gradient
2131             gg(1)=xj*fac
2132             gg(2)=yj*fac
2133             gg(3)=zj*fac
2134 C Calculate angular part of the gradient.
2135             call sc_grad
2136           enddo      ! j
2137         enddo        ! iint
2138       enddo          ! i
2139       end
2140 C-----------------------------------------------------------------------------
2141       subroutine sc_angular
2142 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2143 C om12. Called by ebp, egb, and egbv.
2144       implicit none
2145       include 'COMMON.CALC'
2146       include 'COMMON.IOUNITS'
2147       erij(1)=xj*rij
2148       erij(2)=yj*rij
2149       erij(3)=zj*rij
2150       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2151       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2152       om12=dxi*dxj+dyi*dyj+dzi*dzj
2153       chiom12=chi12*om12
2154 C Calculate eps1(om12) and its derivative in om12
2155       faceps1=1.0D0-om12*chiom12
2156       faceps1_inv=1.0D0/faceps1
2157       eps1=dsqrt(faceps1_inv)
2158 C Following variable is eps1*deps1/dom12
2159       eps1_om12=faceps1_inv*chiom12
2160 c diagnostics only
2161 c      faceps1_inv=om12
2162 c      eps1=om12
2163 c      eps1_om12=1.0d0
2164 c      write (iout,*) "om12",om12," eps1",eps1
2165 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2166 C and om12.
2167       om1om2=om1*om2
2168       chiom1=chi1*om1
2169       chiom2=chi2*om2
2170       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2171       sigsq=1.0D0-facsig*faceps1_inv
2172       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2173       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2174       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2175 c diagnostics only
2176 c      sigsq=1.0d0
2177 c      sigsq_om1=0.0d0
2178 c      sigsq_om2=0.0d0
2179 c      sigsq_om12=0.0d0
2180 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2181 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2182 c     &    " eps1",eps1
2183 C Calculate eps2 and its derivatives in om1, om2, and om12.
2184       chipom1=chip1*om1
2185       chipom2=chip2*om2
2186       chipom12=chip12*om12
2187       facp=1.0D0-om12*chipom12
2188       facp_inv=1.0D0/facp
2189       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2190 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2191 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2192 C Following variable is the square root of eps2
2193       eps2rt=1.0D0-facp1*facp_inv
2194 C Following three variables are the derivatives of the square root of eps
2195 C in om1, om2, and om12.
2196       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2197       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2198       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2199 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2200       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2201 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2202 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2203 c     &  " eps2rt_om12",eps2rt_om12
2204 C Calculate whole angle-dependent part of epsilon and contributions
2205 C to its derivatives
2206       return
2207       end
2208 C----------------------------------------------------------------------------
2209       subroutine sc_grad
2210       implicit real*8 (a-h,o-z)
2211       include 'DIMENSIONS'
2212       include 'COMMON.CHAIN'
2213       include 'COMMON.DERIV'
2214       include 'COMMON.CALC'
2215       include 'COMMON.IOUNITS'
2216       double precision dcosom1(3),dcosom2(3)
2217 cc      print *,'sss=',sss
2218       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2219       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2220       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2221      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2222 c diagnostics only
2223 c      eom1=0.0d0
2224 c      eom2=0.0d0
2225 c      eom12=evdwij*eps1_om12
2226 c end diagnostics
2227 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2228 c     &  " sigder",sigder
2229 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2230 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2231       do k=1,3
2232         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2233         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2234       enddo
2235       do k=1,3
2236         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2237       enddo
2238 c      write (iout,*) "gg",(gg(k),k=1,3)
2239       do k=1,3
2240         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2241      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2242      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2243         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2244      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2245      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2246 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2247 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2248 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2249 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2250       enddo
2251 C
2252 C Calculate the components of the gradient in DC and X
2253 C
2254 cgrad      do k=i,j-1
2255 cgrad        do l=1,3
2256 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2257 cgrad        enddo
2258 cgrad      enddo
2259       do l=1,3
2260         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2261         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2262       enddo
2263       return
2264       end
2265 C-----------------------------------------------------------------------
2266       subroutine e_softsphere(evdw)
2267 C
2268 C This subroutine calculates the interaction energy of nonbonded side chains
2269 C assuming the LJ potential of interaction.
2270 C
2271       implicit real*8 (a-h,o-z)
2272       include 'DIMENSIONS'
2273       parameter (accur=1.0d-10)
2274       include 'COMMON.GEO'
2275       include 'COMMON.VAR'
2276       include 'COMMON.LOCAL'
2277       include 'COMMON.CHAIN'
2278       include 'COMMON.DERIV'
2279       include 'COMMON.INTERACT'
2280       include 'COMMON.TORSION'
2281       include 'COMMON.SBRIDGE'
2282       include 'COMMON.NAMES'
2283       include 'COMMON.IOUNITS'
2284       include 'COMMON.CONTACTS'
2285       dimension gg(3)
2286 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2287       evdw=0.0D0
2288       do i=iatsc_s,iatsc_e
2289         itypi=iabs(itype(i))
2290         if (itypi.eq.ntyp1) cycle
2291         itypi1=iabs(itype(i+1))
2292         xi=c(1,nres+i)
2293         yi=c(2,nres+i)
2294         zi=c(3,nres+i)
2295 C
2296 C Calculate SC interaction energy.
2297 C
2298         do iint=1,nint_gr(i)
2299 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2300 cd   &                  'iend=',iend(i,iint)
2301           do j=istart(i,iint),iend(i,iint)
2302             itypj=iabs(itype(j))
2303             if (itypj.eq.ntyp1) cycle
2304             xj=c(1,nres+j)-xi
2305             yj=c(2,nres+j)-yi
2306             zj=c(3,nres+j)-zi
2307             rij=xj*xj+yj*yj+zj*zj
2308 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2309             r0ij=r0(itypi,itypj)
2310             r0ijsq=r0ij*r0ij
2311 c            print *,i,j,r0ij,dsqrt(rij)
2312             if (rij.lt.r0ijsq) then
2313               evdwij=0.25d0*(rij-r0ijsq)**2
2314               fac=rij-r0ijsq
2315             else
2316               evdwij=0.0d0
2317               fac=0.0d0
2318             endif
2319             evdw=evdw+evdwij
2320 C
2321 C Calculate the components of the gradient in DC and X
2322 C
2323             gg(1)=xj*fac
2324             gg(2)=yj*fac
2325             gg(3)=zj*fac
2326             do k=1,3
2327               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2328               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2329               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2330               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2331             enddo
2332 cgrad            do k=i,j-1
2333 cgrad              do l=1,3
2334 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2335 cgrad              enddo
2336 cgrad            enddo
2337           enddo ! j
2338         enddo ! iint
2339       enddo ! i
2340       return
2341       end
2342 C--------------------------------------------------------------------------
2343       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2344      &              eello_turn4)
2345 C
2346 C Soft-sphere potential of p-p interaction
2347 C
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350       include 'COMMON.CONTROL'
2351       include 'COMMON.IOUNITS'
2352       include 'COMMON.GEO'
2353       include 'COMMON.VAR'
2354       include 'COMMON.LOCAL'
2355       include 'COMMON.CHAIN'
2356       include 'COMMON.DERIV'
2357       include 'COMMON.INTERACT'
2358       include 'COMMON.CONTACTS'
2359       include 'COMMON.TORSION'
2360       include 'COMMON.VECTORS'
2361       include 'COMMON.FFIELD'
2362       dimension ggg(3)
2363 C      write(iout,*) 'In EELEC_soft_sphere'
2364       ees=0.0D0
2365       evdw1=0.0D0
2366       eel_loc=0.0d0
2367       eello_turn3=0.0d0
2368       eello_turn4=0.0d0
2369       ind=0
2370       do i=iatel_s,iatel_e
2371         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2372         dxi=dc(1,i)
2373         dyi=dc(2,i)
2374         dzi=dc(3,i)
2375         xmedi=c(1,i)+0.5d0*dxi
2376         ymedi=c(2,i)+0.5d0*dyi
2377         zmedi=c(3,i)+0.5d0*dzi
2378           xmedi=mod(xmedi,boxxsize)
2379           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2380           ymedi=mod(ymedi,boxysize)
2381           if (ymedi.lt.0) ymedi=ymedi+boxysize
2382           zmedi=mod(zmedi,boxzsize)
2383           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2384         num_conti=0
2385 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2386         do j=ielstart(i),ielend(i)
2387           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2388           ind=ind+1
2389           iteli=itel(i)
2390           itelj=itel(j)
2391           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2392           r0ij=rpp(iteli,itelj)
2393           r0ijsq=r0ij*r0ij
2394           dxj=dc(1,j)
2395           dyj=dc(2,j)
2396           dzj=dc(3,j)
2397           xj=c(1,j)+0.5D0*dxj
2398           yj=c(2,j)+0.5D0*dyj
2399           zj=c(3,j)+0.5D0*dzj
2400           xj=mod(xj,boxxsize)
2401           if (xj.lt.0) xj=xj+boxxsize
2402           yj=mod(yj,boxysize)
2403           if (yj.lt.0) yj=yj+boxysize
2404           zj=mod(zj,boxzsize)
2405           if (zj.lt.0) zj=zj+boxzsize
2406       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2407       xj_safe=xj
2408       yj_safe=yj
2409       zj_safe=zj
2410       isubchap=0
2411       do xshift=-1,1
2412       do yshift=-1,1
2413       do zshift=-1,1
2414           xj=xj_safe+xshift*boxxsize
2415           yj=yj_safe+yshift*boxysize
2416           zj=zj_safe+zshift*boxzsize
2417           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2418           if(dist_temp.lt.dist_init) then
2419             dist_init=dist_temp
2420             xj_temp=xj
2421             yj_temp=yj
2422             zj_temp=zj
2423             isubchap=1
2424           endif
2425        enddo
2426        enddo
2427        enddo
2428        if (isubchap.eq.1) then
2429           xj=xj_temp-xmedi
2430           yj=yj_temp-ymedi
2431           zj=zj_temp-zmedi
2432        else
2433           xj=xj_safe-xmedi
2434           yj=yj_safe-ymedi
2435           zj=zj_safe-zmedi
2436        endif
2437           rij=xj*xj+yj*yj+zj*zj
2438             sss=sscale(sqrt(rij))
2439             sssgrad=sscagrad(sqrt(rij))
2440           if (rij.lt.r0ijsq) then
2441             evdw1ij=0.25d0*(rij-r0ijsq)**2
2442             fac=rij-r0ijsq
2443           else
2444             evdw1ij=0.0d0
2445             fac=0.0d0
2446           endif
2447           evdw1=evdw1+evdw1ij*sss
2448 C
2449 C Calculate contributions to the Cartesian gradient.
2450 C
2451           ggg(1)=fac*xj*sssgrad
2452           ggg(2)=fac*yj*sssgrad
2453           ggg(3)=fac*zj*sssgrad
2454           do k=1,3
2455             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2456             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2457           enddo
2458 *
2459 * Loop over residues i+1 thru j-1.
2460 *
2461 cgrad          do k=i+1,j-1
2462 cgrad            do l=1,3
2463 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2464 cgrad            enddo
2465 cgrad          enddo
2466         enddo ! j
2467       enddo   ! i
2468 cgrad      do i=nnt,nct-1
2469 cgrad        do k=1,3
2470 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2471 cgrad        enddo
2472 cgrad        do j=i+1,nct-1
2473 cgrad          do k=1,3
2474 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2475 cgrad          enddo
2476 cgrad        enddo
2477 cgrad      enddo
2478       return
2479       end
2480 c------------------------------------------------------------------------------
2481       subroutine vec_and_deriv
2482       implicit real*8 (a-h,o-z)
2483       include 'DIMENSIONS'
2484 #ifdef MPI
2485       include 'mpif.h'
2486 #endif
2487       include 'COMMON.IOUNITS'
2488       include 'COMMON.GEO'
2489       include 'COMMON.VAR'
2490       include 'COMMON.LOCAL'
2491       include 'COMMON.CHAIN'
2492       include 'COMMON.VECTORS'
2493       include 'COMMON.SETUP'
2494       include 'COMMON.TIME1'
2495       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2496 C Compute the local reference systems. For reference system (i), the
2497 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2498 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2499 #ifdef PARVEC
2500       do i=ivec_start,ivec_end
2501 #else
2502       do i=1,nres-1
2503 #endif
2504           if (i.eq.nres-1) then
2505 C Case of the last full residue
2506 C Compute the Z-axis
2507             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2508             costh=dcos(pi-theta(nres))
2509             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2510             do k=1,3
2511               uz(k,i)=fac*uz(k,i)
2512             enddo
2513 C Compute the derivatives of uz
2514             uzder(1,1,1)= 0.0d0
2515             uzder(2,1,1)=-dc_norm(3,i-1)
2516             uzder(3,1,1)= dc_norm(2,i-1)
2517             uzder(1,2,1)= dc_norm(3,i-1)
2518             uzder(2,2,1)= 0.0d0
2519             uzder(3,2,1)=-dc_norm(1,i-1)
2520             uzder(1,3,1)=-dc_norm(2,i-1)
2521             uzder(2,3,1)= dc_norm(1,i-1)
2522             uzder(3,3,1)= 0.0d0
2523             uzder(1,1,2)= 0.0d0
2524             uzder(2,1,2)= dc_norm(3,i)
2525             uzder(3,1,2)=-dc_norm(2,i)
2526             uzder(1,2,2)=-dc_norm(3,i)
2527             uzder(2,2,2)= 0.0d0
2528             uzder(3,2,2)= dc_norm(1,i)
2529             uzder(1,3,2)= dc_norm(2,i)
2530             uzder(2,3,2)=-dc_norm(1,i)
2531             uzder(3,3,2)= 0.0d0
2532 C Compute the Y-axis
2533             facy=fac
2534             do k=1,3
2535               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2536             enddo
2537 C Compute the derivatives of uy
2538             do j=1,3
2539               do k=1,3
2540                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2541      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2542                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2543               enddo
2544               uyder(j,j,1)=uyder(j,j,1)-costh
2545               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2546             enddo
2547             do j=1,2
2548               do k=1,3
2549                 do l=1,3
2550                   uygrad(l,k,j,i)=uyder(l,k,j)
2551                   uzgrad(l,k,j,i)=uzder(l,k,j)
2552                 enddo
2553               enddo
2554             enddo
2555             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2556             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2557             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2558             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2559           else
2560 C Other residues
2561 C Compute the Z-axis
2562             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2563             costh=dcos(pi-theta(i+2))
2564             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2565             do k=1,3
2566               uz(k,i)=fac*uz(k,i)
2567             enddo
2568 C Compute the derivatives of uz
2569             uzder(1,1,1)= 0.0d0
2570             uzder(2,1,1)=-dc_norm(3,i+1)
2571             uzder(3,1,1)= dc_norm(2,i+1)
2572             uzder(1,2,1)= dc_norm(3,i+1)
2573             uzder(2,2,1)= 0.0d0
2574             uzder(3,2,1)=-dc_norm(1,i+1)
2575             uzder(1,3,1)=-dc_norm(2,i+1)
2576             uzder(2,3,1)= dc_norm(1,i+1)
2577             uzder(3,3,1)= 0.0d0
2578             uzder(1,1,2)= 0.0d0
2579             uzder(2,1,2)= dc_norm(3,i)
2580             uzder(3,1,2)=-dc_norm(2,i)
2581             uzder(1,2,2)=-dc_norm(3,i)
2582             uzder(2,2,2)= 0.0d0
2583             uzder(3,2,2)= dc_norm(1,i)
2584             uzder(1,3,2)= dc_norm(2,i)
2585             uzder(2,3,2)=-dc_norm(1,i)
2586             uzder(3,3,2)= 0.0d0
2587 C Compute the Y-axis
2588             facy=fac
2589             do k=1,3
2590               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2591             enddo
2592 C Compute the derivatives of uy
2593             do j=1,3
2594               do k=1,3
2595                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2596      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2597                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2598               enddo
2599               uyder(j,j,1)=uyder(j,j,1)-costh
2600               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2601             enddo
2602             do j=1,2
2603               do k=1,3
2604                 do l=1,3
2605                   uygrad(l,k,j,i)=uyder(l,k,j)
2606                   uzgrad(l,k,j,i)=uzder(l,k,j)
2607                 enddo
2608               enddo
2609             enddo
2610             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2611             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2612             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2613             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2614           endif
2615       enddo
2616       do i=1,nres-1
2617         vbld_inv_temp(1)=vbld_inv(i+1)
2618         if (i.lt.nres-1) then
2619           vbld_inv_temp(2)=vbld_inv(i+2)
2620           else
2621           vbld_inv_temp(2)=vbld_inv(i)
2622           endif
2623         do j=1,2
2624           do k=1,3
2625             do l=1,3
2626               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2627               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2628             enddo
2629           enddo
2630         enddo
2631       enddo
2632 #if defined(PARVEC) && defined(MPI)
2633       if (nfgtasks1.gt.1) then
2634         time00=MPI_Wtime()
2635 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2636 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2637 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2638         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2639      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2640      &   FG_COMM1,IERR)
2641         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2642      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2645      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2646      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2647         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2648      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2649      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2650         time_gather=time_gather+MPI_Wtime()-time00
2651       endif
2652 c      if (fg_rank.eq.0) then
2653 c        write (iout,*) "Arrays UY and UZ"
2654 c        do i=1,nres-1
2655 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2656 c     &     (uz(k,i),k=1,3)
2657 c        enddo
2658 c      endif
2659 #endif
2660       return
2661       end
2662 C-----------------------------------------------------------------------------
2663       subroutine check_vecgrad
2664       implicit real*8 (a-h,o-z)
2665       include 'DIMENSIONS'
2666       include 'COMMON.IOUNITS'
2667       include 'COMMON.GEO'
2668       include 'COMMON.VAR'
2669       include 'COMMON.LOCAL'
2670       include 'COMMON.CHAIN'
2671       include 'COMMON.VECTORS'
2672       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2673       dimension uyt(3,maxres),uzt(3,maxres)
2674       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2675       double precision delta /1.0d-7/
2676       call vec_and_deriv
2677 cd      do i=1,nres
2678 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2679 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2680 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2681 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2682 cd     &     (dc_norm(if90,i),if90=1,3)
2683 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2684 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2685 cd          write(iout,'(a)')
2686 cd      enddo
2687       do i=1,nres
2688         do j=1,2
2689           do k=1,3
2690             do l=1,3
2691               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2692               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2693             enddo
2694           enddo
2695         enddo
2696       enddo
2697       call vec_and_deriv
2698       do i=1,nres
2699         do j=1,3
2700           uyt(j,i)=uy(j,i)
2701           uzt(j,i)=uz(j,i)
2702         enddo
2703       enddo
2704       do i=1,nres
2705 cd        write (iout,*) 'i=',i
2706         do k=1,3
2707           erij(k)=dc_norm(k,i)
2708         enddo
2709         do j=1,3
2710           do k=1,3
2711             dc_norm(k,i)=erij(k)
2712           enddo
2713           dc_norm(j,i)=dc_norm(j,i)+delta
2714 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2715 c          do k=1,3
2716 c            dc_norm(k,i)=dc_norm(k,i)/fac
2717 c          enddo
2718 c          write (iout,*) (dc_norm(k,i),k=1,3)
2719 c          write (iout,*) (erij(k),k=1,3)
2720           call vec_and_deriv
2721           do k=1,3
2722             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2723             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2724             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2725             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2726           enddo
2727 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2728 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2729 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2730         enddo
2731         do k=1,3
2732           dc_norm(k,i)=erij(k)
2733         enddo
2734 cd        do k=1,3
2735 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2736 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2737 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2738 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2739 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2740 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2741 cd          write (iout,'(a)')
2742 cd        enddo
2743       enddo
2744       return
2745       end
2746 C--------------------------------------------------------------------------
2747       subroutine set_matrices
2748       implicit real*8 (a-h,o-z)
2749       include 'DIMENSIONS'
2750 #ifdef MPI
2751       include "mpif.h"
2752       include "COMMON.SETUP"
2753       integer IERR
2754       integer status(MPI_STATUS_SIZE)
2755 #endif
2756       include 'COMMON.IOUNITS'
2757       include 'COMMON.GEO'
2758       include 'COMMON.VAR'
2759       include 'COMMON.LOCAL'
2760       include 'COMMON.CHAIN'
2761       include 'COMMON.DERIV'
2762       include 'COMMON.INTERACT'
2763       include 'COMMON.CONTACTS'
2764       include 'COMMON.TORSION'
2765       include 'COMMON.VECTORS'
2766       include 'COMMON.FFIELD'
2767       double precision auxvec(2),auxmat(2,2)
2768 C
2769 C Compute the virtual-bond-torsional-angle dependent quantities needed
2770 C to calculate the el-loc multibody terms of various order.
2771 C
2772 c      write(iout,*) 'nphi=',nphi,nres
2773 #ifdef PARMAT
2774       do i=ivec_start+2,ivec_end+2
2775 #else
2776       do i=3,nres+1
2777 #endif
2778 #ifdef NEWCORR
2779         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2780           iti = itortyp(itype(i-2))
2781         else
2782           iti=ntortyp+1
2783         endif
2784 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2785         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2786           iti1 = itortyp(itype(i-1))
2787         else
2788           iti1=ntortyp+1
2789         endif
2790 c        write(iout,*),i
2791         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2792      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2793      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2794         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2795      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2796      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2797 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2798 c     &*(cos(theta(i)/2.0)
2799         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2800      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2801      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2802 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2803 c     &*(cos(theta(i)/2.0)
2804         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2805      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2806      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2807 c        if (ggb1(1,i).eq.0.0d0) then
2808 c        write(iout,*) 'i=',i,ggb1(1,i),
2809 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2810 c     &bnew1(2,1,iti)*cos(theta(i)),
2811 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2812 c        endif
2813         b1(2,i-2)=bnew1(1,2,iti)
2814         gtb1(2,i-2)=0.0
2815         b2(2,i-2)=bnew2(1,2,iti)
2816         gtb2(2,i-2)=0.0
2817         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2818         EE(1,2,i-2)=eeold(1,2,iti)
2819         EE(2,1,i-2)=eeold(2,1,iti)
2820         EE(2,2,i-2)=eeold(2,2,iti)
2821         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2822         gtEE(1,2,i-2)=0.0d0
2823         gtEE(2,2,i-2)=0.0d0
2824         gtEE(2,1,i-2)=0.0d0
2825 c        EE(2,2,iti)=0.0d0
2826 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2827 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2828 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2829 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2830        b1tilde(1,i-2)=b1(1,i-2)
2831        b1tilde(2,i-2)=-b1(2,i-2)
2832        b2tilde(1,i-2)=b2(1,i-2)
2833        b2tilde(2,i-2)=-b2(2,i-2)
2834 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2835 c       write(iout,*)  'b1=',b1(1,i-2)
2836 c       write (iout,*) 'theta=', theta(i-1)
2837        enddo
2838 #else
2839         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2840           iti = itortyp(itype(i-2))
2841         else
2842           iti=ntortyp+1
2843         endif
2844 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2845         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2846           iti1 = itortyp(itype(i-1))
2847         else
2848           iti1=ntortyp+1
2849         endif
2850         b1(1,i-2)=b(3,iti)
2851         b1(2,i-2)=b(5,iti)
2852         b2(1,i-2)=b(2,iti)
2853         b2(2,i-2)=b(4,iti)
2854        b1tilde(1,i-2)=b1(1,i-2)
2855        b1tilde(2,i-2)=-b1(2,i-2)
2856        b2tilde(1,i-2)=b2(1,i-2)
2857        b2tilde(2,i-2)=-b2(2,i-2)
2858         EE(1,2,i-2)=eeold(1,2,iti)
2859         EE(2,1,i-2)=eeold(2,1,iti)
2860         EE(2,2,i-2)=eeold(2,2,iti)
2861         EE(1,1,i-2)=eeold(1,1,iti)
2862       enddo
2863 #endif
2864 #ifdef PARMAT
2865       do i=ivec_start+2,ivec_end+2
2866 #else
2867       do i=3,nres+1
2868 #endif
2869         if (i .lt. nres+1) then
2870           sin1=dsin(phi(i))
2871           cos1=dcos(phi(i))
2872           sintab(i-2)=sin1
2873           costab(i-2)=cos1
2874           obrot(1,i-2)=cos1
2875           obrot(2,i-2)=sin1
2876           sin2=dsin(2*phi(i))
2877           cos2=dcos(2*phi(i))
2878           sintab2(i-2)=sin2
2879           costab2(i-2)=cos2
2880           obrot2(1,i-2)=cos2
2881           obrot2(2,i-2)=sin2
2882           Ug(1,1,i-2)=-cos1
2883           Ug(1,2,i-2)=-sin1
2884           Ug(2,1,i-2)=-sin1
2885           Ug(2,2,i-2)= cos1
2886           Ug2(1,1,i-2)=-cos2
2887           Ug2(1,2,i-2)=-sin2
2888           Ug2(2,1,i-2)=-sin2
2889           Ug2(2,2,i-2)= cos2
2890         else
2891           costab(i-2)=1.0d0
2892           sintab(i-2)=0.0d0
2893           obrot(1,i-2)=1.0d0
2894           obrot(2,i-2)=0.0d0
2895           obrot2(1,i-2)=0.0d0
2896           obrot2(2,i-2)=0.0d0
2897           Ug(1,1,i-2)=1.0d0
2898           Ug(1,2,i-2)=0.0d0
2899           Ug(2,1,i-2)=0.0d0
2900           Ug(2,2,i-2)=1.0d0
2901           Ug2(1,1,i-2)=0.0d0
2902           Ug2(1,2,i-2)=0.0d0
2903           Ug2(2,1,i-2)=0.0d0
2904           Ug2(2,2,i-2)=0.0d0
2905         endif
2906         if (i .gt. 3 .and. i .lt. nres+1) then
2907           obrot_der(1,i-2)=-sin1
2908           obrot_der(2,i-2)= cos1
2909           Ugder(1,1,i-2)= sin1
2910           Ugder(1,2,i-2)=-cos1
2911           Ugder(2,1,i-2)=-cos1
2912           Ugder(2,2,i-2)=-sin1
2913           dwacos2=cos2+cos2
2914           dwasin2=sin2+sin2
2915           obrot2_der(1,i-2)=-dwasin2
2916           obrot2_der(2,i-2)= dwacos2
2917           Ug2der(1,1,i-2)= dwasin2
2918           Ug2der(1,2,i-2)=-dwacos2
2919           Ug2der(2,1,i-2)=-dwacos2
2920           Ug2der(2,2,i-2)=-dwasin2
2921         else
2922           obrot_der(1,i-2)=0.0d0
2923           obrot_der(2,i-2)=0.0d0
2924           Ugder(1,1,i-2)=0.0d0
2925           Ugder(1,2,i-2)=0.0d0
2926           Ugder(2,1,i-2)=0.0d0
2927           Ugder(2,2,i-2)=0.0d0
2928           obrot2_der(1,i-2)=0.0d0
2929           obrot2_der(2,i-2)=0.0d0
2930           Ug2der(1,1,i-2)=0.0d0
2931           Ug2der(1,2,i-2)=0.0d0
2932           Ug2der(2,1,i-2)=0.0d0
2933           Ug2der(2,2,i-2)=0.0d0
2934         endif
2935 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2936         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2937           iti = itortyp(itype(i-2))
2938         else
2939           iti=ntortyp
2940         endif
2941 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2942         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2943           iti1 = itortyp(itype(i-1))
2944         else
2945           iti1=ntortyp
2946         endif
2947 cd        write (iout,*) '*******i',i,' iti1',iti
2948 cd        write (iout,*) 'b1',b1(:,iti)
2949 cd        write (iout,*) 'b2',b2(:,iti)
2950 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2951 c        if (i .gt. iatel_s+2) then
2952         if (i .gt. nnt+2) then
2953           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2954 #ifdef NEWCORR
2955           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2956 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2957 #endif
2958 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2959 c     &    EE(1,2,iti),EE(2,2,iti)
2960           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2961           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2962 c          write(iout,*) "Macierz EUG",
2963 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2964 c     &    eug(2,2,i-2)
2965           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2966      &    then
2967           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2968           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2969           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2970           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2971           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2972           endif
2973         else
2974           do k=1,2
2975             Ub2(k,i-2)=0.0d0
2976             Ctobr(k,i-2)=0.0d0
2977             Dtobr2(k,i-2)=0.0d0
2978             do l=1,2
2979               EUg(l,k,i-2)=0.0d0
2980               CUg(l,k,i-2)=0.0d0
2981               DUg(l,k,i-2)=0.0d0
2982               DtUg2(l,k,i-2)=0.0d0
2983             enddo
2984           enddo
2985         endif
2986         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2987         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2988         do k=1,2
2989           muder(k,i-2)=Ub2der(k,i-2)
2990         enddo
2991 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2992         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2993           if (itype(i-1).le.ntyp) then
2994             iti1 = itortyp(itype(i-1))
2995           else
2996             iti1=ntortyp
2997           endif
2998         else
2999           iti1=ntortyp
3000         endif
3001         do k=1,2
3002           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3003         enddo
3004 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
3005 c        write (iout,*) 'mu ',mu(:,i-2),i-2
3006 cd        write (iout,*) 'mu1',mu1(:,i-2)
3007 cd        write (iout,*) 'mu2',mu2(:,i-2)
3008         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3009      &  then
3010         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3011         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3012         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3013         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3014         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3015 C Vectors and matrices dependent on a single virtual-bond dihedral.
3016         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3017         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3018         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3019         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3020         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3021         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3022         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3023         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3024         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3025         endif
3026       enddo
3027 C Matrices dependent on two consecutive virtual-bond dihedrals.
3028 C The order of matrices is from left to right.
3029       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3030      &then
3031 c      do i=max0(ivec_start,2),ivec_end
3032       do i=2,nres-1
3033         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3034         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3035         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3036         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3037         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3038         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3039         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3040         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3041       enddo
3042       endif
3043 #if defined(MPI) && defined(PARMAT)
3044 #ifdef DEBUG
3045 c      if (fg_rank.eq.0) then
3046         write (iout,*) "Arrays UG and UGDER before GATHER"
3047         do i=1,nres-1
3048           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3049      &     ((ug(l,k,i),l=1,2),k=1,2),
3050      &     ((ugder(l,k,i),l=1,2),k=1,2)
3051         enddo
3052         write (iout,*) "Arrays UG2 and UG2DER"
3053         do i=1,nres-1
3054           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3055      &     ((ug2(l,k,i),l=1,2),k=1,2),
3056      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3057         enddo
3058         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3059         do i=1,nres-1
3060           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3061      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3062      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3063         enddo
3064         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3065         do i=1,nres-1
3066           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3067      &     costab(i),sintab(i),costab2(i),sintab2(i)
3068         enddo
3069         write (iout,*) "Array MUDER"
3070         do i=1,nres-1
3071           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3072         enddo
3073 c      endif
3074 #endif
3075       if (nfgtasks.gt.1) then
3076         time00=MPI_Wtime()
3077 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3078 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3079 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3080 #ifdef MATGATHER
3081         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3082      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3083      &   FG_COMM1,IERR)
3084         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3085      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3086      &   FG_COMM1,IERR)
3087         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3088      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3089      &   FG_COMM1,IERR)
3090         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3091      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3092      &   FG_COMM1,IERR)
3093         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3094      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3095      &   FG_COMM1,IERR)
3096         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3097      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3098      &   FG_COMM1,IERR)
3099         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3100      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3101      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3102         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3103      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3104      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3105         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3106      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3107      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3108         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3109      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3110      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3111         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3112      &  then
3113         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3115      &   FG_COMM1,IERR)
3116         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3118      &   FG_COMM1,IERR)
3119         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3121      &   FG_COMM1,IERR)
3122        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3123      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3124      &   FG_COMM1,IERR)
3125         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3126      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3127      &   FG_COMM1,IERR)
3128         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3129      &   ivec_count(fg_rank1),
3130      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3131      &   FG_COMM1,IERR)
3132         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3133      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3134      &   FG_COMM1,IERR)
3135         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3136      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3137      &   FG_COMM1,IERR)
3138         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3139      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3140      &   FG_COMM1,IERR)
3141         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3142      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3143      &   FG_COMM1,IERR)
3144         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3145      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3146      &   FG_COMM1,IERR)
3147         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3148      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3149      &   FG_COMM1,IERR)
3150         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3151      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3152      &   FG_COMM1,IERR)
3153         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3154      &   ivec_count(fg_rank1),
3155      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3156      &   FG_COMM1,IERR)
3157         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3158      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3159      &   FG_COMM1,IERR)
3160        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3161      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3162      &   FG_COMM1,IERR)
3163         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3164      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3165      &   FG_COMM1,IERR)
3166        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3167      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3168      &   FG_COMM1,IERR)
3169         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3170      &   ivec_count(fg_rank1),
3171      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3172      &   FG_COMM1,IERR)
3173         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3174      &   ivec_count(fg_rank1),
3175      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3176      &   FG_COMM1,IERR)
3177         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3178      &   ivec_count(fg_rank1),
3179      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3180      &   MPI_MAT2,FG_COMM1,IERR)
3181         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3182      &   ivec_count(fg_rank1),
3183      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3184      &   MPI_MAT2,FG_COMM1,IERR)
3185         endif
3186 #else
3187 c Passes matrix info through the ring
3188       isend=fg_rank1
3189       irecv=fg_rank1-1
3190       if (irecv.lt.0) irecv=nfgtasks1-1
3191       iprev=irecv
3192       inext=fg_rank1+1
3193       if (inext.ge.nfgtasks1) inext=0
3194       do i=1,nfgtasks1-1
3195 c        write (iout,*) "isend",isend," irecv",irecv
3196 c        call flush(iout)
3197         lensend=lentyp(isend)
3198         lenrecv=lentyp(irecv)
3199 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3200 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3201 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3202 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3203 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3204 c        write (iout,*) "Gather ROTAT1"
3205 c        call flush(iout)
3206 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3207 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3208 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3209 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3210 c        write (iout,*) "Gather ROTAT2"
3211 c        call flush(iout)
3212         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3213      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3214      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3215      &   iprev,4400+irecv,FG_COMM,status,IERR)
3216 c        write (iout,*) "Gather ROTAT_OLD"
3217 c        call flush(iout)
3218         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3219      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3220      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3221      &   iprev,5500+irecv,FG_COMM,status,IERR)
3222 c        write (iout,*) "Gather PRECOMP11"
3223 c        call flush(iout)
3224         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3225      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3226      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3227      &   iprev,6600+irecv,FG_COMM,status,IERR)
3228 c        write (iout,*) "Gather PRECOMP12"
3229 c        call flush(iout)
3230         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3231      &  then
3232         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3233      &   MPI_ROTAT2(lensend),inext,7700+isend,
3234      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3235      &   iprev,7700+irecv,FG_COMM,status,IERR)
3236 c        write (iout,*) "Gather PRECOMP21"
3237 c        call flush(iout)
3238         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3239      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3240      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3241      &   iprev,8800+irecv,FG_COMM,status,IERR)
3242 c        write (iout,*) "Gather PRECOMP22"
3243 c        call flush(iout)
3244         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3245      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3246      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3247      &   MPI_PRECOMP23(lenrecv),
3248      &   iprev,9900+irecv,FG_COMM,status,IERR)
3249 c        write (iout,*) "Gather PRECOMP23"
3250 c        call flush(iout)
3251         endif
3252         isend=irecv
3253         irecv=irecv-1
3254         if (irecv.lt.0) irecv=nfgtasks1-1
3255       enddo
3256 #endif
3257         time_gather=time_gather+MPI_Wtime()-time00
3258       endif
3259 #ifdef DEBUG
3260 c      if (fg_rank.eq.0) then
3261         write (iout,*) "Arrays UG and UGDER"
3262         do i=1,nres-1
3263           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3264      &     ((ug(l,k,i),l=1,2),k=1,2),
3265      &     ((ugder(l,k,i),l=1,2),k=1,2)
3266         enddo
3267         write (iout,*) "Arrays UG2 and UG2DER"
3268         do i=1,nres-1
3269           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3270      &     ((ug2(l,k,i),l=1,2),k=1,2),
3271      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3272         enddo
3273         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3274         do i=1,nres-1
3275           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3276      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3277      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3278         enddo
3279         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3280         do i=1,nres-1
3281           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3282      &     costab(i),sintab(i),costab2(i),sintab2(i)
3283         enddo
3284         write (iout,*) "Array MUDER"
3285         do i=1,nres-1
3286           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3287         enddo
3288 c      endif
3289 #endif
3290 #endif
3291 cd      do i=1,nres
3292 cd        iti = itortyp(itype(i))
3293 cd        write (iout,*) i
3294 cd        do j=1,2
3295 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3296 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3297 cd        enddo
3298 cd      enddo
3299       return
3300       end
3301 C--------------------------------------------------------------------------
3302       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3303 C
3304 C This subroutine calculates the average interaction energy and its gradient
3305 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3306 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3307 C The potential depends both on the distance of peptide-group centers and on
3308 C the orientation of the CA-CA virtual bonds.
3309 C
3310       implicit real*8 (a-h,o-z)
3311 #ifdef MPI
3312       include 'mpif.h'
3313 #endif
3314       include 'DIMENSIONS'
3315       include 'COMMON.CONTROL'
3316       include 'COMMON.SETUP'
3317       include 'COMMON.IOUNITS'
3318       include 'COMMON.GEO'
3319       include 'COMMON.VAR'
3320       include 'COMMON.LOCAL'
3321       include 'COMMON.CHAIN'
3322       include 'COMMON.DERIV'
3323       include 'COMMON.INTERACT'
3324       include 'COMMON.CONTACTS'
3325       include 'COMMON.TORSION'
3326       include 'COMMON.VECTORS'
3327       include 'COMMON.FFIELD'
3328       include 'COMMON.TIME1'
3329       include 'COMMON.SPLITELE'
3330       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3331      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3332       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3333      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3334       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3335      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3336      &    num_conti,j1,j2
3337 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3338 #ifdef MOMENT
3339       double precision scal_el /1.0d0/
3340 #else
3341       double precision scal_el /0.5d0/
3342 #endif
3343 C 12/13/98
3344 C 13-go grudnia roku pamietnego...
3345       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3346      &                   0.0d0,1.0d0,0.0d0,
3347      &                   0.0d0,0.0d0,1.0d0/
3348 cd      write(iout,*) 'In EELEC'
3349 cd      do i=1,nloctyp
3350 cd        write(iout,*) 'Type',i
3351 cd        write(iout,*) 'B1',B1(:,i)
3352 cd        write(iout,*) 'B2',B2(:,i)
3353 cd        write(iout,*) 'CC',CC(:,:,i)
3354 cd        write(iout,*) 'DD',DD(:,:,i)
3355 cd        write(iout,*) 'EE',EE(:,:,i)
3356 cd      enddo
3357 cd      call check_vecgrad
3358 cd      stop
3359       if (icheckgrad.eq.1) then
3360         do i=1,nres-1
3361           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3362           do k=1,3
3363             dc_norm(k,i)=dc(k,i)*fac
3364           enddo
3365 c          write (iout,*) 'i',i,' fac',fac
3366         enddo
3367       endif
3368       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3369      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3370      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3371 c        call vec_and_deriv
3372 #ifdef TIMING
3373         time01=MPI_Wtime()
3374 #endif
3375         call set_matrices
3376 #ifdef TIMING
3377         time_mat=time_mat+MPI_Wtime()-time01
3378 #endif
3379       endif
3380 cd      do i=1,nres-1
3381 cd        write (iout,*) 'i=',i
3382 cd        do k=1,3
3383 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3384 cd        enddo
3385 cd        do k=1,3
3386 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3387 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3388 cd        enddo
3389 cd      enddo
3390       t_eelecij=0.0d0
3391       ees=0.0D0
3392       evdw1=0.0D0
3393       eel_loc=0.0d0
3394       eello_turn3=0.0d0
3395       eello_turn4=0.0d0
3396       ind=0
3397       do i=1,nres
3398         num_cont_hb(i)=0
3399       enddo
3400 cd      print '(a)','Enter EELEC'
3401 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3402       do i=1,nres
3403         gel_loc_loc(i)=0.0d0
3404         gcorr_loc(i)=0.0d0
3405       enddo
3406 c
3407 c
3408 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3409 C
3410 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3411 C
3412 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3413       do i=iturn3_start,iturn3_end
3414         if (i.le.1) cycle
3415 C        write(iout,*) "tu jest i",i
3416         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3417 C changes suggested by Ana to avoid out of bounds
3418      & .or.((i+4).gt.nres)
3419      & .or.((i-1).le.0)
3420 C end of changes by Ana
3421      &  .or. itype(i+2).eq.ntyp1
3422      &  .or. itype(i+3).eq.ntyp1) cycle
3423         if(i.gt.1)then
3424           if(itype(i-1).eq.ntyp1)cycle
3425         end if
3426         if(i.LT.nres-3)then
3427           if (itype(i+4).eq.ntyp1) cycle
3428         end if
3429         dxi=dc(1,i)
3430         dyi=dc(2,i)
3431         dzi=dc(3,i)
3432         dx_normi=dc_norm(1,i)
3433         dy_normi=dc_norm(2,i)
3434         dz_normi=dc_norm(3,i)
3435         xmedi=c(1,i)+0.5d0*dxi
3436         ymedi=c(2,i)+0.5d0*dyi
3437         zmedi=c(3,i)+0.5d0*dzi
3438           xmedi=mod(xmedi,boxxsize)
3439           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3440           ymedi=mod(ymedi,boxysize)
3441           if (ymedi.lt.0) ymedi=ymedi+boxysize
3442           zmedi=mod(zmedi,boxzsize)
3443           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3444         num_conti=0
3445         call eelecij(i,i+2,ees,evdw1,eel_loc)
3446         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3447         num_cont_hb(i)=num_conti
3448       enddo
3449       do i=iturn4_start,iturn4_end
3450         if (i.le.1) cycle
3451         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3452 C changes suggested by Ana to avoid out of bounds
3453      & .or.((i+5).gt.nres)
3454      & .or.((i-1).le.0)
3455 C end of changes suggested by Ana
3456      &    .or. itype(i+3).eq.ntyp1
3457      &    .or. itype(i+4).eq.ntyp1
3458      &    .or. itype(i+5).eq.ntyp1
3459      &    .or. itype(i).eq.ntyp1
3460      &    .or. itype(i-1).eq.ntyp1
3461      &                             ) cycle
3462         dxi=dc(1,i)
3463         dyi=dc(2,i)
3464         dzi=dc(3,i)
3465         dx_normi=dc_norm(1,i)
3466         dy_normi=dc_norm(2,i)
3467         dz_normi=dc_norm(3,i)
3468         xmedi=c(1,i)+0.5d0*dxi
3469         ymedi=c(2,i)+0.5d0*dyi
3470         zmedi=c(3,i)+0.5d0*dzi
3471 C Return atom into box, boxxsize is size of box in x dimension
3472 c  194   continue
3473 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3474 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3475 C Condition for being inside the proper box
3476 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3477 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3478 c        go to 194
3479 c        endif
3480 c  195   continue
3481 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3482 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3483 C Condition for being inside the proper box
3484 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3485 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3486 c        go to 195
3487 c        endif
3488 c  196   continue
3489 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3490 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3491 C Condition for being inside the proper box
3492 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3493 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3494 c        go to 196
3495 c        endif
3496           xmedi=mod(xmedi,boxxsize)
3497           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3498           ymedi=mod(ymedi,boxysize)
3499           if (ymedi.lt.0) ymedi=ymedi+boxysize
3500           zmedi=mod(zmedi,boxzsize)
3501           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3502
3503         num_conti=num_cont_hb(i)
3504 c        write(iout,*) "JESTEM W PETLI"
3505         call eelecij(i,i+3,ees,evdw1,eel_loc)
3506         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3507      &   call eturn4(i,eello_turn4)
3508         num_cont_hb(i)=num_conti
3509       enddo   ! i
3510 C Loop over all neighbouring boxes
3511 C      do xshift=-1,1
3512 C      do yshift=-1,1
3513 C      do zshift=-1,1
3514 c
3515 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3516 c
3517 CTU KURWA
3518       do i=iatel_s,iatel_e
3519 C        do i=75,75
3520         if (i.le.1) cycle
3521         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3522 C changes suggested by Ana to avoid out of bounds
3523      & .or.((i+2).gt.nres)
3524      & .or.((i-1).le.0)
3525 C end of changes by Ana
3526      &  .or. itype(i+2).eq.ntyp1
3527      &  .or. itype(i-1).eq.ntyp1
3528      &                ) cycle
3529         dxi=dc(1,i)
3530         dyi=dc(2,i)
3531         dzi=dc(3,i)
3532         dx_normi=dc_norm(1,i)
3533         dy_normi=dc_norm(2,i)
3534         dz_normi=dc_norm(3,i)
3535         xmedi=c(1,i)+0.5d0*dxi
3536         ymedi=c(2,i)+0.5d0*dyi
3537         zmedi=c(3,i)+0.5d0*dzi
3538           xmedi=mod(xmedi,boxxsize)
3539           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3540           ymedi=mod(ymedi,boxysize)
3541           if (ymedi.lt.0) ymedi=ymedi+boxysize
3542           zmedi=mod(zmedi,boxzsize)
3543           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3544 C          xmedi=xmedi+xshift*boxxsize
3545 C          ymedi=ymedi+yshift*boxysize
3546 C          zmedi=zmedi+zshift*boxzsize
3547
3548 C Return tom into box, boxxsize is size of box in x dimension
3549 c  164   continue
3550 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3551 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3552 C Condition for being inside the proper box
3553 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3554 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3555 c        go to 164
3556 c        endif
3557 c  165   continue
3558 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3559 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3560 C Condition for being inside the proper box
3561 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3562 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3563 c        go to 165
3564 c        endif
3565 c  166   continue
3566 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3567 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3568 cC Condition for being inside the proper box
3569 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3570 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3571 c        go to 166
3572 c        endif
3573
3574 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3575         num_conti=num_cont_hb(i)
3576 C I TU KURWA
3577         do j=ielstart(i),ielend(i)
3578 C          do j=16,17
3579 C          write (iout,*) i,j
3580          if (j.le.1) cycle
3581           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3582 C changes suggested by Ana to avoid out of bounds
3583      & .or.((j+2).gt.nres)
3584      & .or.((j-1).le.0)
3585 C end of changes by Ana
3586      & .or.itype(j+2).eq.ntyp1
3587      & .or.itype(j-1).eq.ntyp1
3588      &) cycle
3589           call eelecij(i,j,ees,evdw1,eel_loc)
3590         enddo ! j
3591         num_cont_hb(i)=num_conti
3592       enddo   ! i
3593 C     enddo   ! zshift
3594 C      enddo   ! yshift
3595 C      enddo   ! xshift
3596
3597 c      write (iout,*) "Number of loop steps in EELEC:",ind
3598 cd      do i=1,nres
3599 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3600 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3601 cd      enddo
3602 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3603 ccc      eel_loc=eel_loc+eello_turn3
3604 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3605       return
3606       end
3607 C-------------------------------------------------------------------------------
3608       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3609       implicit real*8 (a-h,o-z)
3610       include 'DIMENSIONS'
3611 #ifdef MPI
3612       include "mpif.h"
3613 #endif
3614       include 'COMMON.CONTROL'
3615       include 'COMMON.IOUNITS'
3616       include 'COMMON.GEO'
3617       include 'COMMON.VAR'
3618       include 'COMMON.LOCAL'
3619       include 'COMMON.CHAIN'
3620       include 'COMMON.DERIV'
3621       include 'COMMON.INTERACT'
3622       include 'COMMON.CONTACTS'
3623       include 'COMMON.TORSION'
3624       include 'COMMON.VECTORS'
3625       include 'COMMON.FFIELD'
3626       include 'COMMON.TIME1'
3627       include 'COMMON.SPLITELE'
3628       include 'COMMON.SHIELD'
3629       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3630      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3631       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3632      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3633      &    gmuij2(4),gmuji2(4)
3634       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3635      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3636      &    num_conti,j1,j2
3637 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3638 #ifdef MOMENT
3639       double precision scal_el /1.0d0/
3640 #else
3641       double precision scal_el /0.5d0/
3642 #endif
3643 C 12/13/98
3644 C 13-go grudnia roku pamietnego...
3645       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3646      &                   0.0d0,1.0d0,0.0d0,
3647      &                   0.0d0,0.0d0,1.0d0/
3648 c          time00=MPI_Wtime()
3649 cd      write (iout,*) "eelecij",i,j
3650 c          ind=ind+1
3651           iteli=itel(i)
3652           itelj=itel(j)
3653           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3654           aaa=app(iteli,itelj)
3655           bbb=bpp(iteli,itelj)
3656           ael6i=ael6(iteli,itelj)
3657           ael3i=ael3(iteli,itelj)
3658           dxj=dc(1,j)
3659           dyj=dc(2,j)
3660           dzj=dc(3,j)
3661           dx_normj=dc_norm(1,j)
3662           dy_normj=dc_norm(2,j)
3663           dz_normj=dc_norm(3,j)
3664 C          xj=c(1,j)+0.5D0*dxj-xmedi
3665 C          yj=c(2,j)+0.5D0*dyj-ymedi
3666 C          zj=c(3,j)+0.5D0*dzj-zmedi
3667           xj=c(1,j)+0.5D0*dxj
3668           yj=c(2,j)+0.5D0*dyj
3669           zj=c(3,j)+0.5D0*dzj
3670           xj=mod(xj,boxxsize)
3671           if (xj.lt.0) xj=xj+boxxsize
3672           yj=mod(yj,boxysize)
3673           if (yj.lt.0) yj=yj+boxysize
3674           zj=mod(zj,boxzsize)
3675           if (zj.lt.0) zj=zj+boxzsize
3676           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3677       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3678       xj_safe=xj
3679       yj_safe=yj
3680       zj_safe=zj
3681       isubchap=0
3682       do xshift=-1,1
3683       do yshift=-1,1
3684       do zshift=-1,1
3685           xj=xj_safe+xshift*boxxsize
3686           yj=yj_safe+yshift*boxysize
3687           zj=zj_safe+zshift*boxzsize
3688           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3689           if(dist_temp.lt.dist_init) then
3690             dist_init=dist_temp
3691             xj_temp=xj
3692             yj_temp=yj
3693             zj_temp=zj
3694             isubchap=1
3695           endif
3696        enddo
3697        enddo
3698        enddo
3699        if (isubchap.eq.1) then
3700           xj=xj_temp-xmedi
3701           yj=yj_temp-ymedi
3702           zj=zj_temp-zmedi
3703        else
3704           xj=xj_safe-xmedi
3705           yj=yj_safe-ymedi
3706           zj=zj_safe-zmedi
3707        endif
3708 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3709 c  174   continue
3710 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3711 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3712 C Condition for being inside the proper box
3713 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3714 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3715 c        go to 174
3716 c        endif
3717 c  175   continue
3718 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3719 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3720 C Condition for being inside the proper box
3721 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3722 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3723 c        go to 175
3724 c        endif
3725 c  176   continue
3726 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3727 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3728 C Condition for being inside the proper box
3729 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3730 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3731 c        go to 176
3732 c        endif
3733 C        endif !endPBC condintion
3734 C        xj=xj-xmedi
3735 C        yj=yj-ymedi
3736 C        zj=zj-zmedi
3737           rij=xj*xj+yj*yj+zj*zj
3738
3739             sss=sscale(sqrt(rij))
3740             sssgrad=sscagrad(sqrt(rij))
3741 c            if (sss.gt.0.0d0) then
3742           rrmij=1.0D0/rij
3743           rij=dsqrt(rij)
3744           rmij=1.0D0/rij
3745           r3ij=rrmij*rmij
3746           r6ij=r3ij*r3ij
3747           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3748           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3749           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3750           fac=cosa-3.0D0*cosb*cosg
3751           ev1=aaa*r6ij*r6ij
3752 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3753           if (j.eq.i+2) ev1=scal_el*ev1
3754           ev2=bbb*r6ij
3755           fac3=ael6i*r6ij
3756           fac4=ael3i*r3ij
3757           evdwij=(ev1+ev2)
3758           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3759           el2=fac4*fac
3760 C MARYSIA
3761 C          eesij=(el1+el2)
3762 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3763           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3764           if (shield_mode.gt.0) then
3765 C          fac_shield(i)=0.4
3766 C          fac_shield(j)=0.6
3767           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3768           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3769           eesij=(el1+el2)
3770           ees=ees+eesij
3771           else
3772           fac_shield(i)=1.0
3773           fac_shield(j)=1.0
3774           eesij=(el1+el2)
3775           ees=ees+eesij
3776           endif
3777           evdw1=evdw1+evdwij*sss
3778 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3779 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3780 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3781 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3782
3783           if (energy_dec) then
3784               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3785      &'evdw1',i,j,evdwij
3786      &,iteli,itelj,aaa,evdw1
3787               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3788      &fac_shield(i),fac_shield(j)
3789           endif
3790
3791 C
3792 C Calculate contributions to the Cartesian gradient.
3793 C
3794 #ifdef SPLITELE
3795           facvdw=-6*rrmij*(ev1+evdwij)*sss
3796           facel=-3*rrmij*(el1+eesij)
3797           fac1=fac
3798           erij(1)=xj*rmij
3799           erij(2)=yj*rmij
3800           erij(3)=zj*rmij
3801
3802 *
3803 * Radial derivatives. First process both termini of the fragment (i,j)
3804 *
3805           ggg(1)=facel*xj
3806           ggg(2)=facel*yj
3807           ggg(3)=facel*zj
3808           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3809      &  (shield_mode.gt.0)) then
3810 C          print *,i,j
3811           do ilist=1,ishield_list(i)
3812            iresshield=shield_list(ilist,i)
3813            do k=1,3
3814            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3815      &      *2.0
3816            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3817      &              rlocshield
3818      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3819             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3820 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3821 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3822 C             if (iresshield.gt.i) then
3823 C               do ishi=i+1,iresshield-1
3824 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3825 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3826 C
3827 C              enddo
3828 C             else
3829 C               do ishi=iresshield,i
3830 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3831 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3832 C
3833 C               enddo
3834 C              endif
3835            enddo
3836           enddo
3837           do ilist=1,ishield_list(j)
3838            iresshield=shield_list(ilist,j)
3839            do k=1,3
3840            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3841      &     *2.0
3842            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3843      &              rlocshield
3844      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3845            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3846
3847 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3848 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3849 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3850 C             if (iresshield.gt.j) then
3851 C               do ishi=j+1,iresshield-1
3852 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3853 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3854 C
3855 C               enddo
3856 C            else
3857 C               do ishi=iresshield,j
3858 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3859 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3860 C               enddo
3861 C              endif
3862            enddo
3863           enddo
3864
3865           do k=1,3
3866             gshieldc(k,i)=gshieldc(k,i)+
3867      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3868             gshieldc(k,j)=gshieldc(k,j)+
3869      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3870             gshieldc(k,i-1)=gshieldc(k,i-1)+
3871      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3872             gshieldc(k,j-1)=gshieldc(k,j-1)+
3873      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3874
3875            enddo
3876            endif
3877 c          do k=1,3
3878 c            ghalf=0.5D0*ggg(k)
3879 c            gelc(k,i)=gelc(k,i)+ghalf
3880 c            gelc(k,j)=gelc(k,j)+ghalf
3881 c          enddo
3882 c 9/28/08 AL Gradient compotents will be summed only at the end
3883 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3884           do k=1,3
3885             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3886 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3887             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3888 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3889 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3890 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3891 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3892 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3893           enddo
3894 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3895
3896 *
3897 * Loop over residues i+1 thru j-1.
3898 *
3899 cgrad          do k=i+1,j-1
3900 cgrad            do l=1,3
3901 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3902 cgrad            enddo
3903 cgrad          enddo
3904           if (sss.gt.0.0) then
3905           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3906           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3907           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3908           else
3909           ggg(1)=0.0
3910           ggg(2)=0.0
3911           ggg(3)=0.0
3912           endif
3913 c          do k=1,3
3914 c            ghalf=0.5D0*ggg(k)
3915 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3916 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3917 c          enddo
3918 c 9/28/08 AL Gradient compotents will be summed only at the end
3919           do k=1,3
3920             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3921             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3922           enddo
3923 *
3924 * Loop over residues i+1 thru j-1.
3925 *
3926 cgrad          do k=i+1,j-1
3927 cgrad            do l=1,3
3928 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3929 cgrad            enddo
3930 cgrad          enddo
3931 #else
3932 C MARYSIA
3933           facvdw=(ev1+evdwij)*sss
3934           facel=(el1+eesij)
3935           fac1=fac
3936           fac=-3*rrmij*(facvdw+facvdw+facel)
3937           erij(1)=xj*rmij
3938           erij(2)=yj*rmij
3939           erij(3)=zj*rmij
3940 *
3941 * Radial derivatives. First process both termini of the fragment (i,j)
3942 *
3943           ggg(1)=fac*xj
3944 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3945           ggg(2)=fac*yj
3946 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3947           ggg(3)=fac*zj
3948 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3949 c          do k=1,3
3950 c            ghalf=0.5D0*ggg(k)
3951 c            gelc(k,i)=gelc(k,i)+ghalf
3952 c            gelc(k,j)=gelc(k,j)+ghalf
3953 c          enddo
3954 c 9/28/08 AL Gradient compotents will be summed only at the end
3955           do k=1,3
3956             gelc_long(k,j)=gelc(k,j)+ggg(k)
3957             gelc_long(k,i)=gelc(k,i)-ggg(k)
3958           enddo
3959 *
3960 * Loop over residues i+1 thru j-1.
3961 *
3962 cgrad          do k=i+1,j-1
3963 cgrad            do l=1,3
3964 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3965 cgrad            enddo
3966 cgrad          enddo
3967 c 9/28/08 AL Gradient compotents will be summed only at the end
3968           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3969           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3970           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3971           do k=1,3
3972             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3973             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3974           enddo
3975 #endif
3976 *
3977 * Angular part
3978 *
3979           ecosa=2.0D0*fac3*fac1+fac4
3980           fac4=-3.0D0*fac4
3981           fac3=-6.0D0*fac3
3982           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3983           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3984           do k=1,3
3985             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3986             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3987           enddo
3988 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3989 cd   &          (dcosg(k),k=1,3)
3990           do k=1,3
3991             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3992      &      fac_shield(i)**2*fac_shield(j)**2
3993           enddo
3994 c          do k=1,3
3995 c            ghalf=0.5D0*ggg(k)
3996 c            gelc(k,i)=gelc(k,i)+ghalf
3997 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3998 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3999 c            gelc(k,j)=gelc(k,j)+ghalf
4000 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4001 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4002 c          enddo
4003 cgrad          do k=i+1,j-1
4004 cgrad            do l=1,3
4005 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4006 cgrad            enddo
4007 cgrad          enddo
4008 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4009           do k=1,3
4010             gelc(k,i)=gelc(k,i)
4011      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4012      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4013      &           *fac_shield(i)**2*fac_shield(j)**2
4014             gelc(k,j)=gelc(k,j)
4015      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4016      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4017      &           *fac_shield(i)**2*fac_shield(j)**2
4018             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4019             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4020           enddo
4021 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4022
4023 C MARYSIA
4024 c          endif !sscale
4025           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4026      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4027      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4028 C
4029 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4030 C   energy of a peptide unit is assumed in the form of a second-order
4031 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4032 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4033 C   are computed for EVERY pair of non-contiguous peptide groups.
4034 C
4035
4036           if (j.lt.nres-1) then
4037             j1=j+1
4038             j2=j-1
4039           else
4040             j1=j-1
4041             j2=j-2
4042           endif
4043           kkk=0
4044           lll=0
4045           do k=1,2
4046             do l=1,2
4047               kkk=kkk+1
4048               muij(kkk)=mu(k,i)*mu(l,j)
4049 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4050 #ifdef NEWCORR
4051              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4052 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4053              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4054              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4055 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4056              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4057 #endif
4058             enddo
4059           enddo
4060 cd         write (iout,*) 'EELEC: i',i,' j',j
4061 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4062 cd          write(iout,*) 'muij',muij
4063           ury=scalar(uy(1,i),erij)
4064           urz=scalar(uz(1,i),erij)
4065           vry=scalar(uy(1,j),erij)
4066           vrz=scalar(uz(1,j),erij)
4067           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4068           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4069           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4070           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4071           fac=dsqrt(-ael6i)*r3ij
4072           a22=a22*fac
4073           a23=a23*fac
4074           a32=a32*fac
4075           a33=a33*fac
4076 cd          write (iout,'(4i5,4f10.5)')
4077 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4078 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4079 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4080 cd     &      uy(:,j),uz(:,j)
4081 cd          write (iout,'(4f10.5)')
4082 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4083 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4084 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4085 cd           write (iout,'(9f10.5/)')
4086 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4087 C Derivatives of the elements of A in virtual-bond vectors
4088           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4089           do k=1,3
4090             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4091             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4092             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4093             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4094             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4095             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4096             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4097             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4098             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4099             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4100             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4101             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4102           enddo
4103 C Compute radial contributions to the gradient
4104           facr=-3.0d0*rrmij
4105           a22der=a22*facr
4106           a23der=a23*facr
4107           a32der=a32*facr
4108           a33der=a33*facr
4109           agg(1,1)=a22der*xj
4110           agg(2,1)=a22der*yj
4111           agg(3,1)=a22der*zj
4112           agg(1,2)=a23der*xj
4113           agg(2,2)=a23der*yj
4114           agg(3,2)=a23der*zj
4115           agg(1,3)=a32der*xj
4116           agg(2,3)=a32der*yj
4117           agg(3,3)=a32der*zj
4118           agg(1,4)=a33der*xj
4119           agg(2,4)=a33der*yj
4120           agg(3,4)=a33der*zj
4121 C Add the contributions coming from er
4122           fac3=-3.0d0*fac
4123           do k=1,3
4124             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4125             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4126             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4127             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4128           enddo
4129           do k=1,3
4130 C Derivatives in DC(i)
4131 cgrad            ghalf1=0.5d0*agg(k,1)
4132 cgrad            ghalf2=0.5d0*agg(k,2)
4133 cgrad            ghalf3=0.5d0*agg(k,3)
4134 cgrad            ghalf4=0.5d0*agg(k,4)
4135             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4136      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4137             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4138      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4139             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4140      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4141             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4142      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4143 C Derivatives in DC(i+1)
4144             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4145      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4146             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4147      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4148             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4149      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4150             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4151      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4152 C Derivatives in DC(j)
4153             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4154      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4155             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4156      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4157             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4158      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4159             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4160      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4161 C Derivatives in DC(j+1) or DC(nres-1)
4162             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4163      &      -3.0d0*vryg(k,3)*ury)
4164             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4165      &      -3.0d0*vrzg(k,3)*ury)
4166             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4167      &      -3.0d0*vryg(k,3)*urz)
4168             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4169      &      -3.0d0*vrzg(k,3)*urz)
4170 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4171 cgrad              do l=1,4
4172 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4173 cgrad              enddo
4174 cgrad            endif
4175           enddo
4176           acipa(1,1)=a22
4177           acipa(1,2)=a23
4178           acipa(2,1)=a32
4179           acipa(2,2)=a33
4180           a22=-a22
4181           a23=-a23
4182           do l=1,2
4183             do k=1,3
4184               agg(k,l)=-agg(k,l)
4185               aggi(k,l)=-aggi(k,l)
4186               aggi1(k,l)=-aggi1(k,l)
4187               aggj(k,l)=-aggj(k,l)
4188               aggj1(k,l)=-aggj1(k,l)
4189             enddo
4190           enddo
4191           if (j.lt.nres-1) then
4192             a22=-a22
4193             a32=-a32
4194             do l=1,3,2
4195               do k=1,3
4196                 agg(k,l)=-agg(k,l)
4197                 aggi(k,l)=-aggi(k,l)
4198                 aggi1(k,l)=-aggi1(k,l)
4199                 aggj(k,l)=-aggj(k,l)
4200                 aggj1(k,l)=-aggj1(k,l)
4201               enddo
4202             enddo
4203           else
4204             a22=-a22
4205             a23=-a23
4206             a32=-a32
4207             a33=-a33
4208             do l=1,4
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           endif
4218           ENDIF ! WCORR
4219           IF (wel_loc.gt.0.0d0) THEN
4220 C Contribution to the local-electrostatic energy coming from the i-j pair
4221           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4222      &     +a33*muij(4)
4223           if (shield_mode.eq.0) then
4224            fac_shield(i)=1.0
4225            fac_shield(j)=1.0
4226 C          else
4227 C           fac_shield(i)=0.4
4228 C           fac_shield(j)=0.6
4229           endif
4230           eel_loc_ij=eel_loc_ij
4231      &    *fac_shield(i)*fac_shield(j)
4232 C Now derivative over eel_loc
4233           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4234      &  (shield_mode.gt.0)) then
4235 C          print *,i,j
4236
4237           do ilist=1,ishield_list(i)
4238            iresshield=shield_list(ilist,i)
4239            do k=1,3
4240            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4241      &                                          /fac_shield(i)
4242 C     &      *2.0
4243            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4244      &              rlocshield
4245      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4246             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4247      &      +rlocshield
4248            enddo
4249           enddo
4250           do ilist=1,ishield_list(j)
4251            iresshield=shield_list(ilist,j)
4252            do k=1,3
4253            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4254      &                                       /fac_shield(j)
4255 C     &     *2.0
4256            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4257      &              rlocshield
4258      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4259            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4260      &             +rlocshield
4261
4262            enddo
4263           enddo
4264
4265           do k=1,3
4266             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4267      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4268             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4269      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4270             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4271      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4272             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4273      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4274            enddo
4275            endif
4276
4277
4278 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4279 c     &                     ' eel_loc_ij',eel_loc_ij
4280 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4281 C Calculate patrial derivative for theta angle
4282 #ifdef NEWCORR
4283          geel_loc_ij=(a22*gmuij1(1)
4284      &     +a23*gmuij1(2)
4285      &     +a32*gmuij1(3)
4286      &     +a33*gmuij1(4))
4287      &    *fac_shield(i)*fac_shield(j)
4288 c         write(iout,*) "derivative over thatai"
4289 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4290 c     &   a33*gmuij1(4)
4291          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4292      &      geel_loc_ij*wel_loc
4293 c         write(iout,*) "derivative over thatai-1"
4294 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4295 c     &   a33*gmuij2(4)
4296          geel_loc_ij=
4297      &     a22*gmuij2(1)
4298      &     +a23*gmuij2(2)
4299      &     +a32*gmuij2(3)
4300      &     +a33*gmuij2(4)
4301          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4302      &      geel_loc_ij*wel_loc
4303      &    *fac_shield(i)*fac_shield(j)
4304
4305 c  Derivative over j residue
4306          geel_loc_ji=a22*gmuji1(1)
4307      &     +a23*gmuji1(2)
4308      &     +a32*gmuji1(3)
4309      &     +a33*gmuji1(4)
4310 c         write(iout,*) "derivative over thataj"
4311 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4312 c     &   a33*gmuji1(4)
4313
4314         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4315      &      geel_loc_ji*wel_loc
4316      &    *fac_shield(i)*fac_shield(j)
4317
4318          geel_loc_ji=
4319      &     +a22*gmuji2(1)
4320      &     +a23*gmuji2(2)
4321      &     +a32*gmuji2(3)
4322      &     +a33*gmuji2(4)
4323 c         write(iout,*) "derivative over thataj-1"
4324 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4325 c     &   a33*gmuji2(4)
4326          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4327      &      geel_loc_ji*wel_loc
4328      &    *fac_shield(i)*fac_shield(j)
4329 #endif
4330 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4331
4332           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4333      &            'eelloc',i,j,eel_loc_ij
4334 c           if (eel_loc_ij.ne.0)
4335 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4336 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4337
4338           eel_loc=eel_loc+eel_loc_ij
4339 C Partial derivatives in virtual-bond dihedral angles gamma
4340           if (i.gt.1)
4341      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4342      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4343      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4344      &    *fac_shield(i)*fac_shield(j)
4345
4346           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4347      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4348      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4349      &    *fac_shield(i)*fac_shield(j)
4350 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4351           do l=1,3
4352             ggg(l)=(agg(l,1)*muij(1)+
4353      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4354      &    *fac_shield(i)*fac_shield(j)
4355             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4356             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4357 cgrad            ghalf=0.5d0*ggg(l)
4358 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4359 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4360           enddo
4361 cgrad          do k=i+1,j2
4362 cgrad            do l=1,3
4363 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4364 cgrad            enddo
4365 cgrad          enddo
4366 C Remaining derivatives of eello
4367           do l=1,3
4368             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4369      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4370      &    *fac_shield(i)*fac_shield(j)
4371
4372             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4373      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4374      &    *fac_shield(i)*fac_shield(j)
4375
4376             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4377      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4378      &    *fac_shield(i)*fac_shield(j)
4379
4380             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4381      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4382      &    *fac_shield(i)*fac_shield(j)
4383
4384           enddo
4385           ENDIF
4386 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4387 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4388           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4389      &       .and. num_conti.le.maxconts) then
4390 c            write (iout,*) i,j," entered corr"
4391 C
4392 C Calculate the contact function. The ith column of the array JCONT will
4393 C contain the numbers of atoms that make contacts with the atom I (of numbers
4394 C greater than I). The arrays FACONT and GACONT will contain the values of
4395 C the contact function and its derivative.
4396 c           r0ij=1.02D0*rpp(iteli,itelj)
4397 c           r0ij=1.11D0*rpp(iteli,itelj)
4398             r0ij=2.20D0*rpp(iteli,itelj)
4399 c           r0ij=1.55D0*rpp(iteli,itelj)
4400             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4401             if (fcont.gt.0.0D0) then
4402               num_conti=num_conti+1
4403               if (num_conti.gt.maxconts) then
4404                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4405      &                         ' will skip next contacts for this conf.'
4406               else
4407                 jcont_hb(num_conti,i)=j
4408 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4409 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4410                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4411      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4412 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4413 C  terms.
4414                 d_cont(num_conti,i)=rij
4415 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4416 C     --- Electrostatic-interaction matrix ---
4417                 a_chuj(1,1,num_conti,i)=a22
4418                 a_chuj(1,2,num_conti,i)=a23
4419                 a_chuj(2,1,num_conti,i)=a32
4420                 a_chuj(2,2,num_conti,i)=a33
4421 C     --- Gradient of rij
4422                 do kkk=1,3
4423                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4424                 enddo
4425                 kkll=0
4426                 do k=1,2
4427                   do l=1,2
4428                     kkll=kkll+1
4429                     do m=1,3
4430                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4431                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4432                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4433                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4434                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4435                     enddo
4436                   enddo
4437                 enddo
4438                 ENDIF
4439                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4440 C Calculate contact energies
4441                 cosa4=4.0D0*cosa
4442                 wij=cosa-3.0D0*cosb*cosg
4443                 cosbg1=cosb+cosg
4444                 cosbg2=cosb-cosg
4445 c               fac3=dsqrt(-ael6i)/r0ij**3
4446                 fac3=dsqrt(-ael6i)*r3ij
4447 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4448                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4449                 if (ees0tmp.gt.0) then
4450                   ees0pij=dsqrt(ees0tmp)
4451                 else
4452                   ees0pij=0
4453                 endif
4454 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4455                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4456                 if (ees0tmp.gt.0) then
4457                   ees0mij=dsqrt(ees0tmp)
4458                 else
4459                   ees0mij=0
4460                 endif
4461 c               ees0mij=0.0D0
4462                 if (shield_mode.eq.0) then
4463                 fac_shield(i)=1.0d0
4464                 fac_shield(j)=1.0d0
4465                 else
4466                 ees0plist(num_conti,i)=j
4467 C                fac_shield(i)=0.4d0
4468 C                fac_shield(j)=0.6d0
4469                 endif
4470                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4471      &          *fac_shield(i)*fac_shield(j)
4472                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4473      &          *fac_shield(i)*fac_shield(j)
4474 C Diagnostics. Comment out or remove after debugging!
4475 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4476 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4477 c               ees0m(num_conti,i)=0.0D0
4478 C End diagnostics.
4479 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4480 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4481 C Angular derivatives of the contact function
4482                 ees0pij1=fac3/ees0pij
4483                 ees0mij1=fac3/ees0mij
4484                 fac3p=-3.0D0*fac3*rrmij
4485                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4486                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4487 c               ees0mij1=0.0D0
4488                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4489                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4490                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4491                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4492                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4493                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4494                 ecosap=ecosa1+ecosa2
4495                 ecosbp=ecosb1+ecosb2
4496                 ecosgp=ecosg1+ecosg2
4497                 ecosam=ecosa1-ecosa2
4498                 ecosbm=ecosb1-ecosb2
4499                 ecosgm=ecosg1-ecosg2
4500 C Diagnostics
4501 c               ecosap=ecosa1
4502 c               ecosbp=ecosb1
4503 c               ecosgp=ecosg1
4504 c               ecosam=0.0D0
4505 c               ecosbm=0.0D0
4506 c               ecosgm=0.0D0
4507 C End diagnostics
4508                 facont_hb(num_conti,i)=fcont
4509                 fprimcont=fprimcont/rij
4510 cd              facont_hb(num_conti,i)=1.0D0
4511 C Following line is for diagnostics.
4512 cd              fprimcont=0.0D0
4513                 do k=1,3
4514                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4515                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4516                 enddo
4517                 do k=1,3
4518                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4519                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4520                 enddo
4521                 gggp(1)=gggp(1)+ees0pijp*xj
4522                 gggp(2)=gggp(2)+ees0pijp*yj
4523                 gggp(3)=gggp(3)+ees0pijp*zj
4524                 gggm(1)=gggm(1)+ees0mijp*xj
4525                 gggm(2)=gggm(2)+ees0mijp*yj
4526                 gggm(3)=gggm(3)+ees0mijp*zj
4527 C Derivatives due to the contact function
4528                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4529                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4530                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4531                 do k=1,3
4532 c
4533 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4534 c          following the change of gradient-summation algorithm.
4535 c
4536 cgrad                  ghalfp=0.5D0*gggp(k)
4537 cgrad                  ghalfm=0.5D0*gggm(k)
4538                   gacontp_hb1(k,num_conti,i)=!ghalfp
4539      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4540      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4541      &          *fac_shield(i)*fac_shield(j)
4542
4543                   gacontp_hb2(k,num_conti,i)=!ghalfp
4544      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4545      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4546      &          *fac_shield(i)*fac_shield(j)
4547
4548                   gacontp_hb3(k,num_conti,i)=gggp(k)
4549      &          *fac_shield(i)*fac_shield(j)
4550
4551                   gacontm_hb1(k,num_conti,i)=!ghalfm
4552      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4553      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4554      &          *fac_shield(i)*fac_shield(j)
4555
4556                   gacontm_hb2(k,num_conti,i)=!ghalfm
4557      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4558      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4559      &          *fac_shield(i)*fac_shield(j)
4560
4561                   gacontm_hb3(k,num_conti,i)=gggm(k)
4562      &          *fac_shield(i)*fac_shield(j)
4563
4564                 enddo
4565 C Diagnostics. Comment out or remove after debugging!
4566 cdiag           do k=1,3
4567 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4568 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4569 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4570 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4571 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4572 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4573 cdiag           enddo
4574               ENDIF ! wcorr
4575               endif  ! num_conti.le.maxconts
4576             endif  ! fcont.gt.0
4577           endif    ! j.gt.i+1
4578           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4579             do k=1,4
4580               do l=1,3
4581                 ghalf=0.5d0*agg(l,k)
4582                 aggi(l,k)=aggi(l,k)+ghalf
4583                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4584                 aggj(l,k)=aggj(l,k)+ghalf
4585               enddo
4586             enddo
4587             if (j.eq.nres-1 .and. i.lt.j-2) then
4588               do k=1,4
4589                 do l=1,3
4590                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4591                 enddo
4592               enddo
4593             endif
4594           endif
4595 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4596       return
4597       end
4598 C-----------------------------------------------------------------------------
4599       subroutine eturn3(i,eello_turn3)
4600 C Third- and fourth-order contributions from turns
4601       implicit real*8 (a-h,o-z)
4602       include 'DIMENSIONS'
4603       include 'COMMON.IOUNITS'
4604       include 'COMMON.GEO'
4605       include 'COMMON.VAR'
4606       include 'COMMON.LOCAL'
4607       include 'COMMON.CHAIN'
4608       include 'COMMON.DERIV'
4609       include 'COMMON.INTERACT'
4610       include 'COMMON.CONTACTS'
4611       include 'COMMON.TORSION'
4612       include 'COMMON.VECTORS'
4613       include 'COMMON.FFIELD'
4614       include 'COMMON.CONTROL'
4615       include 'COMMON.SHIELD'
4616       dimension ggg(3)
4617       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4618      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4619      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4620      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4621      &  auxgmat2(2,2),auxgmatt2(2,2)
4622       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4623      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4624       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4625      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4626      &    num_conti,j1,j2
4627       j=i+2
4628 c      write (iout,*) "eturn3",i,j,j1,j2
4629       a_temp(1,1)=a22
4630       a_temp(1,2)=a23
4631       a_temp(2,1)=a32
4632       a_temp(2,2)=a33
4633 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4634 C
4635 C               Third-order contributions
4636 C
4637 C                 (i+2)o----(i+3)
4638 C                      | |
4639 C                      | |
4640 C                 (i+1)o----i
4641 C
4642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4643 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4644         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4645 c auxalary matices for theta gradient
4646 c auxalary matrix for i+1 and constant i+2
4647         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4648 c auxalary matrix for i+2 and constant i+1
4649         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4650         call transpose2(auxmat(1,1),auxmat1(1,1))
4651         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4652         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4653         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4654         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4655         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4656         if (shield_mode.eq.0) then
4657         fac_shield(i)=1.0
4658         fac_shield(j)=1.0
4659 C        else
4660 C        fac_shield(i)=0.4
4661 C        fac_shield(j)=0.6
4662         endif
4663         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4664      &  *fac_shield(i)*fac_shield(j)
4665         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4666      &  *fac_shield(i)*fac_shield(j)
4667 C Derivatives in theta
4668         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4669      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4670      &   *fac_shield(i)*fac_shield(j)
4671         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4672      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4673      &   *fac_shield(i)*fac_shield(j)
4674
4675
4676 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4677 C Derivatives in shield mode
4678           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4679      &  (shield_mode.gt.0)) then
4680 C          print *,i,j
4681
4682           do ilist=1,ishield_list(i)
4683            iresshield=shield_list(ilist,i)
4684            do k=1,3
4685            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4686 C     &      *2.0
4687            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4688      &              rlocshield
4689      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4690             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4691      &      +rlocshield
4692            enddo
4693           enddo
4694           do ilist=1,ishield_list(j)
4695            iresshield=shield_list(ilist,j)
4696            do k=1,3
4697            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4698 C     &     *2.0
4699            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4700      &              rlocshield
4701      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4702            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4703      &             +rlocshield
4704
4705            enddo
4706           enddo
4707
4708           do k=1,3
4709             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4710      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4711             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4712      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4713             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4714      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4715             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4716      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4717            enddo
4718            endif
4719
4720 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4721 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4722 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4723 cd     &    ' eello_turn3_num',4*eello_turn3_num
4724 C Derivatives in gamma(i)
4725         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4726         call transpose2(auxmat2(1,1),auxmat3(1,1))
4727         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4728         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4729      &   *fac_shield(i)*fac_shield(j)
4730 C Derivatives in gamma(i+1)
4731         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4732         call transpose2(auxmat2(1,1),auxmat3(1,1))
4733         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4734         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4735      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4736      &   *fac_shield(i)*fac_shield(j)
4737 C Cartesian derivatives
4738         do l=1,3
4739 c            ghalf1=0.5d0*agg(l,1)
4740 c            ghalf2=0.5d0*agg(l,2)
4741 c            ghalf3=0.5d0*agg(l,3)
4742 c            ghalf4=0.5d0*agg(l,4)
4743           a_temp(1,1)=aggi(l,1)!+ghalf1
4744           a_temp(1,2)=aggi(l,2)!+ghalf2
4745           a_temp(2,1)=aggi(l,3)!+ghalf3
4746           a_temp(2,2)=aggi(l,4)!+ghalf4
4747           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4748           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4749      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4750      &   *fac_shield(i)*fac_shield(j)
4751
4752           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4753           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4754           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4755           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4756           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4757           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4758      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4759      &   *fac_shield(i)*fac_shield(j)
4760           a_temp(1,1)=aggj(l,1)!+ghalf1
4761           a_temp(1,2)=aggj(l,2)!+ghalf2
4762           a_temp(2,1)=aggj(l,3)!+ghalf3
4763           a_temp(2,2)=aggj(l,4)!+ghalf4
4764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4765           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4767      &   *fac_shield(i)*fac_shield(j)
4768           a_temp(1,1)=aggj1(l,1)
4769           a_temp(1,2)=aggj1(l,2)
4770           a_temp(2,1)=aggj1(l,3)
4771           a_temp(2,2)=aggj1(l,4)
4772           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4773           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4774      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4775      &   *fac_shield(i)*fac_shield(j)
4776         enddo
4777       return
4778       end
4779 C-------------------------------------------------------------------------------
4780       subroutine eturn4(i,eello_turn4)
4781 C Third- and fourth-order contributions from turns
4782       implicit real*8 (a-h,o-z)
4783       include 'DIMENSIONS'
4784       include 'COMMON.IOUNITS'
4785       include 'COMMON.GEO'
4786       include 'COMMON.VAR'
4787       include 'COMMON.LOCAL'
4788       include 'COMMON.CHAIN'
4789       include 'COMMON.DERIV'
4790       include 'COMMON.INTERACT'
4791       include 'COMMON.CONTACTS'
4792       include 'COMMON.TORSION'
4793       include 'COMMON.VECTORS'
4794       include 'COMMON.FFIELD'
4795       include 'COMMON.CONTROL'
4796       include 'COMMON.SHIELD'
4797       dimension ggg(3)
4798       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4799      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4800      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4801      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4802      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4803      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4804      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4805       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4806      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4807       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4808      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4809      &    num_conti,j1,j2
4810       j=i+3
4811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4812 C
4813 C               Fourth-order contributions
4814 C
4815 C                 (i+3)o----(i+4)
4816 C                     /  |
4817 C               (i+2)o   |
4818 C                     \  |
4819 C                 (i+1)o----i
4820 C
4821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4822 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4823 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4824 c        write(iout,*)"WCHODZE W PROGRAM"
4825         a_temp(1,1)=a22
4826         a_temp(1,2)=a23
4827         a_temp(2,1)=a32
4828         a_temp(2,2)=a33
4829         iti1=itortyp(itype(i+1))
4830         iti2=itortyp(itype(i+2))
4831         iti3=itortyp(itype(i+3))
4832 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4833         call transpose2(EUg(1,1,i+1),e1t(1,1))
4834         call transpose2(Eug(1,1,i+2),e2t(1,1))
4835         call transpose2(Eug(1,1,i+3),e3t(1,1))
4836 C Ematrix derivative in theta
4837         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4838         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4839         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4840         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4841 c       eta1 in derivative theta
4842         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4843         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4844 c       auxgvec is derivative of Ub2 so i+3 theta
4845         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4846 c       auxalary matrix of E i+1
4847         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4848 c        s1=0.0
4849 c        gs1=0.0
4850         s1=scalar2(b1(1,i+2),auxvec(1))
4851 c derivative of theta i+2 with constant i+3
4852         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4853 c derivative of theta i+2 with constant i+2
4854         gs32=scalar2(b1(1,i+2),auxgvec(1))
4855 c derivative of E matix in theta of i+1
4856         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4857
4858         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4859 c       ea31 in derivative theta
4860         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4861         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4862 c auxilary matrix auxgvec of Ub2 with constant E matirx
4863         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4864 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4865         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4866
4867 c        s2=0.0
4868 c        gs2=0.0
4869         s2=scalar2(b1(1,i+1),auxvec(1))
4870 c derivative of theta i+1 with constant i+3
4871         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4872 c derivative of theta i+2 with constant i+1
4873         gs21=scalar2(b1(1,i+1),auxgvec(1))
4874 c derivative of theta i+3 with constant i+1
4875         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4876 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4877 c     &  gtb1(1,i+1)
4878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4879 c two derivatives over diffetent matrices
4880 c gtae3e2 is derivative over i+3
4881         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4882 c ae3gte2 is derivative over i+2
4883         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4884         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4885 c three possible derivative over theta E matices
4886 c i+1
4887         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4888 c i+2
4889         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4890 c i+3
4891         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4893
4894         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4895         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4896         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4897         if (shield_mode.eq.0) then
4898         fac_shield(i)=1.0
4899         fac_shield(j)=1.0
4900 C        else
4901 C        fac_shield(i)=0.6
4902 C        fac_shield(j)=0.4
4903         endif
4904         eello_turn4=eello_turn4-(s1+s2+s3)
4905      &  *fac_shield(i)*fac_shield(j)
4906         eello_t4=-(s1+s2+s3)
4907      &  *fac_shield(i)*fac_shield(j)
4908 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4909         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4910      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4911 C Now derivative over shield:
4912           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4913      &  (shield_mode.gt.0)) then
4914 C          print *,i,j
4915
4916           do ilist=1,ishield_list(i)
4917            iresshield=shield_list(ilist,i)
4918            do k=1,3
4919            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4920 C     &      *2.0
4921            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4922      &              rlocshield
4923      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4924             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4925      &      +rlocshield
4926            enddo
4927           enddo
4928           do ilist=1,ishield_list(j)
4929            iresshield=shield_list(ilist,j)
4930            do k=1,3
4931            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4932 C     &     *2.0
4933            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4934      &              rlocshield
4935      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4936            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4937      &             +rlocshield
4938
4939            enddo
4940           enddo
4941
4942           do k=1,3
4943             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4944      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4945             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4946      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4947             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4948      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4949             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4950      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4951            enddo
4952            endif
4953
4954
4955
4956
4957
4958
4959 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4960 cd     &    ' eello_turn4_num',8*eello_turn4_num
4961 #ifdef NEWCORR
4962         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4963      &                  -(gs13+gsE13+gsEE1)*wturn4
4964      &  *fac_shield(i)*fac_shield(j)
4965         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4966      &                    -(gs23+gs21+gsEE2)*wturn4
4967      &  *fac_shield(i)*fac_shield(j)
4968
4969         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4970      &                    -(gs32+gsE31+gsEE3)*wturn4
4971      &  *fac_shield(i)*fac_shield(j)
4972
4973 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4974 c     &   gs2
4975 #endif
4976         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4977      &      'eturn4',i,j,-(s1+s2+s3)
4978 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4979 c     &    ' eello_turn4_num',8*eello_turn4_num
4980 C Derivatives in gamma(i)
4981         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4982         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4983         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4984         s1=scalar2(b1(1,i+2),auxvec(1))
4985         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4986         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4987         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4988      &  *fac_shield(i)*fac_shield(j)
4989 C Derivatives in gamma(i+1)
4990         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4991         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4992         s2=scalar2(b1(1,i+1),auxvec(1))
4993         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4994         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4995         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4996         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4997      &  *fac_shield(i)*fac_shield(j)
4998 C Derivatives in gamma(i+2)
4999         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5000         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5001         s1=scalar2(b1(1,i+2),auxvec(1))
5002         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5003         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5004         s2=scalar2(b1(1,i+1),auxvec(1))
5005         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5006         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5007         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5008         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5009      &  *fac_shield(i)*fac_shield(j)
5010 C Cartesian derivatives
5011 C Derivatives of this turn contributions in DC(i+2)
5012         if (j.lt.nres-1) then
5013           do l=1,3
5014             a_temp(1,1)=agg(l,1)
5015             a_temp(1,2)=agg(l,2)
5016             a_temp(2,1)=agg(l,3)
5017             a_temp(2,2)=agg(l,4)
5018             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5019             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5020             s1=scalar2(b1(1,i+2),auxvec(1))
5021             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5022             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5023             s2=scalar2(b1(1,i+1),auxvec(1))
5024             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5025             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5026             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5027             ggg(l)=-(s1+s2+s3)
5028             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5029      &  *fac_shield(i)*fac_shield(j)
5030           enddo
5031         endif
5032 C Remaining derivatives of this turn contribution
5033         do l=1,3
5034           a_temp(1,1)=aggi(l,1)
5035           a_temp(1,2)=aggi(l,2)
5036           a_temp(2,1)=aggi(l,3)
5037           a_temp(2,2)=aggi(l,4)
5038           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5039           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5040           s1=scalar2(b1(1,i+2),auxvec(1))
5041           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5042           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5043           s2=scalar2(b1(1,i+1),auxvec(1))
5044           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5045           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5046           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5047           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5048      &  *fac_shield(i)*fac_shield(j)
5049           a_temp(1,1)=aggi1(l,1)
5050           a_temp(1,2)=aggi1(l,2)
5051           a_temp(2,1)=aggi1(l,3)
5052           a_temp(2,2)=aggi1(l,4)
5053           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5054           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5055           s1=scalar2(b1(1,i+2),auxvec(1))
5056           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5057           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5058           s2=scalar2(b1(1,i+1),auxvec(1))
5059           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5060           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5061           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5062           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5063      &  *fac_shield(i)*fac_shield(j)
5064           a_temp(1,1)=aggj(l,1)
5065           a_temp(1,2)=aggj(l,2)
5066           a_temp(2,1)=aggj(l,3)
5067           a_temp(2,2)=aggj(l,4)
5068           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5069           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5070           s1=scalar2(b1(1,i+2),auxvec(1))
5071           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5072           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5073           s2=scalar2(b1(1,i+1),auxvec(1))
5074           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5075           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5076           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5077           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5078      &  *fac_shield(i)*fac_shield(j)
5079           a_temp(1,1)=aggj1(l,1)
5080           a_temp(1,2)=aggj1(l,2)
5081           a_temp(2,1)=aggj1(l,3)
5082           a_temp(2,2)=aggj1(l,4)
5083           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5084           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5085           s1=scalar2(b1(1,i+2),auxvec(1))
5086           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5087           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5088           s2=scalar2(b1(1,i+1),auxvec(1))
5089           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5090           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5091           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5092 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5093           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5094      &  *fac_shield(i)*fac_shield(j)
5095         enddo
5096       return
5097       end
5098 C-----------------------------------------------------------------------------
5099       subroutine vecpr(u,v,w)
5100       implicit real*8(a-h,o-z)
5101       dimension u(3),v(3),w(3)
5102       w(1)=u(2)*v(3)-u(3)*v(2)
5103       w(2)=-u(1)*v(3)+u(3)*v(1)
5104       w(3)=u(1)*v(2)-u(2)*v(1)
5105       return
5106       end
5107 C-----------------------------------------------------------------------------
5108       subroutine unormderiv(u,ugrad,unorm,ungrad)
5109 C This subroutine computes the derivatives of a normalized vector u, given
5110 C the derivatives computed without normalization conditions, ugrad. Returns
5111 C ungrad.
5112       implicit none
5113       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5114       double precision vec(3)
5115       double precision scalar
5116       integer i,j
5117 c      write (2,*) 'ugrad',ugrad
5118 c      write (2,*) 'u',u
5119       do i=1,3
5120         vec(i)=scalar(ugrad(1,i),u(1))
5121       enddo
5122 c      write (2,*) 'vec',vec
5123       do i=1,3
5124         do j=1,3
5125           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5126         enddo
5127       enddo
5128 c      write (2,*) 'ungrad',ungrad
5129       return
5130       end
5131 C-----------------------------------------------------------------------------
5132       subroutine escp_soft_sphere(evdw2,evdw2_14)
5133 C
5134 C This subroutine calculates the excluded-volume interaction energy between
5135 C peptide-group centers and side chains and its gradient in virtual-bond and
5136 C side-chain vectors.
5137 C
5138       implicit real*8 (a-h,o-z)
5139       include 'DIMENSIONS'
5140       include 'COMMON.GEO'
5141       include 'COMMON.VAR'
5142       include 'COMMON.LOCAL'
5143       include 'COMMON.CHAIN'
5144       include 'COMMON.DERIV'
5145       include 'COMMON.INTERACT'
5146       include 'COMMON.FFIELD'
5147       include 'COMMON.IOUNITS'
5148       include 'COMMON.CONTROL'
5149       dimension ggg(3)
5150       evdw2=0.0D0
5151       evdw2_14=0.0d0
5152       r0_scp=4.5d0
5153 cd    print '(a)','Enter ESCP'
5154 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5155 C      do xshift=-1,1
5156 C      do yshift=-1,1
5157 C      do zshift=-1,1
5158       do i=iatscp_s,iatscp_e
5159         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5160         iteli=itel(i)
5161         xi=0.5D0*(c(1,i)+c(1,i+1))
5162         yi=0.5D0*(c(2,i)+c(2,i+1))
5163         zi=0.5D0*(c(3,i)+c(3,i+1))
5164 C Return atom into box, boxxsize is size of box in x dimension
5165 c  134   continue
5166 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5167 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5168 C Condition for being inside the proper box
5169 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5170 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5171 c        go to 134
5172 c        endif
5173 c  135   continue
5174 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5175 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5176 C Condition for being inside the proper box
5177 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5178 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5179 c        go to 135
5180 c c       endif
5181 c  136   continue
5182 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5183 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5184 cC Condition for being inside the proper box
5185 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5186 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5187 c        go to 136
5188 c        endif
5189           xi=mod(xi,boxxsize)
5190           if (xi.lt.0) xi=xi+boxxsize
5191           yi=mod(yi,boxysize)
5192           if (yi.lt.0) yi=yi+boxysize
5193           zi=mod(zi,boxzsize)
5194           if (zi.lt.0) zi=zi+boxzsize
5195 C          xi=xi+xshift*boxxsize
5196 C          yi=yi+yshift*boxysize
5197 C          zi=zi+zshift*boxzsize
5198         do iint=1,nscp_gr(i)
5199
5200         do j=iscpstart(i,iint),iscpend(i,iint)
5201           if (itype(j).eq.ntyp1) cycle
5202           itypj=iabs(itype(j))
5203 C Uncomment following three lines for SC-p interactions
5204 c         xj=c(1,nres+j)-xi
5205 c         yj=c(2,nres+j)-yi
5206 c         zj=c(3,nres+j)-zi
5207 C Uncomment following three lines for Ca-p interactions
5208           xj=c(1,j)
5209           yj=c(2,j)
5210           zj=c(3,j)
5211 c  174   continue
5212 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5213 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5214 C Condition for being inside the proper box
5215 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5216 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5217 c        go to 174
5218 c        endif
5219 c  175   continue
5220 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5221 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5222 cC Condition for being inside the proper box
5223 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5224 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5225 c        go to 175
5226 c        endif
5227 c  176   continue
5228 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5229 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5230 C Condition for being inside the proper box
5231 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5232 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5233 c        go to 176
5234           xj=mod(xj,boxxsize)
5235           if (xj.lt.0) xj=xj+boxxsize
5236           yj=mod(yj,boxysize)
5237           if (yj.lt.0) yj=yj+boxysize
5238           zj=mod(zj,boxzsize)
5239           if (zj.lt.0) zj=zj+boxzsize
5240       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5241       xj_safe=xj
5242       yj_safe=yj
5243       zj_safe=zj
5244       subchap=0
5245       do xshift=-1,1
5246       do yshift=-1,1
5247       do zshift=-1,1
5248           xj=xj_safe+xshift*boxxsize
5249           yj=yj_safe+yshift*boxysize
5250           zj=zj_safe+zshift*boxzsize
5251           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5252           if(dist_temp.lt.dist_init) then
5253             dist_init=dist_temp
5254             xj_temp=xj
5255             yj_temp=yj
5256             zj_temp=zj
5257             subchap=1
5258           endif
5259        enddo
5260        enddo
5261        enddo
5262        if (subchap.eq.1) then
5263           xj=xj_temp-xi
5264           yj=yj_temp-yi
5265           zj=zj_temp-zi
5266        else
5267           xj=xj_safe-xi
5268           yj=yj_safe-yi
5269           zj=zj_safe-zi
5270        endif
5271 c c       endif
5272 C          xj=xj-xi
5273 C          yj=yj-yi
5274 C          zj=zj-zi
5275           rij=xj*xj+yj*yj+zj*zj
5276
5277           r0ij=r0_scp
5278           r0ijsq=r0ij*r0ij
5279           if (rij.lt.r0ijsq) then
5280             evdwij=0.25d0*(rij-r0ijsq)**2
5281             fac=rij-r0ijsq
5282           else
5283             evdwij=0.0d0
5284             fac=0.0d0
5285           endif
5286           evdw2=evdw2+evdwij
5287 C
5288 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5289 C
5290           ggg(1)=xj*fac
5291           ggg(2)=yj*fac
5292           ggg(3)=zj*fac
5293 cgrad          if (j.lt.i) then
5294 cd          write (iout,*) 'j<i'
5295 C Uncomment following three lines for SC-p interactions
5296 c           do k=1,3
5297 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5298 c           enddo
5299 cgrad          else
5300 cd          write (iout,*) 'j>i'
5301 cgrad            do k=1,3
5302 cgrad              ggg(k)=-ggg(k)
5303 C Uncomment following line for SC-p interactions
5304 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5305 cgrad            enddo
5306 cgrad          endif
5307 cgrad          do k=1,3
5308 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5309 cgrad          enddo
5310 cgrad          kstart=min0(i+1,j)
5311 cgrad          kend=max0(i-1,j-1)
5312 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5313 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5314 cgrad          do k=kstart,kend
5315 cgrad            do l=1,3
5316 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5317 cgrad            enddo
5318 cgrad          enddo
5319           do k=1,3
5320             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5321             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5322           enddo
5323         enddo
5324
5325         enddo ! iint
5326       enddo ! i
5327 C      enddo !zshift
5328 C      enddo !yshift
5329 C      enddo !xshift
5330       return
5331       end
5332 C-----------------------------------------------------------------------------
5333       subroutine escp(evdw2,evdw2_14)
5334 C
5335 C This subroutine calculates the excluded-volume interaction energy between
5336 C peptide-group centers and side chains and its gradient in virtual-bond and
5337 C side-chain vectors.
5338 C
5339       implicit real*8 (a-h,o-z)
5340       include 'DIMENSIONS'
5341       include 'COMMON.GEO'
5342       include 'COMMON.VAR'
5343       include 'COMMON.LOCAL'
5344       include 'COMMON.CHAIN'
5345       include 'COMMON.DERIV'
5346       include 'COMMON.INTERACT'
5347       include 'COMMON.FFIELD'
5348       include 'COMMON.IOUNITS'
5349       include 'COMMON.CONTROL'
5350       include 'COMMON.SPLITELE'
5351       dimension ggg(3)
5352       evdw2=0.0D0
5353       evdw2_14=0.0d0
5354 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5355 cd    print '(a)','Enter ESCP'
5356 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5357 C      do xshift=-1,1
5358 C      do yshift=-1,1
5359 C      do zshift=-1,1
5360       do i=iatscp_s,iatscp_e
5361         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5362         iteli=itel(i)
5363         xi=0.5D0*(c(1,i)+c(1,i+1))
5364         yi=0.5D0*(c(2,i)+c(2,i+1))
5365         zi=0.5D0*(c(3,i)+c(3,i+1))
5366           xi=mod(xi,boxxsize)
5367           if (xi.lt.0) xi=xi+boxxsize
5368           yi=mod(yi,boxysize)
5369           if (yi.lt.0) yi=yi+boxysize
5370           zi=mod(zi,boxzsize)
5371           if (zi.lt.0) zi=zi+boxzsize
5372 c          xi=xi+xshift*boxxsize
5373 c          yi=yi+yshift*boxysize
5374 c          zi=zi+zshift*boxzsize
5375 c        print *,xi,yi,zi,'polozenie i'
5376 C Return atom into box, boxxsize is size of box in x dimension
5377 c  134   continue
5378 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5379 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5380 C Condition for being inside the proper box
5381 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5382 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5383 c        go to 134
5384 c        endif
5385 c  135   continue
5386 c          print *,xi,boxxsize,"pierwszy"
5387
5388 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5389 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5390 C Condition for being inside the proper box
5391 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5392 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5393 c        go to 135
5394 c        endif
5395 c  136   continue
5396 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5397 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5398 C Condition for being inside the proper box
5399 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5400 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5401 c        go to 136
5402 c        endif
5403         do iint=1,nscp_gr(i)
5404
5405         do j=iscpstart(i,iint),iscpend(i,iint)
5406           itypj=iabs(itype(j))
5407           if (itypj.eq.ntyp1) cycle
5408 C Uncomment following three lines for SC-p interactions
5409 c         xj=c(1,nres+j)-xi
5410 c         yj=c(2,nres+j)-yi
5411 c         zj=c(3,nres+j)-zi
5412 C Uncomment following three lines for Ca-p interactions
5413           xj=c(1,j)
5414           yj=c(2,j)
5415           zj=c(3,j)
5416           xj=mod(xj,boxxsize)
5417           if (xj.lt.0) xj=xj+boxxsize
5418           yj=mod(yj,boxysize)
5419           if (yj.lt.0) yj=yj+boxysize
5420           zj=mod(zj,boxzsize)
5421           if (zj.lt.0) zj=zj+boxzsize
5422 c  174   continue
5423 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5424 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5425 C Condition for being inside the proper box
5426 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5427 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5428 c        go to 174
5429 c        endif
5430 c  175   continue
5431 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5432 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5433 cC Condition for being inside the proper box
5434 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5435 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5436 c        go to 175
5437 c        endif
5438 c  176   continue
5439 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5440 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5441 C Condition for being inside the proper box
5442 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5443 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5444 c        go to 176
5445 c        endif
5446 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5447       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5448       xj_safe=xj
5449       yj_safe=yj
5450       zj_safe=zj
5451       subchap=0
5452       do xshift=-1,1
5453       do yshift=-1,1
5454       do zshift=-1,1
5455           xj=xj_safe+xshift*boxxsize
5456           yj=yj_safe+yshift*boxysize
5457           zj=zj_safe+zshift*boxzsize
5458           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5459           if(dist_temp.lt.dist_init) then
5460             dist_init=dist_temp
5461             xj_temp=xj
5462             yj_temp=yj
5463             zj_temp=zj
5464             subchap=1
5465           endif
5466        enddo
5467        enddo
5468        enddo
5469        if (subchap.eq.1) then
5470           xj=xj_temp-xi
5471           yj=yj_temp-yi
5472           zj=zj_temp-zi
5473        else
5474           xj=xj_safe-xi
5475           yj=yj_safe-yi
5476           zj=zj_safe-zi
5477        endif
5478 c          print *,xj,yj,zj,'polozenie j'
5479           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5480 c          print *,rrij
5481           sss=sscale(1.0d0/(dsqrt(rrij)))
5482 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5483 c          if (sss.eq.0) print *,'czasem jest OK'
5484           if (sss.le.0.0d0) cycle
5485           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5486           fac=rrij**expon2
5487           e1=fac*fac*aad(itypj,iteli)
5488           e2=fac*bad(itypj,iteli)
5489           if (iabs(j-i) .le. 2) then
5490             e1=scal14*e1
5491             e2=scal14*e2
5492             evdw2_14=evdw2_14+(e1+e2)*sss
5493           endif
5494           evdwij=e1+e2
5495           evdw2=evdw2+evdwij*sss
5496           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5497      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5498      &       bad(itypj,iteli)
5499 C
5500 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5501 C
5502           fac=-(evdwij+e1)*rrij*sss
5503           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5504           ggg(1)=xj*fac
5505           ggg(2)=yj*fac
5506           ggg(3)=zj*fac
5507 cgrad          if (j.lt.i) then
5508 cd          write (iout,*) 'j<i'
5509 C Uncomment following three lines for SC-p interactions
5510 c           do k=1,3
5511 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5512 c           enddo
5513 cgrad          else
5514 cd          write (iout,*) 'j>i'
5515 cgrad            do k=1,3
5516 cgrad              ggg(k)=-ggg(k)
5517 C Uncomment following line for SC-p interactions
5518 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5519 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5520 cgrad            enddo
5521 cgrad          endif
5522 cgrad          do k=1,3
5523 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5524 cgrad          enddo
5525 cgrad          kstart=min0(i+1,j)
5526 cgrad          kend=max0(i-1,j-1)
5527 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5528 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5529 cgrad          do k=kstart,kend
5530 cgrad            do l=1,3
5531 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5532 cgrad            enddo
5533 cgrad          enddo
5534           do k=1,3
5535             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5536             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5537           enddo
5538 c        endif !endif for sscale cutoff
5539         enddo ! j
5540
5541         enddo ! iint
5542       enddo ! i
5543 c      enddo !zshift
5544 c      enddo !yshift
5545 c      enddo !xshift
5546       do i=1,nct
5547         do j=1,3
5548           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5549           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5550           gradx_scp(j,i)=expon*gradx_scp(j,i)
5551         enddo
5552       enddo
5553 C******************************************************************************
5554 C
5555 C                              N O T E !!!
5556 C
5557 C To save time the factor EXPON has been extracted from ALL components
5558 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5559 C use!
5560 C
5561 C******************************************************************************
5562       return
5563       end
5564 C--------------------------------------------------------------------------
5565       subroutine edis(ehpb)
5566 C
5567 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5568 C
5569       implicit real*8 (a-h,o-z)
5570       include 'DIMENSIONS'
5571       include 'COMMON.SBRIDGE'
5572       include 'COMMON.CHAIN'
5573       include 'COMMON.DERIV'
5574       include 'COMMON.VAR'
5575       include 'COMMON.INTERACT'
5576       include 'COMMON.IOUNITS'
5577       include 'COMMON.CONTROL'
5578       dimension ggg(3)
5579       ehpb=0.0D0
5580       do i=1,3
5581        ggg(i)=0.0d0
5582       enddo
5583 C      write (iout,*) ,"link_end",link_end,constr_dist
5584 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5585 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5586       if (link_end.eq.0) return
5587       do i=link_start,link_end
5588 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5589 C CA-CA distance used in regularization of structure.
5590         ii=ihpb(i)
5591         jj=jhpb(i)
5592 C iii and jjj point to the residues for which the distance is assigned.
5593         if (ii.gt.nres) then
5594           iii=ii-nres
5595           jjj=jj-nres
5596         else
5597           iii=ii
5598           jjj=jj
5599         endif
5600 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5601 c     &    dhpb(i),dhpb1(i),forcon(i)
5602 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5603 C    distance and angle dependent SS bond potential.
5604 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5605 C     & iabs(itype(jjj)).eq.1) then
5606 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5607 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5608         if (.not.dyn_ss .and. i.le.nss) then
5609 C 15/02/13 CC dynamic SSbond - additional check
5610          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5611      & iabs(itype(jjj)).eq.1) then
5612           call ssbond_ene(iii,jjj,eij)
5613           ehpb=ehpb+2*eij
5614          endif
5615 cd          write (iout,*) "eij",eij
5616 cd   &   ' waga=',waga,' fac=',fac
5617         else if (ii.gt.nres .and. jj.gt.nres) then
5618 c Restraints from contact prediction
5619           dd=dist(ii,jj)
5620           if (constr_dist.eq.11) then
5621             ehpb=ehpb+fordepth(i)**4.0d0
5622      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5623             fac=fordepth(i)**4.0d0
5624      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5625           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5626      &    ehpb,fordepth(i),dd
5627            else
5628           if (dhpb1(i).gt.0.0d0) then
5629             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5630             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5631 c            write (iout,*) "beta nmr",
5632 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5633           else
5634             dd=dist(ii,jj)
5635             rdis=dd-dhpb(i)
5636 C Get the force constant corresponding to this distance.
5637             waga=forcon(i)
5638 C Calculate the contribution to energy.
5639             ehpb=ehpb+waga*rdis*rdis
5640 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5641 C
5642 C Evaluate gradient.
5643 C
5644             fac=waga*rdis/dd
5645           endif
5646           endif
5647           do j=1,3
5648             ggg(j)=fac*(c(j,jj)-c(j,ii))
5649           enddo
5650           do j=1,3
5651             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5652             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5653           enddo
5654           do k=1,3
5655             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5656             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5657           enddo
5658         else
5659 C Calculate the distance between the two points and its difference from the
5660 C target distance.
5661           dd=dist(ii,jj)
5662           if (constr_dist.eq.11) then
5663             ehpb=ehpb+fordepth(i)**4.0d0
5664      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5665             fac=fordepth(i)**4.0d0
5666      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5667           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5668      &    ehpb,fordepth(i),dd
5669            else
5670           if (dhpb1(i).gt.0.0d0) then
5671             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5672             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5673 c            write (iout,*) "alph nmr",
5674 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5675           else
5676             rdis=dd-dhpb(i)
5677 C Get the force constant corresponding to this distance.
5678             waga=forcon(i)
5679 C Calculate the contribution to energy.
5680             ehpb=ehpb+waga*rdis*rdis
5681 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5682 C
5683 C Evaluate gradient.
5684 C
5685             fac=waga*rdis/dd
5686           endif
5687           endif
5688             do j=1,3
5689               ggg(j)=fac*(c(j,jj)-c(j,ii))
5690             enddo
5691 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5692 C If this is a SC-SC distance, we need to calculate the contributions to the
5693 C Cartesian gradient in the SC vectors (ghpbx).
5694           if (iii.lt.ii) then
5695           do j=1,3
5696             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5697             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5698           enddo
5699           endif
5700 cgrad        do j=iii,jjj-1
5701 cgrad          do k=1,3
5702 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5703 cgrad          enddo
5704 cgrad        enddo
5705           do k=1,3
5706             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5707             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5708           enddo
5709         endif
5710       enddo
5711       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5712       return
5713       end
5714 C--------------------------------------------------------------------------
5715       subroutine ssbond_ene(i,j,eij)
5716 C
5717 C Calculate the distance and angle dependent SS-bond potential energy
5718 C using a free-energy function derived based on RHF/6-31G** ab initio
5719 C calculations of diethyl disulfide.
5720 C
5721 C A. Liwo and U. Kozlowska, 11/24/03
5722 C
5723       implicit real*8 (a-h,o-z)
5724       include 'DIMENSIONS'
5725       include 'COMMON.SBRIDGE'
5726       include 'COMMON.CHAIN'
5727       include 'COMMON.DERIV'
5728       include 'COMMON.LOCAL'
5729       include 'COMMON.INTERACT'
5730       include 'COMMON.VAR'
5731       include 'COMMON.IOUNITS'
5732       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5733       itypi=iabs(itype(i))
5734       xi=c(1,nres+i)
5735       yi=c(2,nres+i)
5736       zi=c(3,nres+i)
5737       dxi=dc_norm(1,nres+i)
5738       dyi=dc_norm(2,nres+i)
5739       dzi=dc_norm(3,nres+i)
5740 c      dsci_inv=dsc_inv(itypi)
5741       dsci_inv=vbld_inv(nres+i)
5742       itypj=iabs(itype(j))
5743 c      dscj_inv=dsc_inv(itypj)
5744       dscj_inv=vbld_inv(nres+j)
5745       xj=c(1,nres+j)-xi
5746       yj=c(2,nres+j)-yi
5747       zj=c(3,nres+j)-zi
5748       dxj=dc_norm(1,nres+j)
5749       dyj=dc_norm(2,nres+j)
5750       dzj=dc_norm(3,nres+j)
5751       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5752       rij=dsqrt(rrij)
5753       erij(1)=xj*rij
5754       erij(2)=yj*rij
5755       erij(3)=zj*rij
5756       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5757       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5758       om12=dxi*dxj+dyi*dyj+dzi*dzj
5759       do k=1,3
5760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5762       enddo
5763       rij=1.0d0/rij
5764       deltad=rij-d0cm
5765       deltat1=1.0d0-om1
5766       deltat2=1.0d0+om2
5767       deltat12=om2-om1+2.0d0
5768       cosphi=om12-om1*om2
5769       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5770      &  +akct*deltad*deltat12
5771      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5772 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5773 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5774 c     &  " deltat12",deltat12," eij",eij
5775       ed=2*akcm*deltad+akct*deltat12
5776       pom1=akct*deltad
5777       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5778       eom1=-2*akth*deltat1-pom1-om2*pom2
5779       eom2= 2*akth*deltat2+pom1-om1*pom2
5780       eom12=pom2
5781       do k=1,3
5782         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5783         ghpbx(k,i)=ghpbx(k,i)-ggk
5784      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5785      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5786         ghpbx(k,j)=ghpbx(k,j)+ggk
5787      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5788      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5789         ghpbc(k,i)=ghpbc(k,i)-ggk
5790         ghpbc(k,j)=ghpbc(k,j)+ggk
5791       enddo
5792 C
5793 C Calculate the components of the gradient in DC and X
5794 C
5795 cgrad      do k=i,j-1
5796 cgrad        do l=1,3
5797 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5798 cgrad        enddo
5799 cgrad      enddo
5800       return
5801       end
5802 C--------------------------------------------------------------------------
5803       subroutine ebond(estr)
5804 c
5805 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5806 c
5807       implicit real*8 (a-h,o-z)
5808       include 'DIMENSIONS'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.GEO'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.VAR'
5814       include 'COMMON.CHAIN'
5815       include 'COMMON.IOUNITS'
5816       include 'COMMON.NAMES'
5817       include 'COMMON.FFIELD'
5818       include 'COMMON.CONTROL'
5819       include 'COMMON.SETUP'
5820       double precision u(3),ud(3)
5821       estr=0.0d0
5822       estr1=0.0d0
5823       do i=ibondp_start,ibondp_end
5824         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5825 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5826 c          do j=1,3
5827 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5828 c     &      *dc(j,i-1)/vbld(i)
5829 c          enddo
5830 c          if (energy_dec) write(iout,*)
5831 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5832 c        else
5833 C       Checking if it involves dummy (NH3+ or COO-) group
5834          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5835 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5836         diff = vbld(i)-vbldpDUM
5837          else
5838 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5839         diff = vbld(i)-vbldp0
5840          endif
5841         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5842      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5843         estr=estr+diff*diff
5844         do j=1,3
5845           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5846         enddo
5847 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5848 c        endif
5849       enddo
5850       estr=0.5d0*AKP*estr+estr1
5851 c
5852 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5853 c
5854       do i=ibond_start,ibond_end
5855         iti=iabs(itype(i))
5856         if (iti.ne.10 .and. iti.ne.ntyp1) then
5857           nbi=nbondterm(iti)
5858           if (nbi.eq.1) then
5859             diff=vbld(i+nres)-vbldsc0(1,iti)
5860             if (energy_dec)  write (iout,*)
5861      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5862      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5863             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5864             do j=1,3
5865               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5866             enddo
5867           else
5868             do j=1,nbi
5869               diff=vbld(i+nres)-vbldsc0(j,iti)
5870               ud(j)=aksc(j,iti)*diff
5871               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5872             enddo
5873             uprod=u(1)
5874             do j=2,nbi
5875               uprod=uprod*u(j)
5876             enddo
5877             usum=0.0d0
5878             usumsqder=0.0d0
5879             do j=1,nbi
5880               uprod1=1.0d0
5881               uprod2=1.0d0
5882               do k=1,nbi
5883                 if (k.ne.j) then
5884                   uprod1=uprod1*u(k)
5885                   uprod2=uprod2*u(k)*u(k)
5886                 endif
5887               enddo
5888               usum=usum+uprod1
5889               usumsqder=usumsqder+ud(j)*uprod2
5890             enddo
5891             estr=estr+uprod/usum
5892             do j=1,3
5893              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5894             enddo
5895           endif
5896         endif
5897       enddo
5898       return
5899       end
5900 #ifdef CRYST_THETA
5901 C--------------------------------------------------------------------------
5902       subroutine ebend(etheta,ethetacnstr)
5903 C
5904 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5905 C angles gamma and its derivatives in consecutive thetas and gammas.
5906 C
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.LOCAL'
5910       include 'COMMON.GEO'
5911       include 'COMMON.INTERACT'
5912       include 'COMMON.DERIV'
5913       include 'COMMON.VAR'
5914       include 'COMMON.CHAIN'
5915       include 'COMMON.IOUNITS'
5916       include 'COMMON.NAMES'
5917       include 'COMMON.FFIELD'
5918       include 'COMMON.CONTROL'
5919       include 'COMMON.TORCNSTR'
5920       common /calcthet/ term1,term2,termm,diffak,ratak,
5921      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5922      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5923       double precision y(2),z(2)
5924       delta=0.02d0*pi
5925 c      time11=dexp(-2*time)
5926 c      time12=1.0d0
5927       etheta=0.0D0
5928 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5929       do i=ithet_start,ithet_end
5930         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5931      &  .or.itype(i).eq.ntyp1) cycle
5932 C Zero the energy function and its derivative at 0 or pi.
5933         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5934         it=itype(i-1)
5935         ichir1=isign(1,itype(i-2))
5936         ichir2=isign(1,itype(i))
5937          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5938          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5939          if (itype(i-1).eq.10) then
5940           itype1=isign(10,itype(i-2))
5941           ichir11=isign(1,itype(i-2))
5942           ichir12=isign(1,itype(i-2))
5943           itype2=isign(10,itype(i))
5944           ichir21=isign(1,itype(i))
5945           ichir22=isign(1,itype(i))
5946          endif
5947
5948         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5949 #ifdef OSF
5950           phii=phi(i)
5951           if (phii.ne.phii) phii=150.0
5952 #else
5953           phii=phi(i)
5954 #endif
5955           y(1)=dcos(phii)
5956           y(2)=dsin(phii)
5957         else
5958           y(1)=0.0D0
5959           y(2)=0.0D0
5960         endif
5961         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5962 #ifdef OSF
5963           phii1=phi(i+1)
5964           if (phii1.ne.phii1) phii1=150.0
5965           phii1=pinorm(phii1)
5966           z(1)=cos(phii1)
5967 #else
5968           phii1=phi(i+1)
5969 #endif
5970           z(1)=dcos(phii1)
5971           z(2)=dsin(phii1)
5972         else
5973           z(1)=0.0D0
5974           z(2)=0.0D0
5975         endif
5976 C Calculate the "mean" value of theta from the part of the distribution
5977 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5978 C In following comments this theta will be referred to as t_c.
5979         thet_pred_mean=0.0d0
5980         do k=1,2
5981             athetk=athet(k,it,ichir1,ichir2)
5982             bthetk=bthet(k,it,ichir1,ichir2)
5983           if (it.eq.10) then
5984              athetk=athet(k,itype1,ichir11,ichir12)
5985              bthetk=bthet(k,itype2,ichir21,ichir22)
5986           endif
5987          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5988 c         write(iout,*) 'chuj tu', y(k),z(k)
5989         enddo
5990         dthett=thet_pred_mean*ssd
5991         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5992 C Derivatives of the "mean" values in gamma1 and gamma2.
5993         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5994      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5995          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5996      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5997          if (it.eq.10) then
5998       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5999      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6000         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6001      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6002          endif
6003         if (theta(i).gt.pi-delta) then
6004           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6005      &         E_tc0)
6006           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6007           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6008           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6009      &        E_theta)
6010           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6011      &        E_tc)
6012         else if (theta(i).lt.delta) then
6013           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6014           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6015           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6016      &        E_theta)
6017           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6018           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6019      &        E_tc)
6020         else
6021           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6022      &        E_theta,E_tc)
6023         endif
6024         etheta=etheta+ethetai
6025         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6026      &      'ebend',i,ethetai,theta(i),itype(i)
6027         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6028         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6029         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6030       enddo
6031       ethetacnstr=0.0d0
6032 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6033       do i=ithetaconstr_start,ithetaconstr_end
6034         itheta=itheta_constr(i)
6035         thetiii=theta(itheta)
6036         difi=pinorm(thetiii-theta_constr0(i))
6037         if (difi.gt.theta_drange(i)) then
6038           difi=difi-theta_drange(i)
6039           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6040           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6041      &    +for_thet_constr(i)*difi**3
6042         else if (difi.lt.-drange(i)) then
6043           difi=difi+drange(i)
6044           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6045           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6046      &    +for_thet_constr(i)*difi**3
6047         else
6048           difi=0.0
6049         endif
6050        if (energy_dec) then
6051         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6052      &    i,itheta,rad2deg*thetiii,
6053      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6054      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6055      &    gloc(itheta+nphi-2,icg)
6056         endif
6057       enddo
6058
6059 C Ufff.... We've done all this!!!
6060       return
6061       end
6062 C---------------------------------------------------------------------------
6063       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6064      &     E_tc)
6065       implicit real*8 (a-h,o-z)
6066       include 'DIMENSIONS'
6067       include 'COMMON.LOCAL'
6068       include 'COMMON.IOUNITS'
6069       common /calcthet/ term1,term2,termm,diffak,ratak,
6070      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6071      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6072 C Calculate the contributions to both Gaussian lobes.
6073 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6074 C The "polynomial part" of the "standard deviation" of this part of
6075 C the distributioni.
6076 ccc        write (iout,*) thetai,thet_pred_mean
6077         sig=polthet(3,it)
6078         do j=2,0,-1
6079           sig=sig*thet_pred_mean+polthet(j,it)
6080         enddo
6081 C Derivative of the "interior part" of the "standard deviation of the"
6082 C gamma-dependent Gaussian lobe in t_c.
6083         sigtc=3*polthet(3,it)
6084         do j=2,1,-1
6085           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6086         enddo
6087         sigtc=sig*sigtc
6088 C Set the parameters of both Gaussian lobes of the distribution.
6089 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6090         fac=sig*sig+sigc0(it)
6091         sigcsq=fac+fac
6092         sigc=1.0D0/sigcsq
6093 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6094         sigsqtc=-4.0D0*sigcsq*sigtc
6095 c       print *,i,sig,sigtc,sigsqtc
6096 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6097         sigtc=-sigtc/(fac*fac)
6098 C Following variable is sigma(t_c)**(-2)
6099         sigcsq=sigcsq*sigcsq
6100         sig0i=sig0(it)
6101         sig0inv=1.0D0/sig0i**2
6102         delthec=thetai-thet_pred_mean
6103         delthe0=thetai-theta0i
6104         term1=-0.5D0*sigcsq*delthec*delthec
6105         term2=-0.5D0*sig0inv*delthe0*delthe0
6106 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6107 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6108 C NaNs in taking the logarithm. We extract the largest exponent which is added
6109 C to the energy (this being the log of the distribution) at the end of energy
6110 C term evaluation for this virtual-bond angle.
6111         if (term1.gt.term2) then
6112           termm=term1
6113           term2=dexp(term2-termm)
6114           term1=1.0d0
6115         else
6116           termm=term2
6117           term1=dexp(term1-termm)
6118           term2=1.0d0
6119         endif
6120 C The ratio between the gamma-independent and gamma-dependent lobes of
6121 C the distribution is a Gaussian function of thet_pred_mean too.
6122         diffak=gthet(2,it)-thet_pred_mean
6123         ratak=diffak/gthet(3,it)**2
6124         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6125 C Let's differentiate it in thet_pred_mean NOW.
6126         aktc=ak*ratak
6127 C Now put together the distribution terms to make complete distribution.
6128         termexp=term1+ak*term2
6129         termpre=sigc+ak*sig0i
6130 C Contribution of the bending energy from this theta is just the -log of
6131 C the sum of the contributions from the two lobes and the pre-exponential
6132 C factor. Simple enough, isn't it?
6133         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6134 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6135 C NOW the derivatives!!!
6136 C 6/6/97 Take into account the deformation.
6137         E_theta=(delthec*sigcsq*term1
6138      &       +ak*delthe0*sig0inv*term2)/termexp
6139         E_tc=((sigtc+aktc*sig0i)/termpre
6140      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6141      &       aktc*term2)/termexp)
6142       return
6143       end
6144 c-----------------------------------------------------------------------------
6145       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6146       implicit real*8 (a-h,o-z)
6147       include 'DIMENSIONS'
6148       include 'COMMON.LOCAL'
6149       include 'COMMON.IOUNITS'
6150       common /calcthet/ term1,term2,termm,diffak,ratak,
6151      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6152      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6153       delthec=thetai-thet_pred_mean
6154       delthe0=thetai-theta0i
6155 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6156       t3 = thetai-thet_pred_mean
6157       t6 = t3**2
6158       t9 = term1
6159       t12 = t3*sigcsq
6160       t14 = t12+t6*sigsqtc
6161       t16 = 1.0d0
6162       t21 = thetai-theta0i
6163       t23 = t21**2
6164       t26 = term2
6165       t27 = t21*t26
6166       t32 = termexp
6167       t40 = t32**2
6168       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6169      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6170      & *(-t12*t9-ak*sig0inv*t27)
6171       return
6172       end
6173 #else
6174 C--------------------------------------------------------------------------
6175       subroutine ebend(etheta,ethetacnstr)
6176 C
6177 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6178 C angles gamma and its derivatives in consecutive thetas and gammas.
6179 C ab initio-derived potentials from
6180 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6181 C
6182       implicit real*8 (a-h,o-z)
6183       include 'DIMENSIONS'
6184       include 'COMMON.LOCAL'
6185       include 'COMMON.GEO'
6186       include 'COMMON.INTERACT'
6187       include 'COMMON.DERIV'
6188       include 'COMMON.VAR'
6189       include 'COMMON.CHAIN'
6190       include 'COMMON.IOUNITS'
6191       include 'COMMON.NAMES'
6192       include 'COMMON.FFIELD'
6193       include 'COMMON.CONTROL'
6194       include 'COMMON.TORCNSTR'
6195       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6196      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6197      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6198      & sinph1ph2(maxdouble,maxdouble)
6199       logical lprn /.false./, lprn1 /.false./
6200       etheta=0.0D0
6201       do i=ithet_start,ithet_end
6202 c        print *,i,itype(i-1),itype(i),itype(i-2)
6203         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6204      &  .or.itype(i).eq.ntyp1) cycle
6205 C        print *,i,theta(i)
6206         if (iabs(itype(i+1)).eq.20) iblock=2
6207         if (iabs(itype(i+1)).ne.20) iblock=1
6208         dethetai=0.0d0
6209         dephii=0.0d0
6210         dephii1=0.0d0
6211         theti2=0.5d0*theta(i)
6212         ityp2=ithetyp((itype(i-1)))
6213         do k=1,nntheterm
6214           coskt(k)=dcos(k*theti2)
6215           sinkt(k)=dsin(k*theti2)
6216         enddo
6217 C        print *,ethetai
6218         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6219 #ifdef OSF
6220           phii=phi(i)
6221           if (phii.ne.phii) phii=150.0
6222 #else
6223           phii=phi(i)
6224 #endif
6225           ityp1=ithetyp((itype(i-2)))
6226 C propagation of chirality for glycine type
6227           do k=1,nsingle
6228             cosph1(k)=dcos(k*phii)
6229             sinph1(k)=dsin(k*phii)
6230           enddo
6231         else
6232           phii=0.0d0
6233           do k=1,nsingle
6234           ityp1=ithetyp((itype(i-2)))
6235             cosph1(k)=0.0d0
6236             sinph1(k)=0.0d0
6237           enddo
6238         endif
6239         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6240 #ifdef OSF
6241           phii1=phi(i+1)
6242           if (phii1.ne.phii1) phii1=150.0
6243           phii1=pinorm(phii1)
6244 #else
6245           phii1=phi(i+1)
6246 #endif
6247           ityp3=ithetyp((itype(i)))
6248           do k=1,nsingle
6249             cosph2(k)=dcos(k*phii1)
6250             sinph2(k)=dsin(k*phii1)
6251           enddo
6252         else
6253           phii1=0.0d0
6254           ityp3=ithetyp((itype(i)))
6255           do k=1,nsingle
6256             cosph2(k)=0.0d0
6257             sinph2(k)=0.0d0
6258           enddo
6259         endif
6260         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6261         do k=1,ndouble
6262           do l=1,k-1
6263             ccl=cosph1(l)*cosph2(k-l)
6264             ssl=sinph1(l)*sinph2(k-l)
6265             scl=sinph1(l)*cosph2(k-l)
6266             csl=cosph1(l)*sinph2(k-l)
6267             cosph1ph2(l,k)=ccl-ssl
6268             cosph1ph2(k,l)=ccl+ssl
6269             sinph1ph2(l,k)=scl+csl
6270             sinph1ph2(k,l)=scl-csl
6271           enddo
6272         enddo
6273         if (lprn) then
6274         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6275      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6276         write (iout,*) "coskt and sinkt"
6277         do k=1,nntheterm
6278           write (iout,*) k,coskt(k),sinkt(k)
6279         enddo
6280         endif
6281         do k=1,ntheterm
6282           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6283           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6284      &      *coskt(k)
6285           if (lprn)
6286      &    write (iout,*) "k",k,"
6287      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6288      &     " ethetai",ethetai
6289         enddo
6290         if (lprn) then
6291         write (iout,*) "cosph and sinph"
6292         do k=1,nsingle
6293           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6294         enddo
6295         write (iout,*) "cosph1ph2 and sinph2ph2"
6296         do k=2,ndouble
6297           do l=1,k-1
6298             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6299      &         sinph1ph2(l,k),sinph1ph2(k,l)
6300           enddo
6301         enddo
6302         write(iout,*) "ethetai",ethetai
6303         endif
6304 C       print *,ethetai
6305         do m=1,ntheterm2
6306           do k=1,nsingle
6307             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6308      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6309      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6310      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6311             ethetai=ethetai+sinkt(m)*aux
6312             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6313             dephii=dephii+k*sinkt(m)*(
6314      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6315      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6316             dephii1=dephii1+k*sinkt(m)*(
6317      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6318      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6319             if (lprn)
6320      &      write (iout,*) "m",m," k",k," bbthet",
6321      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6322      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6323      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6324      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6325 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6326           enddo
6327         enddo
6328 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6329 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6330 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6331 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6332         if (lprn)
6333      &  write(iout,*) "ethetai",ethetai
6334 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6335         do m=1,ntheterm3
6336           do k=2,ndouble
6337             do l=1,k-1
6338               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6339      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6340      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6341      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6342               ethetai=ethetai+sinkt(m)*aux
6343               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6344               dephii=dephii+l*sinkt(m)*(
6345      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6346      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6347      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6348      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6349               dephii1=dephii1+(k-l)*sinkt(m)*(
6350      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6351      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6352      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6353      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6354               if (lprn) then
6355               write (iout,*) "m",m," k",k," l",l," ffthet",
6356      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6357      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6358      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6359      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6360      &            " ethetai",ethetai
6361               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6362      &            cosph1ph2(k,l)*sinkt(m),
6363      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6364               endif
6365             enddo
6366           enddo
6367         enddo
6368 10      continue
6369 c        lprn1=.true.
6370 C        print *,ethetai
6371         if (lprn1)
6372      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6373      &   i,theta(i)*rad2deg,phii*rad2deg,
6374      &   phii1*rad2deg,ethetai
6375 c        lprn1=.false.
6376         etheta=etheta+ethetai
6377         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6378         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6379         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6380       enddo
6381 C now constrains
6382       ethetacnstr=0.0d0
6383 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6384       do i=ithetaconstr_start,ithetaconstr_end
6385         itheta=itheta_constr(i)
6386         thetiii=theta(itheta)
6387         difi=pinorm(thetiii-theta_constr0(i))
6388         if (difi.gt.theta_drange(i)) then
6389           difi=difi-theta_drange(i)
6390           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6391           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6392      &    +for_thet_constr(i)*difi**3
6393         else if (difi.lt.-drange(i)) then
6394           difi=difi+drange(i)
6395           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6396           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6397      &    +for_thet_constr(i)*difi**3
6398         else
6399           difi=0.0
6400         endif
6401        if (energy_dec) then
6402         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6403      &    i,itheta,rad2deg*thetiii,
6404      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6405      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6406      &    gloc(itheta+nphi-2,icg)
6407         endif
6408       enddo
6409
6410       return
6411       end
6412 #endif
6413 #ifdef CRYST_SC
6414 c-----------------------------------------------------------------------------
6415       subroutine esc(escloc)
6416 C Calculate the local energy of a side chain and its derivatives in the
6417 C corresponding virtual-bond valence angles THETA and the spherical angles
6418 C ALPHA and OMEGA.
6419       implicit real*8 (a-h,o-z)
6420       include 'DIMENSIONS'
6421       include 'COMMON.GEO'
6422       include 'COMMON.LOCAL'
6423       include 'COMMON.VAR'
6424       include 'COMMON.INTERACT'
6425       include 'COMMON.DERIV'
6426       include 'COMMON.CHAIN'
6427       include 'COMMON.IOUNITS'
6428       include 'COMMON.NAMES'
6429       include 'COMMON.FFIELD'
6430       include 'COMMON.CONTROL'
6431       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6432      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6433       common /sccalc/ time11,time12,time112,theti,it,nlobit
6434       delta=0.02d0*pi
6435       escloc=0.0D0
6436 c     write (iout,'(a)') 'ESC'
6437       do i=loc_start,loc_end
6438         it=itype(i)
6439         if (it.eq.ntyp1) cycle
6440         if (it.eq.10) goto 1
6441         nlobit=nlob(iabs(it))
6442 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6443 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6444         theti=theta(i+1)-pipol
6445         x(1)=dtan(theti)
6446         x(2)=alph(i)
6447         x(3)=omeg(i)
6448
6449         if (x(2).gt.pi-delta) then
6450           xtemp(1)=x(1)
6451           xtemp(2)=pi-delta
6452           xtemp(3)=x(3)
6453           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6454           xtemp(2)=pi
6455           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6456           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6457      &        escloci,dersc(2))
6458           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6459      &        ddersc0(1),dersc(1))
6460           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6461      &        ddersc0(3),dersc(3))
6462           xtemp(2)=pi-delta
6463           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6464           xtemp(2)=pi
6465           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6466           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6467      &            dersc0(2),esclocbi,dersc02)
6468           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6469      &            dersc12,dersc01)
6470           call splinthet(x(2),0.5d0*delta,ss,ssd)
6471           dersc0(1)=dersc01
6472           dersc0(2)=dersc02
6473           dersc0(3)=0.0d0
6474           do k=1,3
6475             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6476           enddo
6477           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6478 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6479 c    &             esclocbi,ss,ssd
6480           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6481 c         escloci=esclocbi
6482 c         write (iout,*) escloci
6483         else if (x(2).lt.delta) then
6484           xtemp(1)=x(1)
6485           xtemp(2)=delta
6486           xtemp(3)=x(3)
6487           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6488           xtemp(2)=0.0d0
6489           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6490           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6491      &        escloci,dersc(2))
6492           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6493      &        ddersc0(1),dersc(1))
6494           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6495      &        ddersc0(3),dersc(3))
6496           xtemp(2)=delta
6497           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6498           xtemp(2)=0.0d0
6499           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6500           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6501      &            dersc0(2),esclocbi,dersc02)
6502           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6503      &            dersc12,dersc01)
6504           dersc0(1)=dersc01
6505           dersc0(2)=dersc02
6506           dersc0(3)=0.0d0
6507           call splinthet(x(2),0.5d0*delta,ss,ssd)
6508           do k=1,3
6509             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6510           enddo
6511           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6512 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6513 c    &             esclocbi,ss,ssd
6514           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6515 c         write (iout,*) escloci
6516         else
6517           call enesc(x,escloci,dersc,ddummy,.false.)
6518         endif
6519
6520         escloc=escloc+escloci
6521         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6522      &     'escloc',i,escloci
6523 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6524
6525         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6526      &   wscloc*dersc(1)
6527         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6528         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6529     1   continue
6530       enddo
6531       return
6532       end
6533 C---------------------------------------------------------------------------
6534       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6535       implicit real*8 (a-h,o-z)
6536       include 'DIMENSIONS'
6537       include 'COMMON.GEO'
6538       include 'COMMON.LOCAL'
6539       include 'COMMON.IOUNITS'
6540       common /sccalc/ time11,time12,time112,theti,it,nlobit
6541       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6542       double precision contr(maxlob,-1:1)
6543       logical mixed
6544 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6545         escloc_i=0.0D0
6546         do j=1,3
6547           dersc(j)=0.0D0
6548           if (mixed) ddersc(j)=0.0d0
6549         enddo
6550         x3=x(3)
6551
6552 C Because of periodicity of the dependence of the SC energy in omega we have
6553 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6554 C To avoid underflows, first compute & store the exponents.
6555
6556         do iii=-1,1
6557
6558           x(3)=x3+iii*dwapi
6559
6560           do j=1,nlobit
6561             do k=1,3
6562               z(k)=x(k)-censc(k,j,it)
6563             enddo
6564             do k=1,3
6565               Axk=0.0D0
6566               do l=1,3
6567                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6568               enddo
6569               Ax(k,j,iii)=Axk
6570             enddo
6571             expfac=0.0D0
6572             do k=1,3
6573               expfac=expfac+Ax(k,j,iii)*z(k)
6574             enddo
6575             contr(j,iii)=expfac
6576           enddo ! j
6577
6578         enddo ! iii
6579
6580         x(3)=x3
6581 C As in the case of ebend, we want to avoid underflows in exponentiation and
6582 C subsequent NaNs and INFs in energy calculation.
6583 C Find the largest exponent
6584         emin=contr(1,-1)
6585         do iii=-1,1
6586           do j=1,nlobit
6587             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6588           enddo
6589         enddo
6590         emin=0.5D0*emin
6591 cd      print *,'it=',it,' emin=',emin
6592
6593 C Compute the contribution to SC energy and derivatives
6594         do iii=-1,1
6595
6596           do j=1,nlobit
6597 #ifdef OSF
6598             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6599             if(adexp.ne.adexp) adexp=1.0
6600             expfac=dexp(adexp)
6601 #else
6602             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6603 #endif
6604 cd          print *,'j=',j,' expfac=',expfac
6605             escloc_i=escloc_i+expfac
6606             do k=1,3
6607               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6608             enddo
6609             if (mixed) then
6610               do k=1,3,2
6611                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6612      &            +gaussc(k,2,j,it))*expfac
6613               enddo
6614             endif
6615           enddo
6616
6617         enddo ! iii
6618
6619         dersc(1)=dersc(1)/cos(theti)**2
6620         ddersc(1)=ddersc(1)/cos(theti)**2
6621         ddersc(3)=ddersc(3)
6622
6623         escloci=-(dlog(escloc_i)-emin)
6624         do j=1,3
6625           dersc(j)=dersc(j)/escloc_i
6626         enddo
6627         if (mixed) then
6628           do j=1,3,2
6629             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6630           enddo
6631         endif
6632       return
6633       end
6634 C------------------------------------------------------------------------------
6635       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6636       implicit real*8 (a-h,o-z)
6637       include 'DIMENSIONS'
6638       include 'COMMON.GEO'
6639       include 'COMMON.LOCAL'
6640       include 'COMMON.IOUNITS'
6641       common /sccalc/ time11,time12,time112,theti,it,nlobit
6642       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6643       double precision contr(maxlob)
6644       logical mixed
6645
6646       escloc_i=0.0D0
6647
6648       do j=1,3
6649         dersc(j)=0.0D0
6650       enddo
6651
6652       do j=1,nlobit
6653         do k=1,2
6654           z(k)=x(k)-censc(k,j,it)
6655         enddo
6656         z(3)=dwapi
6657         do k=1,3
6658           Axk=0.0D0
6659           do l=1,3
6660             Axk=Axk+gaussc(l,k,j,it)*z(l)
6661           enddo
6662           Ax(k,j)=Axk
6663         enddo
6664         expfac=0.0D0
6665         do k=1,3
6666           expfac=expfac+Ax(k,j)*z(k)
6667         enddo
6668         contr(j)=expfac
6669       enddo ! j
6670
6671 C As in the case of ebend, we want to avoid underflows in exponentiation and
6672 C subsequent NaNs and INFs in energy calculation.
6673 C Find the largest exponent
6674       emin=contr(1)
6675       do j=1,nlobit
6676         if (emin.gt.contr(j)) emin=contr(j)
6677       enddo
6678       emin=0.5D0*emin
6679
6680 C Compute the contribution to SC energy and derivatives
6681
6682       dersc12=0.0d0
6683       do j=1,nlobit
6684         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6685         escloc_i=escloc_i+expfac
6686         do k=1,2
6687           dersc(k)=dersc(k)+Ax(k,j)*expfac
6688         enddo
6689         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6690      &            +gaussc(1,2,j,it))*expfac
6691         dersc(3)=0.0d0
6692       enddo
6693
6694       dersc(1)=dersc(1)/cos(theti)**2
6695       dersc12=dersc12/cos(theti)**2
6696       escloci=-(dlog(escloc_i)-emin)
6697       do j=1,2
6698         dersc(j)=dersc(j)/escloc_i
6699       enddo
6700       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6701       return
6702       end
6703 #else
6704 c----------------------------------------------------------------------------------
6705       subroutine esc(escloc)
6706 C Calculate the local energy of a side chain and its derivatives in the
6707 C corresponding virtual-bond valence angles THETA and the spherical angles
6708 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6709 C added by Urszula Kozlowska. 07/11/2007
6710 C
6711       implicit real*8 (a-h,o-z)
6712       include 'DIMENSIONS'
6713       include 'COMMON.GEO'
6714       include 'COMMON.LOCAL'
6715       include 'COMMON.VAR'
6716       include 'COMMON.SCROT'
6717       include 'COMMON.INTERACT'
6718       include 'COMMON.DERIV'
6719       include 'COMMON.CHAIN'
6720       include 'COMMON.IOUNITS'
6721       include 'COMMON.NAMES'
6722       include 'COMMON.FFIELD'
6723       include 'COMMON.CONTROL'
6724       include 'COMMON.VECTORS'
6725       double precision x_prime(3),y_prime(3),z_prime(3)
6726      &    , sumene,dsc_i,dp2_i,x(65),
6727      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6728      &    de_dxx,de_dyy,de_dzz,de_dt
6729       double precision s1_t,s1_6_t,s2_t,s2_6_t
6730       double precision
6731      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6732      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6733      & dt_dCi(3),dt_dCi1(3)
6734       common /sccalc/ time11,time12,time112,theti,it,nlobit
6735       delta=0.02d0*pi
6736       escloc=0.0D0
6737       do i=loc_start,loc_end
6738         if (itype(i).eq.ntyp1) cycle
6739         costtab(i+1) =dcos(theta(i+1))
6740         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6741         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6742         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6743         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6744         cosfac=dsqrt(cosfac2)
6745         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6746         sinfac=dsqrt(sinfac2)
6747         it=iabs(itype(i))
6748         if (it.eq.10) goto 1
6749 c
6750 C  Compute the axes of tghe local cartesian coordinates system; store in
6751 c   x_prime, y_prime and z_prime
6752 c
6753         do j=1,3
6754           x_prime(j) = 0.00
6755           y_prime(j) = 0.00
6756           z_prime(j) = 0.00
6757         enddo
6758 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6759 C     &   dc_norm(3,i+nres)
6760         do j = 1,3
6761           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6762           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6763         enddo
6764         do j = 1,3
6765           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6766         enddo
6767 c       write (2,*) "i",i
6768 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6769 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6770 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6771 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6772 c      & " xy",scalar(x_prime(1),y_prime(1)),
6773 c      & " xz",scalar(x_prime(1),z_prime(1)),
6774 c      & " yy",scalar(y_prime(1),y_prime(1)),
6775 c      & " yz",scalar(y_prime(1),z_prime(1)),
6776 c      & " zz",scalar(z_prime(1),z_prime(1))
6777 c
6778 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6779 C to local coordinate system. Store in xx, yy, zz.
6780 c
6781         xx=0.0d0
6782         yy=0.0d0
6783         zz=0.0d0
6784         do j = 1,3
6785           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6786           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6787           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6788         enddo
6789
6790         xxtab(i)=xx
6791         yytab(i)=yy
6792         zztab(i)=zz
6793 C
6794 C Compute the energy of the ith side cbain
6795 C
6796 c        write (2,*) "xx",xx," yy",yy," zz",zz
6797         it=iabs(itype(i))
6798         do j = 1,65
6799           x(j) = sc_parmin(j,it)
6800         enddo
6801 #ifdef CHECK_COORD
6802 Cc diagnostics - remove later
6803         xx1 = dcos(alph(2))
6804         yy1 = dsin(alph(2))*dcos(omeg(2))
6805         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6806         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6807      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6808      &    xx1,yy1,zz1
6809 C,"  --- ", xx_w,yy_w,zz_w
6810 c end diagnostics
6811 #endif
6812         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6813      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6814      &   + x(10)*yy*zz
6815         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6816      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6817      & + x(20)*yy*zz
6818         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6819      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6820      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6821      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6822      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6823      &  +x(40)*xx*yy*zz
6824         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6825      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6826      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6827      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6828      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6829      &  +x(60)*xx*yy*zz
6830         dsc_i   = 0.743d0+x(61)
6831         dp2_i   = 1.9d0+x(62)
6832         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6833      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6834         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6835      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6836         s1=(1+x(63))/(0.1d0 + dscp1)
6837         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6838         s2=(1+x(65))/(0.1d0 + dscp2)
6839         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6840         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6841      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6842 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6843 c     &   sumene4,
6844 c     &   dscp1,dscp2,sumene
6845 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6846         escloc = escloc + sumene
6847 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6848 c     & ,zz,xx,yy
6849 c#define DEBUG
6850 #ifdef DEBUG
6851 C
6852 C This section to check the numerical derivatives of the energy of ith side
6853 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6854 C #define DEBUG in the code to turn it on.
6855 C
6856         write (2,*) "sumene               =",sumene
6857         aincr=1.0d-7
6858         xxsave=xx
6859         xx=xx+aincr
6860         write (2,*) xx,yy,zz
6861         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6862         de_dxx_num=(sumenep-sumene)/aincr
6863         xx=xxsave
6864         write (2,*) "xx+ sumene from enesc=",sumenep
6865         yysave=yy
6866         yy=yy+aincr
6867         write (2,*) xx,yy,zz
6868         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6869         de_dyy_num=(sumenep-sumene)/aincr
6870         yy=yysave
6871         write (2,*) "yy+ sumene from enesc=",sumenep
6872         zzsave=zz
6873         zz=zz+aincr
6874         write (2,*) xx,yy,zz
6875         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6876         de_dzz_num=(sumenep-sumene)/aincr
6877         zz=zzsave
6878         write (2,*) "zz+ sumene from enesc=",sumenep
6879         costsave=cost2tab(i+1)
6880         sintsave=sint2tab(i+1)
6881         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6882         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6883         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6884         de_dt_num=(sumenep-sumene)/aincr
6885         write (2,*) " t+ sumene from enesc=",sumenep
6886         cost2tab(i+1)=costsave
6887         sint2tab(i+1)=sintsave
6888 C End of diagnostics section.
6889 #endif
6890 C
6891 C Compute the gradient of esc
6892 C
6893 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6894         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6895         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6896         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6897         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6898         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6899         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6900         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6901         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6902         pom1=(sumene3*sint2tab(i+1)+sumene1)
6903      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6904         pom2=(sumene4*cost2tab(i+1)+sumene2)
6905      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6906         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6907         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6908      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6909      &  +x(40)*yy*zz
6910         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6911         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6912      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6913      &  +x(60)*yy*zz
6914         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6915      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6916      &        +(pom1+pom2)*pom_dx
6917 #ifdef DEBUG
6918         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6919 #endif
6920 C
6921         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6922         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6923      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6924      &  +x(40)*xx*zz
6925         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6926         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6927      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6928      &  +x(59)*zz**2 +x(60)*xx*zz
6929         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6930      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6931      &        +(pom1-pom2)*pom_dy
6932 #ifdef DEBUG
6933         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6934 #endif
6935 C
6936         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6937      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6938      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6939      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6940      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6941      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6942      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6943      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6944 #ifdef DEBUG
6945         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6946 #endif
6947 C
6948         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6949      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6950      &  +pom1*pom_dt1+pom2*pom_dt2
6951 #ifdef DEBUG
6952         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6953 #endif
6954 c#undef DEBUG
6955 c
6956 C
6957        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6958        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6959        cosfac2xx=cosfac2*xx
6960        sinfac2yy=sinfac2*yy
6961        do k = 1,3
6962          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6963      &      vbld_inv(i+1)
6964          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6965      &      vbld_inv(i)
6966          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6967          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6968 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6969 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6970 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6971 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6972          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6973          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6974          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6975          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6976          dZZ_Ci1(k)=0.0d0
6977          dZZ_Ci(k)=0.0d0
6978          do j=1,3
6979            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6980      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6981            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6982      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6983          enddo
6984
6985          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6986          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6987          dZZ_XYZ(k)=vbld_inv(i+nres)*
6988      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6989 c
6990          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6991          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6992        enddo
6993
6994        do k=1,3
6995          dXX_Ctab(k,i)=dXX_Ci(k)
6996          dXX_C1tab(k,i)=dXX_Ci1(k)
6997          dYY_Ctab(k,i)=dYY_Ci(k)
6998          dYY_C1tab(k,i)=dYY_Ci1(k)
6999          dZZ_Ctab(k,i)=dZZ_Ci(k)
7000          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7001          dXX_XYZtab(k,i)=dXX_XYZ(k)
7002          dYY_XYZtab(k,i)=dYY_XYZ(k)
7003          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7004        enddo
7005
7006        do k = 1,3
7007 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7008 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7009 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7010 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7011 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7012 c     &    dt_dci(k)
7013 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7014 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7015          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7016      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7017          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7018      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7019          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7020      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7021        enddo
7022 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7023 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7024
7025 C to check gradient call subroutine check_grad
7026
7027     1 continue
7028       enddo
7029       return
7030       end
7031 c------------------------------------------------------------------------------
7032       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7033       implicit none
7034       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7035      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7036       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7037      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7038      &   + x(10)*yy*zz
7039       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7040      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7041      & + x(20)*yy*zz
7042       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7043      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7044      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7045      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7046      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7047      &  +x(40)*xx*yy*zz
7048       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7049      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7050      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7051      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7052      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7053      &  +x(60)*xx*yy*zz
7054       dsc_i   = 0.743d0+x(61)
7055       dp2_i   = 1.9d0+x(62)
7056       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7057      &          *(xx*cost2+yy*sint2))
7058       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7059      &          *(xx*cost2-yy*sint2))
7060       s1=(1+x(63))/(0.1d0 + dscp1)
7061       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7062       s2=(1+x(65))/(0.1d0 + dscp2)
7063       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7064       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7065      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7066       enesc=sumene
7067       return
7068       end
7069 #endif
7070 c------------------------------------------------------------------------------
7071       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7072 C
7073 C This procedure calculates two-body contact function g(rij) and its derivative:
7074 C
7075 C           eps0ij                                     !       x < -1
7076 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7077 C            0                                         !       x > 1
7078 C
7079 C where x=(rij-r0ij)/delta
7080 C
7081 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7082 C
7083       implicit none
7084       double precision rij,r0ij,eps0ij,fcont,fprimcont
7085       double precision x,x2,x4,delta
7086 c     delta=0.02D0*r0ij
7087 c      delta=0.2D0*r0ij
7088       x=(rij-r0ij)/delta
7089       if (x.lt.-1.0D0) then
7090         fcont=eps0ij
7091         fprimcont=0.0D0
7092       else if (x.le.1.0D0) then
7093         x2=x*x
7094         x4=x2*x2
7095         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7096         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7097       else
7098         fcont=0.0D0
7099         fprimcont=0.0D0
7100       endif
7101       return
7102       end
7103 c------------------------------------------------------------------------------
7104       subroutine splinthet(theti,delta,ss,ssder)
7105       implicit real*8 (a-h,o-z)
7106       include 'DIMENSIONS'
7107       include 'COMMON.VAR'
7108       include 'COMMON.GEO'
7109       thetup=pi-delta
7110       thetlow=delta
7111       if (theti.gt.pipol) then
7112         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7113       else
7114         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7115         ssder=-ssder
7116       endif
7117       return
7118       end
7119 c------------------------------------------------------------------------------
7120       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7121       implicit none
7122       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7123       double precision ksi,ksi2,ksi3,a1,a2,a3
7124       a1=fprim0*delta/(f1-f0)
7125       a2=3.0d0-2.0d0*a1
7126       a3=a1-2.0d0
7127       ksi=(x-x0)/delta
7128       ksi2=ksi*ksi
7129       ksi3=ksi2*ksi
7130       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7131       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7132       return
7133       end
7134 c------------------------------------------------------------------------------
7135       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7136       implicit none
7137       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7138       double precision ksi,ksi2,ksi3,a1,a2,a3
7139       ksi=(x-x0)/delta
7140       ksi2=ksi*ksi
7141       ksi3=ksi2*ksi
7142       a1=fprim0x*delta
7143       a2=3*(f1x-f0x)-2*fprim0x*delta
7144       a3=fprim0x*delta-2*(f1x-f0x)
7145       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7146       return
7147       end
7148 C-----------------------------------------------------------------------------
7149 #ifdef CRYST_TOR
7150 C-----------------------------------------------------------------------------
7151       subroutine etor(etors,edihcnstr)
7152       implicit real*8 (a-h,o-z)
7153       include 'DIMENSIONS'
7154       include 'COMMON.VAR'
7155       include 'COMMON.GEO'
7156       include 'COMMON.LOCAL'
7157       include 'COMMON.TORSION'
7158       include 'COMMON.INTERACT'
7159       include 'COMMON.DERIV'
7160       include 'COMMON.CHAIN'
7161       include 'COMMON.NAMES'
7162       include 'COMMON.IOUNITS'
7163       include 'COMMON.FFIELD'
7164       include 'COMMON.TORCNSTR'
7165       include 'COMMON.CONTROL'
7166       logical lprn
7167 C Set lprn=.true. for debugging
7168       lprn=.false.
7169 c      lprn=.true.
7170       etors=0.0D0
7171       do i=iphi_start,iphi_end
7172       etors_ii=0.0D0
7173         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7174      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7175         itori=itortyp(itype(i-2))
7176         itori1=itortyp(itype(i-1))
7177         phii=phi(i)
7178         gloci=0.0D0
7179 C Proline-Proline pair is a special case...
7180         if (itori.eq.3 .and. itori1.eq.3) then
7181           if (phii.gt.-dwapi3) then
7182             cosphi=dcos(3*phii)
7183             fac=1.0D0/(1.0D0-cosphi)
7184             etorsi=v1(1,3,3)*fac
7185             etorsi=etorsi+etorsi
7186             etors=etors+etorsi-v1(1,3,3)
7187             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7188             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7189           endif
7190           do j=1,3
7191             v1ij=v1(j+1,itori,itori1)
7192             v2ij=v2(j+1,itori,itori1)
7193             cosphi=dcos(j*phii)
7194             sinphi=dsin(j*phii)
7195             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7196             if (energy_dec) etors_ii=etors_ii+
7197      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7198             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7199           enddo
7200         else
7201           do j=1,nterm_old
7202             v1ij=v1(j,itori,itori1)
7203             v2ij=v2(j,itori,itori1)
7204             cosphi=dcos(j*phii)
7205             sinphi=dsin(j*phii)
7206             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7207             if (energy_dec) etors_ii=etors_ii+
7208      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7209             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7210           enddo
7211         endif
7212         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7213              'etor',i,etors_ii
7214         if (lprn)
7215      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7216      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7217      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7218         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7219 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7220       enddo
7221 ! 6/20/98 - dihedral angle constraints
7222       edihcnstr=0.0d0
7223       do i=1,ndih_constr
7224         itori=idih_constr(i)
7225         phii=phi(itori)
7226         difi=phii-phi0(i)
7227         if (difi.gt.drange(i)) then
7228           difi=difi-drange(i)
7229           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7230           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7231         else if (difi.lt.-drange(i)) then
7232           difi=difi+drange(i)
7233           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7234           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7235         endif
7236 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7237 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7238       enddo
7239 !      write (iout,*) 'edihcnstr',edihcnstr
7240       return
7241       end
7242 c------------------------------------------------------------------------------
7243       subroutine etor_d(etors_d)
7244       etors_d=0.0d0
7245       return
7246       end
7247 c----------------------------------------------------------------------------
7248 #else
7249       subroutine etor(etors,edihcnstr)
7250       implicit real*8 (a-h,o-z)
7251       include 'DIMENSIONS'
7252       include 'COMMON.VAR'
7253       include 'COMMON.GEO'
7254       include 'COMMON.LOCAL'
7255       include 'COMMON.TORSION'
7256       include 'COMMON.INTERACT'
7257       include 'COMMON.DERIV'
7258       include 'COMMON.CHAIN'
7259       include 'COMMON.NAMES'
7260       include 'COMMON.IOUNITS'
7261       include 'COMMON.FFIELD'
7262       include 'COMMON.TORCNSTR'
7263       include 'COMMON.CONTROL'
7264       logical lprn
7265 C Set lprn=.true. for debugging
7266       lprn=.false.
7267 c     lprn=.true.
7268       etors=0.0D0
7269       do i=iphi_start,iphi_end
7270 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7271 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7272 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7273 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7274         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7275      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7276 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7277 C For introducing the NH3+ and COO- group please check the etor_d for reference
7278 C and guidance
7279         etors_ii=0.0D0
7280          if (iabs(itype(i)).eq.20) then
7281          iblock=2
7282          else
7283          iblock=1
7284          endif
7285         itori=itortyp(itype(i-2))
7286         itori1=itortyp(itype(i-1))
7287         phii=phi(i)
7288         gloci=0.0D0
7289 C Regular cosine and sine terms
7290         do j=1,nterm(itori,itori1,iblock)
7291           v1ij=v1(j,itori,itori1,iblock)
7292           v2ij=v2(j,itori,itori1,iblock)
7293           cosphi=dcos(j*phii)
7294           sinphi=dsin(j*phii)
7295           etors=etors+v1ij*cosphi+v2ij*sinphi
7296           if (energy_dec) etors_ii=etors_ii+
7297      &                v1ij*cosphi+v2ij*sinphi
7298           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7299         enddo
7300 C Lorentz terms
7301 C                         v1
7302 C  E = SUM ----------------------------------- - v1
7303 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7304 C
7305         cosphi=dcos(0.5d0*phii)
7306         sinphi=dsin(0.5d0*phii)
7307         do j=1,nlor(itori,itori1,iblock)
7308           vl1ij=vlor1(j,itori,itori1)
7309           vl2ij=vlor2(j,itori,itori1)
7310           vl3ij=vlor3(j,itori,itori1)
7311           pom=vl2ij*cosphi+vl3ij*sinphi
7312           pom1=1.0d0/(pom*pom+1.0d0)
7313           etors=etors+vl1ij*pom1
7314           if (energy_dec) etors_ii=etors_ii+
7315      &                vl1ij*pom1
7316           pom=-pom*pom1*pom1
7317           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7318         enddo
7319 C Subtract the constant term
7320         etors=etors-v0(itori,itori1,iblock)
7321           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7322      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7323         if (lprn)
7324      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7325      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7326      &  (v1(j,itori,itori1,iblock),j=1,6),
7327      &  (v2(j,itori,itori1,iblock),j=1,6)
7328         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7329 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7330       enddo
7331 ! 6/20/98 - dihedral angle constraints
7332       edihcnstr=0.0d0
7333 c      do i=1,ndih_constr
7334       do i=idihconstr_start,idihconstr_end
7335         itori=idih_constr(i)
7336         phii=phi(itori)
7337         difi=pinorm(phii-phi0(i))
7338         if (difi.gt.drange(i)) then
7339           difi=difi-drange(i)
7340           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7341           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7342         else if (difi.lt.-drange(i)) then
7343           difi=difi+drange(i)
7344           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7345           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7346         else
7347           difi=0.0
7348         endif
7349        if (energy_dec) then
7350         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7351      &    i,itori,rad2deg*phii,
7352      &    rad2deg*phi0(i),  rad2deg*drange(i),
7353      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7354         endif
7355       enddo
7356 cd       write (iout,*) 'edihcnstr',edihcnstr
7357       return
7358       end
7359 c----------------------------------------------------------------------------
7360       subroutine etor_d(etors_d)
7361 C 6/23/01 Compute double torsional energy
7362       implicit real*8 (a-h,o-z)
7363       include 'DIMENSIONS'
7364       include 'COMMON.VAR'
7365       include 'COMMON.GEO'
7366       include 'COMMON.LOCAL'
7367       include 'COMMON.TORSION'
7368       include 'COMMON.INTERACT'
7369       include 'COMMON.DERIV'
7370       include 'COMMON.CHAIN'
7371       include 'COMMON.NAMES'
7372       include 'COMMON.IOUNITS'
7373       include 'COMMON.FFIELD'
7374       include 'COMMON.TORCNSTR'
7375       logical lprn
7376 C Set lprn=.true. for debugging
7377       lprn=.false.
7378 c     lprn=.true.
7379       etors_d=0.0D0
7380 c      write(iout,*) "a tu??"
7381       do i=iphid_start,iphid_end
7382 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7383 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7384 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7385 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7386 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7387          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7388      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7389      &  (itype(i+1).eq.ntyp1)) cycle
7390 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7391         itori=itortyp(itype(i-2))
7392         itori1=itortyp(itype(i-1))
7393         itori2=itortyp(itype(i))
7394         phii=phi(i)
7395         phii1=phi(i+1)
7396         gloci1=0.0D0
7397         gloci2=0.0D0
7398         iblock=1
7399         if (iabs(itype(i+1)).eq.20) iblock=2
7400 C Iblock=2 Proline type
7401 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7402 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7403 C        if (itype(i+1).eq.ntyp1) iblock=3
7404 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7405 C IS or IS NOT need for this
7406 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7407 C        is (itype(i-3).eq.ntyp1) ntblock=2
7408 C        ntblock is N-terminal blocking group
7409
7410 C Regular cosine and sine terms
7411         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7412 C Example of changes for NH3+ blocking group
7413 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7414 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7415           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7416           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7417           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7418           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7419           cosphi1=dcos(j*phii)
7420           sinphi1=dsin(j*phii)
7421           cosphi2=dcos(j*phii1)
7422           sinphi2=dsin(j*phii1)
7423           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7424      &     v2cij*cosphi2+v2sij*sinphi2
7425           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7426           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7427         enddo
7428         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7429           do l=1,k-1
7430             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7431             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7432             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7433             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7434             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7435             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7436             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7437             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7438             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7439      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7440             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7441      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7442             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7443      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7444           enddo
7445         enddo
7446         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7447         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7448       enddo
7449       return
7450       end
7451 #endif
7452 C----------------------------------------------------------------------------------
7453 C The rigorous attempt to derive energy function
7454       subroutine etor_kcc(etors,edihcnstr)
7455       implicit real*8 (a-h,o-z)
7456       include 'DIMENSIONS'
7457       include 'COMMON.VAR'
7458       include 'COMMON.GEO'
7459       include 'COMMON.LOCAL'
7460       include 'COMMON.TORSION'
7461       include 'COMMON.INTERACT'
7462       include 'COMMON.DERIV'
7463       include 'COMMON.CHAIN'
7464       include 'COMMON.NAMES'
7465       include 'COMMON.IOUNITS'
7466       include 'COMMON.FFIELD'
7467       include 'COMMON.TORCNSTR'
7468       include 'COMMON.CONTROL'
7469       logical lprn
7470       double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7471 C Set lprn=.true. for debugging
7472       lprn=.false.
7473 c     lprn=.true.
7474 C      print *,"wchodze kcc"
7475       if (tor_mode.ne.2) then
7476       etors=0.0D0
7477       endif
7478       do i=iphi_start,iphi_end
7479 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7480 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7481 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7482 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7483         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7484      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7485         itori=itortyp_kcc(itype(i-2))
7486         itori1=itortyp_kcc(itype(i-1))
7487         phii=phi(i)
7488         glocig=0.0D0
7489         glocit1=0.0d0
7490         glocit2=0.0d0
7491         sumnonchebyshev=0.0d0
7492         sumchebyshev=0.0d0
7493 C to avoid multiple devision by 2
7494         theti22=0.5d0*theta(i)
7495 C theta 12 is the theta_1 /2
7496 C theta 22 is theta_2 /2
7497         theti12=0.5d0*theta(i-1)
7498 C and appropriate sinus function
7499         sinthet2=dsin(theta(i))
7500         sinthet1=dsin(theta(i-1))
7501         costhet1=dcos(theta(i-1))
7502         costhet2=dcos(theta(i))
7503 C to speed up lets store its mutliplication
7504          sint1t2=sinthet2*sinthet1
7505 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7506 C +d_n*sin(n*gamma)) *
7507 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7508 C we have two sum 1) Non-Chebyshev which is with n and gamma
7509         do j=1,nterm_kcc(itori,itori1)
7510
7511           v1ij=v1_kcc(j,itori,itori1)
7512           v2ij=v2_kcc(j,itori,itori1)
7513 C v1ij is c_n and d_n in euation above
7514           cosphi=dcos(j*phii)
7515           sinphi=dsin(j*phii)
7516           sint1t2n=sint1t2**j
7517           sumnonchebyshev=
7518      &                    sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7519           actval=sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7520 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7521 C          if (energy_dec) etors_ii=etors_ii+
7522 C     &                v1ij*cosphi+v2ij*sinphi
7523 C glocig is the gradient local i site in gamma
7524           glocig=j*(v2ij*cosphi-v1ij*sinphi)*sint1t2n
7525 C now gradient over theta_1
7526           glocit1=actval/sinthet1*j*costhet1
7527           glocit2=actval/sinthet2*j*costhet2
7528
7529 C now the Czebyshev polinominal sum
7530         do k=1,nterm_kcc_Tb(itori,itori1)
7531          thybt1(k)=v1_chyb(k,j,itori,itori1)
7532          thybt2(k)=v2_chyb(k,j,itori,itori1)
7533 C         thybt1(k)=0.0
7534 C         thybt2(k)=0.0
7535         enddo
7536         sumth1thyb=tschebyshev
7537      &         (1,nterm_kcc_Tb(itori,itori1),thybt1(1),dcos(theti12)**2)
7538         gradthybt1=gradtschebyshev
7539      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt1(1),
7540      &        dcos(theti12)**2)
7541      & *dcos(theti12)*(-dsin(theti12))
7542         sumth2thyb=tschebyshev
7543      &         (1,nterm_kcc_Tb(itori,itori1),thybt2(1),dcos(theti22)**2)
7544         gradthybt2=gradtschebyshev
7545      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7546      &         dcos(theti22)**2)
7547      & *dcos(theti22)*(-dsin(theti22))
7548 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7549 C     &         gradtschebyshev
7550 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7551 C     &         dcos(theti22)**2),
7552 C     &         dsin(theti22)
7553
7554 C now overal sumation
7555          etors=etors+(1.0d0+sumth1thyb+sumth2thyb)*sumnonchebyshev
7556 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7557 C derivative over gamma
7558          gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7559      &   *(1.0d0+sumth1thyb+sumth2thyb)
7560 C derivative over theta1
7561         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*
7562      &  (glocit1*(1.0d0+sumth1thyb+sumth2thyb)+
7563      &   sumnonchebyshev*gradthybt1)
7564 C now derivative over theta2
7565         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*
7566      &  (glocit2*(1.0d0+sumth1thyb+sumth2thyb)+
7567      &   sumnonchebyshev*gradthybt2)
7568        enddo
7569       enddo
7570
7571 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7572 ! 6/20/98 - dihedral angle constraints
7573       if (tor_mode.ne.2) then
7574       edihcnstr=0.0d0
7575 c      do i=1,ndih_constr
7576       do i=idihconstr_start,idihconstr_end
7577         itori=idih_constr(i)
7578         phii=phi(itori)
7579         difi=pinorm(phii-phi0(i))
7580         if (difi.gt.drange(i)) then
7581           difi=difi-drange(i)
7582           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7583           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7584         else if (difi.lt.-drange(i)) then
7585           difi=difi+drange(i)
7586           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7587           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7588         else
7589           difi=0.0
7590         endif
7591        enddo
7592        endif
7593       return
7594       end
7595
7596 C The rigorous attempt to derive energy function
7597       subroutine ebend_kcc(etheta,ethetacnstr)
7598
7599       implicit real*8 (a-h,o-z)
7600       include 'DIMENSIONS'
7601       include 'COMMON.VAR'
7602       include 'COMMON.GEO'
7603       include 'COMMON.LOCAL'
7604       include 'COMMON.TORSION'
7605       include 'COMMON.INTERACT'
7606       include 'COMMON.DERIV'
7607       include 'COMMON.CHAIN'
7608       include 'COMMON.NAMES'
7609       include 'COMMON.IOUNITS'
7610       include 'COMMON.FFIELD'
7611       include 'COMMON.TORCNSTR'
7612       include 'COMMON.CONTROL'
7613       logical lprn
7614       double precision thybt1(maxtermkcc)
7615 C Set lprn=.true. for debugging
7616       lprn=.false.
7617 c     lprn=.true.
7618 C      print *,"wchodze kcc"
7619       if (tormode.ne.2) etheta=0.0D0
7620       do i=ithet_start,ithet_end
7621 c        print *,i,itype(i-1),itype(i),itype(i-2)
7622         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7623      &  .or.itype(i).eq.ntyp1) cycle
7624          iti=itortyp_kcc(itype(i-1))
7625         sinthet=dsin(theta(i)/2.0d0)
7626         costhet=dcos(theta(i)/2.0d0)
7627          do j=1,nbend_kcc_Tb(iti)
7628           thybt1(j)=v1bend_chyb(j,iti)
7629          enddo
7630          sumth1thyb=tschebyshev
7631      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7632         ihelp=nbend_kcc_Tb(iti)-1
7633         gradthybt1=gradtschebyshev
7634      &         (0,ihelp,thybt1(1),costhet)
7635         etheta=etheta+sumth1thyb
7636 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7637         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7638      &   gradthybt1*sinthet*(-0.5d0)
7639       enddo
7640       if (tormode.ne.2) then
7641       ethetacnstr=0.0d0
7642 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7643       do i=ithetaconstr_start,ithetaconstr_end
7644         itheta=itheta_constr(i)
7645         thetiii=theta(itheta)
7646         difi=pinorm(thetiii-theta_constr0(i))
7647         if (difi.gt.theta_drange(i)) then
7648           difi=difi-theta_drange(i)
7649           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7650           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7651      &    +for_thet_constr(i)*difi**3
7652         else if (difi.lt.-drange(i)) then
7653           difi=difi+drange(i)
7654           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7655           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7656      &    +for_thet_constr(i)*difi**3
7657         else
7658           difi=0.0
7659         endif
7660        if (energy_dec) then
7661         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7662      &    i,itheta,rad2deg*thetiii,
7663      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7664      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7665      &    gloc(itheta+nphi-2,icg)
7666         endif
7667       enddo
7668       endif
7669       return
7670       end
7671 c------------------------------------------------------------------------------
7672       subroutine eback_sc_corr(esccor)
7673 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7674 c        conformational states; temporarily implemented as differences
7675 c        between UNRES torsional potentials (dependent on three types of
7676 c        residues) and the torsional potentials dependent on all 20 types
7677 c        of residues computed from AM1  energy surfaces of terminally-blocked
7678 c        amino-acid residues.
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'COMMON.VAR'
7682       include 'COMMON.GEO'
7683       include 'COMMON.LOCAL'
7684       include 'COMMON.TORSION'
7685       include 'COMMON.SCCOR'
7686       include 'COMMON.INTERACT'
7687       include 'COMMON.DERIV'
7688       include 'COMMON.CHAIN'
7689       include 'COMMON.NAMES'
7690       include 'COMMON.IOUNITS'
7691       include 'COMMON.FFIELD'
7692       include 'COMMON.CONTROL'
7693       logical lprn
7694 C Set lprn=.true. for debugging
7695       lprn=.false.
7696 c      lprn=.true.
7697 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7698       esccor=0.0D0
7699       do i=itau_start,itau_end
7700         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7701         esccor_ii=0.0D0
7702         isccori=isccortyp(itype(i-2))
7703         isccori1=isccortyp(itype(i-1))
7704 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7705         phii=phi(i)
7706         do intertyp=1,3 !intertyp
7707 cc Added 09 May 2012 (Adasko)
7708 cc  Intertyp means interaction type of backbone mainchain correlation:
7709 c   1 = SC...Ca...Ca...Ca
7710 c   2 = Ca...Ca...Ca...SC
7711 c   3 = SC...Ca...Ca...SCi
7712         gloci=0.0D0
7713         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7714      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7715      &      (itype(i-1).eq.ntyp1)))
7716      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7717      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7718      &     .or.(itype(i).eq.ntyp1)))
7719      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7720      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7721      &      (itype(i-3).eq.ntyp1)))) cycle
7722         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7723         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7724      & cycle
7725        do j=1,nterm_sccor(isccori,isccori1)
7726           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7727           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7728           cosphi=dcos(j*tauangle(intertyp,i))
7729           sinphi=dsin(j*tauangle(intertyp,i))
7730           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7731           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7732         enddo
7733 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7734         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7735         if (lprn)
7736      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7737      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7738      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7739      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7740         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7741        enddo !intertyp
7742       enddo
7743
7744       return
7745       end
7746 c----------------------------------------------------------------------------
7747       subroutine multibody(ecorr)
7748 C This subroutine calculates multi-body contributions to energy following
7749 C the idea of Skolnick et al. If side chains I and J make a contact and
7750 C at the same time side chains I+1 and J+1 make a contact, an extra
7751 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7752       implicit real*8 (a-h,o-z)
7753       include 'DIMENSIONS'
7754       include 'COMMON.IOUNITS'
7755       include 'COMMON.DERIV'
7756       include 'COMMON.INTERACT'
7757       include 'COMMON.CONTACTS'
7758       double precision gx(3),gx1(3)
7759       logical lprn
7760
7761 C Set lprn=.true. for debugging
7762       lprn=.false.
7763
7764       if (lprn) then
7765         write (iout,'(a)') 'Contact function values:'
7766         do i=nnt,nct-2
7767           write (iout,'(i2,20(1x,i2,f10.5))')
7768      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7769         enddo
7770       endif
7771       ecorr=0.0D0
7772       do i=nnt,nct
7773         do j=1,3
7774           gradcorr(j,i)=0.0D0
7775           gradxorr(j,i)=0.0D0
7776         enddo
7777       enddo
7778       do i=nnt,nct-2
7779
7780         DO ISHIFT = 3,4
7781
7782         i1=i+ishift
7783         num_conti=num_cont(i)
7784         num_conti1=num_cont(i1)
7785         do jj=1,num_conti
7786           j=jcont(jj,i)
7787           do kk=1,num_conti1
7788             j1=jcont(kk,i1)
7789             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7790 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7791 cd   &                   ' ishift=',ishift
7792 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7793 C The system gains extra energy.
7794               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7795             endif   ! j1==j+-ishift
7796           enddo     ! kk
7797         enddo       ! jj
7798
7799         ENDDO ! ISHIFT
7800
7801       enddo         ! i
7802       return
7803       end
7804 c------------------------------------------------------------------------------
7805       double precision function esccorr(i,j,k,l,jj,kk)
7806       implicit real*8 (a-h,o-z)
7807       include 'DIMENSIONS'
7808       include 'COMMON.IOUNITS'
7809       include 'COMMON.DERIV'
7810       include 'COMMON.INTERACT'
7811       include 'COMMON.CONTACTS'
7812       include 'COMMON.SHIELD'
7813       double precision gx(3),gx1(3)
7814       logical lprn
7815       lprn=.false.
7816       eij=facont(jj,i)
7817       ekl=facont(kk,k)
7818 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7819 C Calculate the multi-body contribution to energy.
7820 C Calculate multi-body contributions to the gradient.
7821 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7822 cd   & k,l,(gacont(m,kk,k),m=1,3)
7823       do m=1,3
7824         gx(m) =ekl*gacont(m,jj,i)
7825         gx1(m)=eij*gacont(m,kk,k)
7826         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7827         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7828         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7829         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7830       enddo
7831       do m=i,j-1
7832         do ll=1,3
7833           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7834         enddo
7835       enddo
7836       do m=k,l-1
7837         do ll=1,3
7838           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7839         enddo
7840       enddo
7841       esccorr=-eij*ekl
7842       return
7843       end
7844 c------------------------------------------------------------------------------
7845       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7846 C This subroutine calculates multi-body contributions to hydrogen-bonding
7847       implicit real*8 (a-h,o-z)
7848       include 'DIMENSIONS'
7849       include 'COMMON.IOUNITS'
7850 #ifdef MPI
7851       include "mpif.h"
7852       parameter (max_cont=maxconts)
7853       parameter (max_dim=26)
7854       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7855       double precision zapas(max_dim,maxconts,max_fg_procs),
7856      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7857       common /przechowalnia/ zapas
7858       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7859      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7860 #endif
7861       include 'COMMON.SETUP'
7862       include 'COMMON.FFIELD'
7863       include 'COMMON.DERIV'
7864       include 'COMMON.INTERACT'
7865       include 'COMMON.CONTACTS'
7866       include 'COMMON.CONTROL'
7867       include 'COMMON.LOCAL'
7868       double precision gx(3),gx1(3),time00
7869       logical lprn,ldone
7870
7871 C Set lprn=.true. for debugging
7872       lprn=.false.
7873 #ifdef MPI
7874       n_corr=0
7875       n_corr1=0
7876       if (nfgtasks.le.1) goto 30
7877       if (lprn) then
7878         write (iout,'(a)') 'Contact function values before RECEIVE:'
7879         do i=nnt,nct-2
7880           write (iout,'(2i3,50(1x,i2,f5.2))')
7881      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7882      &    j=1,num_cont_hb(i))
7883         enddo
7884       endif
7885       call flush(iout)
7886       do i=1,ntask_cont_from
7887         ncont_recv(i)=0
7888       enddo
7889       do i=1,ntask_cont_to
7890         ncont_sent(i)=0
7891       enddo
7892 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7893 c     & ntask_cont_to
7894 C Make the list of contacts to send to send to other procesors
7895 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7896 c      call flush(iout)
7897       do i=iturn3_start,iturn3_end
7898 c        write (iout,*) "make contact list turn3",i," num_cont",
7899 c     &    num_cont_hb(i)
7900         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7901       enddo
7902       do i=iturn4_start,iturn4_end
7903 c        write (iout,*) "make contact list turn4",i," num_cont",
7904 c     &   num_cont_hb(i)
7905         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7906       enddo
7907       do ii=1,nat_sent
7908         i=iat_sent(ii)
7909 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7910 c     &    num_cont_hb(i)
7911         do j=1,num_cont_hb(i)
7912         do k=1,4
7913           jjc=jcont_hb(j,i)
7914           iproc=iint_sent_local(k,jjc,ii)
7915 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7916           if (iproc.gt.0) then
7917             ncont_sent(iproc)=ncont_sent(iproc)+1
7918             nn=ncont_sent(iproc)
7919             zapas(1,nn,iproc)=i
7920             zapas(2,nn,iproc)=jjc
7921             zapas(3,nn,iproc)=facont_hb(j,i)
7922             zapas(4,nn,iproc)=ees0p(j,i)
7923             zapas(5,nn,iproc)=ees0m(j,i)
7924             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7925             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7926             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7927             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7928             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7929             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7930             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7931             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7932             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7933             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7934             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7935             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7936             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7937             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7938             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7939             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7940             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7941             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7942             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7943             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7944             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7945           endif
7946         enddo
7947         enddo
7948       enddo
7949       if (lprn) then
7950       write (iout,*)
7951      &  "Numbers of contacts to be sent to other processors",
7952      &  (ncont_sent(i),i=1,ntask_cont_to)
7953       write (iout,*) "Contacts sent"
7954       do ii=1,ntask_cont_to
7955         nn=ncont_sent(ii)
7956         iproc=itask_cont_to(ii)
7957         write (iout,*) nn," contacts to processor",iproc,
7958      &   " of CONT_TO_COMM group"
7959         do i=1,nn
7960           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7961         enddo
7962       enddo
7963       call flush(iout)
7964       endif
7965       CorrelType=477
7966       CorrelID=fg_rank+1
7967       CorrelType1=478
7968       CorrelID1=nfgtasks+fg_rank+1
7969       ireq=0
7970 C Receive the numbers of needed contacts from other processors
7971       do ii=1,ntask_cont_from
7972         iproc=itask_cont_from(ii)
7973         ireq=ireq+1
7974         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7975      &    FG_COMM,req(ireq),IERR)
7976       enddo
7977 c      write (iout,*) "IRECV ended"
7978 c      call flush(iout)
7979 C Send the number of contacts needed by other processors
7980       do ii=1,ntask_cont_to
7981         iproc=itask_cont_to(ii)
7982         ireq=ireq+1
7983         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7984      &    FG_COMM,req(ireq),IERR)
7985       enddo
7986 c      write (iout,*) "ISEND ended"
7987 c      write (iout,*) "number of requests (nn)",ireq
7988       call flush(iout)
7989       if (ireq.gt.0)
7990      &  call MPI_Waitall(ireq,req,status_array,ierr)
7991 c      write (iout,*)
7992 c     &  "Numbers of contacts to be received from other processors",
7993 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7994 c      call flush(iout)
7995 C Receive contacts
7996       ireq=0
7997       do ii=1,ntask_cont_from
7998         iproc=itask_cont_from(ii)
7999         nn=ncont_recv(ii)
8000 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8001 c     &   " of CONT_TO_COMM group"
8002         call flush(iout)
8003         if (nn.gt.0) then
8004           ireq=ireq+1
8005           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8006      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8007 c          write (iout,*) "ireq,req",ireq,req(ireq)
8008         endif
8009       enddo
8010 C Send the contacts to processors that need them
8011       do ii=1,ntask_cont_to
8012         iproc=itask_cont_to(ii)
8013         nn=ncont_sent(ii)
8014 c        write (iout,*) nn," contacts to processor",iproc,
8015 c     &   " of CONT_TO_COMM group"
8016         if (nn.gt.0) then
8017           ireq=ireq+1
8018           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8019      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8020 c          write (iout,*) "ireq,req",ireq,req(ireq)
8021 c          do i=1,nn
8022 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8023 c          enddo
8024         endif
8025       enddo
8026 c      write (iout,*) "number of requests (contacts)",ireq
8027 c      write (iout,*) "req",(req(i),i=1,4)
8028 c      call flush(iout)
8029       if (ireq.gt.0)
8030      & call MPI_Waitall(ireq,req,status_array,ierr)
8031       do iii=1,ntask_cont_from
8032         iproc=itask_cont_from(iii)
8033         nn=ncont_recv(iii)
8034         if (lprn) then
8035         write (iout,*) "Received",nn," contacts from processor",iproc,
8036      &   " of CONT_FROM_COMM group"
8037         call flush(iout)
8038         do i=1,nn
8039           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8040         enddo
8041         call flush(iout)
8042         endif
8043         do i=1,nn
8044           ii=zapas_recv(1,i,iii)
8045 c Flag the received contacts to prevent double-counting
8046           jj=-zapas_recv(2,i,iii)
8047 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8048 c          call flush(iout)
8049           nnn=num_cont_hb(ii)+1
8050           num_cont_hb(ii)=nnn
8051           jcont_hb(nnn,ii)=jj
8052           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8053           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8054           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8055           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8056           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8057           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8058           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8059           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8060           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8061           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8062           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8063           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8064           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8065           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8066           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8067           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8068           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8069           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8070           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8071           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8072           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8073           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8074           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8075           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8076         enddo
8077       enddo
8078       call flush(iout)
8079       if (lprn) then
8080         write (iout,'(a)') 'Contact function values after receive:'
8081         do i=nnt,nct-2
8082           write (iout,'(2i3,50(1x,i3,f5.2))')
8083      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8084      &    j=1,num_cont_hb(i))
8085         enddo
8086         call flush(iout)
8087       endif
8088    30 continue
8089 #endif
8090       if (lprn) then
8091         write (iout,'(a)') 'Contact function values:'
8092         do i=nnt,nct-2
8093           write (iout,'(2i3,50(1x,i3,f5.2))')
8094      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8095      &    j=1,num_cont_hb(i))
8096         enddo
8097       endif
8098       ecorr=0.0D0
8099 C Remove the loop below after debugging !!!
8100       do i=nnt,nct
8101         do j=1,3
8102           gradcorr(j,i)=0.0D0
8103           gradxorr(j,i)=0.0D0
8104         enddo
8105       enddo
8106 C Calculate the local-electrostatic correlation terms
8107       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8108         i1=i+1
8109         num_conti=num_cont_hb(i)
8110         num_conti1=num_cont_hb(i+1)
8111         do jj=1,num_conti
8112           j=jcont_hb(jj,i)
8113           jp=iabs(j)
8114           do kk=1,num_conti1
8115             j1=jcont_hb(kk,i1)
8116             jp1=iabs(j1)
8117 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8118 c     &         ' jj=',jj,' kk=',kk
8119             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8120      &          .or. j.lt.0 .and. j1.gt.0) .and.
8121      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8122 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8123 C The system gains extra energy.
8124               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8125               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8126      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8127               n_corr=n_corr+1
8128             else if (j1.eq.j) then
8129 C Contacts I-J and I-(J+1) occur simultaneously.
8130 C The system loses extra energy.
8131 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8132             endif
8133           enddo ! kk
8134           do kk=1,num_conti
8135             j1=jcont_hb(kk,i)
8136 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8137 c    &         ' jj=',jj,' kk=',kk
8138             if (j1.eq.j+1) then
8139 C Contacts I-J and (I+1)-J occur simultaneously.
8140 C The system loses extra energy.
8141 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8142             endif ! j1==j+1
8143           enddo ! kk
8144         enddo ! jj
8145       enddo ! i
8146       return
8147       end
8148 c------------------------------------------------------------------------------
8149       subroutine add_hb_contact(ii,jj,itask)
8150       implicit real*8 (a-h,o-z)
8151       include "DIMENSIONS"
8152       include "COMMON.IOUNITS"
8153       integer max_cont
8154       integer max_dim
8155       parameter (max_cont=maxconts)
8156       parameter (max_dim=26)
8157       include "COMMON.CONTACTS"
8158       double precision zapas(max_dim,maxconts,max_fg_procs),
8159      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8160       common /przechowalnia/ zapas
8161       integer i,j,ii,jj,iproc,itask(4),nn
8162 c      write (iout,*) "itask",itask
8163       do i=1,2
8164         iproc=itask(i)
8165         if (iproc.gt.0) then
8166           do j=1,num_cont_hb(ii)
8167             jjc=jcont_hb(j,ii)
8168 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8169             if (jjc.eq.jj) then
8170               ncont_sent(iproc)=ncont_sent(iproc)+1
8171               nn=ncont_sent(iproc)
8172               zapas(1,nn,iproc)=ii
8173               zapas(2,nn,iproc)=jjc
8174               zapas(3,nn,iproc)=facont_hb(j,ii)
8175               zapas(4,nn,iproc)=ees0p(j,ii)
8176               zapas(5,nn,iproc)=ees0m(j,ii)
8177               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8178               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8179               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8180               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8181               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8182               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8183               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8184               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8185               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8186               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8187               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8188               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8189               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8190               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8191               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8192               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8193               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8194               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8195               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8196               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8197               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8198               exit
8199             endif
8200           enddo
8201         endif
8202       enddo
8203       return
8204       end
8205 c------------------------------------------------------------------------------
8206       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8207      &  n_corr1)
8208 C This subroutine calculates multi-body contributions to hydrogen-bonding
8209       implicit real*8 (a-h,o-z)
8210       include 'DIMENSIONS'
8211       include 'COMMON.IOUNITS'
8212 #ifdef MPI
8213       include "mpif.h"
8214       parameter (max_cont=maxconts)
8215       parameter (max_dim=70)
8216       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8217       double precision zapas(max_dim,maxconts,max_fg_procs),
8218      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8219       common /przechowalnia/ zapas
8220       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8221      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8222 #endif
8223       include 'COMMON.SETUP'
8224       include 'COMMON.FFIELD'
8225       include 'COMMON.DERIV'
8226       include 'COMMON.LOCAL'
8227       include 'COMMON.INTERACT'
8228       include 'COMMON.CONTACTS'
8229       include 'COMMON.CHAIN'
8230       include 'COMMON.CONTROL'
8231       include 'COMMON.SHIELD'
8232       double precision gx(3),gx1(3)
8233       integer num_cont_hb_old(maxres)
8234       logical lprn,ldone
8235       double precision eello4,eello5,eelo6,eello_turn6
8236       external eello4,eello5,eello6,eello_turn6
8237 C Set lprn=.true. for debugging
8238       lprn=.false.
8239       eturn6=0.0d0
8240 #ifdef MPI
8241       do i=1,nres
8242         num_cont_hb_old(i)=num_cont_hb(i)
8243       enddo
8244       n_corr=0
8245       n_corr1=0
8246       if (nfgtasks.le.1) goto 30
8247       if (lprn) then
8248         write (iout,'(a)') 'Contact function values before RECEIVE:'
8249         do i=nnt,nct-2
8250           write (iout,'(2i3,50(1x,i2,f5.2))')
8251      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8252      &    j=1,num_cont_hb(i))
8253         enddo
8254       endif
8255       call flush(iout)
8256       do i=1,ntask_cont_from
8257         ncont_recv(i)=0
8258       enddo
8259       do i=1,ntask_cont_to
8260         ncont_sent(i)=0
8261       enddo
8262 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8263 c     & ntask_cont_to
8264 C Make the list of contacts to send to send to other procesors
8265       do i=iturn3_start,iturn3_end
8266 c        write (iout,*) "make contact list turn3",i," num_cont",
8267 c     &    num_cont_hb(i)
8268         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8269       enddo
8270       do i=iturn4_start,iturn4_end
8271 c        write (iout,*) "make contact list turn4",i," num_cont",
8272 c     &   num_cont_hb(i)
8273         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8274       enddo
8275       do ii=1,nat_sent
8276         i=iat_sent(ii)
8277 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8278 c     &    num_cont_hb(i)
8279         do j=1,num_cont_hb(i)
8280         do k=1,4
8281           jjc=jcont_hb(j,i)
8282           iproc=iint_sent_local(k,jjc,ii)
8283 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8284           if (iproc.ne.0) then
8285             ncont_sent(iproc)=ncont_sent(iproc)+1
8286             nn=ncont_sent(iproc)
8287             zapas(1,nn,iproc)=i
8288             zapas(2,nn,iproc)=jjc
8289             zapas(3,nn,iproc)=d_cont(j,i)
8290             ind=3
8291             do kk=1,3
8292               ind=ind+1
8293               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8294             enddo
8295             do kk=1,2
8296               do ll=1,2
8297                 ind=ind+1
8298                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8299               enddo
8300             enddo
8301             do jj=1,5
8302               do kk=1,3
8303                 do ll=1,2
8304                   do mm=1,2
8305                     ind=ind+1
8306                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8307                   enddo
8308                 enddo
8309               enddo
8310             enddo
8311           endif
8312         enddo
8313         enddo
8314       enddo
8315       if (lprn) then
8316       write (iout,*)
8317      &  "Numbers of contacts to be sent to other processors",
8318      &  (ncont_sent(i),i=1,ntask_cont_to)
8319       write (iout,*) "Contacts sent"
8320       do ii=1,ntask_cont_to
8321         nn=ncont_sent(ii)
8322         iproc=itask_cont_to(ii)
8323         write (iout,*) nn," contacts to processor",iproc,
8324      &   " of CONT_TO_COMM group"
8325         do i=1,nn
8326           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8327         enddo
8328       enddo
8329       call flush(iout)
8330       endif
8331       CorrelType=477
8332       CorrelID=fg_rank+1
8333       CorrelType1=478
8334       CorrelID1=nfgtasks+fg_rank+1
8335       ireq=0
8336 C Receive the numbers of needed contacts from other processors
8337       do ii=1,ntask_cont_from
8338         iproc=itask_cont_from(ii)
8339         ireq=ireq+1
8340         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8341      &    FG_COMM,req(ireq),IERR)
8342       enddo
8343 c      write (iout,*) "IRECV ended"
8344 c      call flush(iout)
8345 C Send the number of contacts needed by other processors
8346       do ii=1,ntask_cont_to
8347         iproc=itask_cont_to(ii)
8348         ireq=ireq+1
8349         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8350      &    FG_COMM,req(ireq),IERR)
8351       enddo
8352 c      write (iout,*) "ISEND ended"
8353 c      write (iout,*) "number of requests (nn)",ireq
8354       call flush(iout)
8355       if (ireq.gt.0)
8356      &  call MPI_Waitall(ireq,req,status_array,ierr)
8357 c      write (iout,*)
8358 c     &  "Numbers of contacts to be received from other processors",
8359 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8360 c      call flush(iout)
8361 C Receive contacts
8362       ireq=0
8363       do ii=1,ntask_cont_from
8364         iproc=itask_cont_from(ii)
8365         nn=ncont_recv(ii)
8366 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8367 c     &   " of CONT_TO_COMM group"
8368         call flush(iout)
8369         if (nn.gt.0) then
8370           ireq=ireq+1
8371           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8372      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8373 c          write (iout,*) "ireq,req",ireq,req(ireq)
8374         endif
8375       enddo
8376 C Send the contacts to processors that need them
8377       do ii=1,ntask_cont_to
8378         iproc=itask_cont_to(ii)
8379         nn=ncont_sent(ii)
8380 c        write (iout,*) nn," contacts to processor",iproc,
8381 c     &   " of CONT_TO_COMM group"
8382         if (nn.gt.0) then
8383           ireq=ireq+1
8384           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8385      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8386 c          write (iout,*) "ireq,req",ireq,req(ireq)
8387 c          do i=1,nn
8388 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8389 c          enddo
8390         endif
8391       enddo
8392 c      write (iout,*) "number of requests (contacts)",ireq
8393 c      write (iout,*) "req",(req(i),i=1,4)
8394 c      call flush(iout)
8395       if (ireq.gt.0)
8396      & call MPI_Waitall(ireq,req,status_array,ierr)
8397       do iii=1,ntask_cont_from
8398         iproc=itask_cont_from(iii)
8399         nn=ncont_recv(iii)
8400         if (lprn) then
8401         write (iout,*) "Received",nn," contacts from processor",iproc,
8402      &   " of CONT_FROM_COMM group"
8403         call flush(iout)
8404         do i=1,nn
8405           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8406         enddo
8407         call flush(iout)
8408         endif
8409         do i=1,nn
8410           ii=zapas_recv(1,i,iii)
8411 c Flag the received contacts to prevent double-counting
8412           jj=-zapas_recv(2,i,iii)
8413 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8414 c          call flush(iout)
8415           nnn=num_cont_hb(ii)+1
8416           num_cont_hb(ii)=nnn
8417           jcont_hb(nnn,ii)=jj
8418           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8419           ind=3
8420           do kk=1,3
8421             ind=ind+1
8422             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8423           enddo
8424           do kk=1,2
8425             do ll=1,2
8426               ind=ind+1
8427               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8428             enddo
8429           enddo
8430           do jj=1,5
8431             do kk=1,3
8432               do ll=1,2
8433                 do mm=1,2
8434                   ind=ind+1
8435                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8436                 enddo
8437               enddo
8438             enddo
8439           enddo
8440         enddo
8441       enddo
8442       call flush(iout)
8443       if (lprn) then
8444         write (iout,'(a)') 'Contact function values after receive:'
8445         do i=nnt,nct-2
8446           write (iout,'(2i3,50(1x,i3,5f6.3))')
8447      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8448      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8449         enddo
8450         call flush(iout)
8451       endif
8452    30 continue
8453 #endif
8454       if (lprn) then
8455         write (iout,'(a)') 'Contact function values:'
8456         do i=nnt,nct-2
8457           write (iout,'(2i3,50(1x,i2,5f6.3))')
8458      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8459      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8460         enddo
8461       endif
8462       ecorr=0.0D0
8463       ecorr5=0.0d0
8464       ecorr6=0.0d0
8465 C Remove the loop below after debugging !!!
8466       do i=nnt,nct
8467         do j=1,3
8468           gradcorr(j,i)=0.0D0
8469           gradxorr(j,i)=0.0D0
8470         enddo
8471       enddo
8472 C Calculate the dipole-dipole interaction energies
8473       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8474       do i=iatel_s,iatel_e+1
8475         num_conti=num_cont_hb(i)
8476         do jj=1,num_conti
8477           j=jcont_hb(jj,i)
8478 #ifdef MOMENT
8479           call dipole(i,j,jj)
8480 #endif
8481         enddo
8482       enddo
8483       endif
8484 C Calculate the local-electrostatic correlation terms
8485 c                write (iout,*) "gradcorr5 in eello5 before loop"
8486 c                do iii=1,nres
8487 c                  write (iout,'(i5,3f10.5)')
8488 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8489 c                enddo
8490       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8491 c        write (iout,*) "corr loop i",i
8492         i1=i+1
8493         num_conti=num_cont_hb(i)
8494         num_conti1=num_cont_hb(i+1)
8495         do jj=1,num_conti
8496           j=jcont_hb(jj,i)
8497           jp=iabs(j)
8498           do kk=1,num_conti1
8499             j1=jcont_hb(kk,i1)
8500             jp1=iabs(j1)
8501 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8502 c     &         ' jj=',jj,' kk=',kk
8503 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8504             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8505      &          .or. j.lt.0 .and. j1.gt.0) .and.
8506      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8507 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8508 C The system gains extra energy.
8509               n_corr=n_corr+1
8510               sqd1=dsqrt(d_cont(jj,i))
8511               sqd2=dsqrt(d_cont(kk,i1))
8512               sred_geom = sqd1*sqd2
8513               IF (sred_geom.lt.cutoff_corr) THEN
8514                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8515      &            ekont,fprimcont)
8516 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8517 cd     &         ' jj=',jj,' kk=',kk
8518                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8519                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8520                 do l=1,3
8521                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8522                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8523                 enddo
8524                 n_corr1=n_corr1+1
8525 cd               write (iout,*) 'sred_geom=',sred_geom,
8526 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8527 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8528 cd               write (iout,*) "g_contij",g_contij
8529 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8530 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8531                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8532                 if (wcorr4.gt.0.0d0)
8533      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8534 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8535                   if (energy_dec.and.wcorr4.gt.0.0d0)
8536      1                 write (iout,'(a6,4i5,0pf7.3)')
8537      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8538 c                write (iout,*) "gradcorr5 before eello5"
8539 c                do iii=1,nres
8540 c                  write (iout,'(i5,3f10.5)')
8541 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8542 c                enddo
8543                 if (wcorr5.gt.0.0d0)
8544      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8545 c                write (iout,*) "gradcorr5 after eello5"
8546 c                do iii=1,nres
8547 c                  write (iout,'(i5,3f10.5)')
8548 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8549 c                enddo
8550                   if (energy_dec.and.wcorr5.gt.0.0d0)
8551      1                 write (iout,'(a6,4i5,0pf7.3)')
8552      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8553 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8554 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8555                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8556      &               .or. wturn6.eq.0.0d0))then
8557 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8558                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8559                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8560      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8561 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8562 cd     &            'ecorr6=',ecorr6
8563 cd                write (iout,'(4e15.5)') sred_geom,
8564 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8565 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8566 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8567                 else if (wturn6.gt.0.0d0
8568      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8569 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8570                   eturn6=eturn6+eello_turn6(i,jj,kk)
8571                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8572      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8573 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8574                 endif
8575               ENDIF
8576 1111          continue
8577             endif
8578           enddo ! kk
8579         enddo ! jj
8580       enddo ! i
8581       do i=1,nres
8582         num_cont_hb(i)=num_cont_hb_old(i)
8583       enddo
8584 c                write (iout,*) "gradcorr5 in eello5"
8585 c                do iii=1,nres
8586 c                  write (iout,'(i5,3f10.5)')
8587 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8588 c                enddo
8589       return
8590       end
8591 c------------------------------------------------------------------------------
8592       subroutine add_hb_contact_eello(ii,jj,itask)
8593       implicit real*8 (a-h,o-z)
8594       include "DIMENSIONS"
8595       include "COMMON.IOUNITS"
8596       integer max_cont
8597       integer max_dim
8598       parameter (max_cont=maxconts)
8599       parameter (max_dim=70)
8600       include "COMMON.CONTACTS"
8601       double precision zapas(max_dim,maxconts,max_fg_procs),
8602      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8603       common /przechowalnia/ zapas
8604       integer i,j,ii,jj,iproc,itask(4),nn
8605 c      write (iout,*) "itask",itask
8606       do i=1,2
8607         iproc=itask(i)
8608         if (iproc.gt.0) then
8609           do j=1,num_cont_hb(ii)
8610             jjc=jcont_hb(j,ii)
8611 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8612             if (jjc.eq.jj) then
8613               ncont_sent(iproc)=ncont_sent(iproc)+1
8614               nn=ncont_sent(iproc)
8615               zapas(1,nn,iproc)=ii
8616               zapas(2,nn,iproc)=jjc
8617               zapas(3,nn,iproc)=d_cont(j,ii)
8618               ind=3
8619               do kk=1,3
8620                 ind=ind+1
8621                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8622               enddo
8623               do kk=1,2
8624                 do ll=1,2
8625                   ind=ind+1
8626                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8627                 enddo
8628               enddo
8629               do jj=1,5
8630                 do kk=1,3
8631                   do ll=1,2
8632                     do mm=1,2
8633                       ind=ind+1
8634                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8635                     enddo
8636                   enddo
8637                 enddo
8638               enddo
8639               exit
8640             endif
8641           enddo
8642         endif
8643       enddo
8644       return
8645       end
8646 c------------------------------------------------------------------------------
8647       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8648       implicit real*8 (a-h,o-z)
8649       include 'DIMENSIONS'
8650       include 'COMMON.IOUNITS'
8651       include 'COMMON.DERIV'
8652       include 'COMMON.INTERACT'
8653       include 'COMMON.CONTACTS'
8654       include 'COMMON.SHIELD'
8655       include 'COMMON.CONTROL'
8656       double precision gx(3),gx1(3)
8657       logical lprn
8658       lprn=.false.
8659 C      print *,"wchodze",fac_shield(i),shield_mode
8660       eij=facont_hb(jj,i)
8661       ekl=facont_hb(kk,k)
8662       ees0pij=ees0p(jj,i)
8663       ees0pkl=ees0p(kk,k)
8664       ees0mij=ees0m(jj,i)
8665       ees0mkl=ees0m(kk,k)
8666       ekont=eij*ekl
8667       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8668 C*
8669 C     & fac_shield(i)**2*fac_shield(j)**2
8670 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8671 C Following 4 lines for diagnostics.
8672 cd    ees0pkl=0.0D0
8673 cd    ees0pij=1.0D0
8674 cd    ees0mkl=0.0D0
8675 cd    ees0mij=1.0D0
8676 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8677 c     & 'Contacts ',i,j,
8678 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8679 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8680 c     & 'gradcorr_long'
8681 C Calculate the multi-body contribution to energy.
8682 c      ecorr=ecorr+ekont*ees
8683 C Calculate multi-body contributions to the gradient.
8684       coeffpees0pij=coeffp*ees0pij
8685       coeffmees0mij=coeffm*ees0mij
8686       coeffpees0pkl=coeffp*ees0pkl
8687       coeffmees0mkl=coeffm*ees0mkl
8688       do ll=1,3
8689 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8690         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8691      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8692      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8693         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8694      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8695      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8696 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8697         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8698      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8699      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8700         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8701      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8702      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8703         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8704      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8705      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8706         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8707         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8708         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8709      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8710      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8711         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8712         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8713 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8714       enddo
8715 c      write (iout,*)
8716 cgrad      do m=i+1,j-1
8717 cgrad        do ll=1,3
8718 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8719 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8720 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8721 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8722 cgrad        enddo
8723 cgrad      enddo
8724 cgrad      do m=k+1,l-1
8725 cgrad        do ll=1,3
8726 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8727 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8728 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8729 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8730 cgrad        enddo
8731 cgrad      enddo
8732 c      write (iout,*) "ehbcorr",ekont*ees
8733 C      print *,ekont,ees,i,k
8734       ehbcorr=ekont*ees
8735 C now gradient over shielding
8736 C      return
8737       if (shield_mode.gt.0) then
8738        j=ees0plist(jj,i)
8739        l=ees0plist(kk,k)
8740 C        print *,i,j,fac_shield(i),fac_shield(j),
8741 C     &fac_shield(k),fac_shield(l)
8742         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8743      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8744           do ilist=1,ishield_list(i)
8745            iresshield=shield_list(ilist,i)
8746            do m=1,3
8747            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8748 C     &      *2.0
8749            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8750      &              rlocshield
8751      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8752             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8753      &+rlocshield
8754            enddo
8755           enddo
8756           do ilist=1,ishield_list(j)
8757            iresshield=shield_list(ilist,j)
8758            do m=1,3
8759            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8760 C     &     *2.0
8761            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8762      &              rlocshield
8763      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8764            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8765      &     +rlocshield
8766            enddo
8767           enddo
8768
8769           do ilist=1,ishield_list(k)
8770            iresshield=shield_list(ilist,k)
8771            do m=1,3
8772            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8773 C     &     *2.0
8774            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8775      &              rlocshield
8776      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8777            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8778      &     +rlocshield
8779            enddo
8780           enddo
8781           do ilist=1,ishield_list(l)
8782            iresshield=shield_list(ilist,l)
8783            do m=1,3
8784            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8785 C     &     *2.0
8786            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8787      &              rlocshield
8788      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8789            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8790      &     +rlocshield
8791            enddo
8792           enddo
8793 C          print *,gshieldx(m,iresshield)
8794           do m=1,3
8795             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8796      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8797             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8798      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8799             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8800      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8801             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8802      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8803
8804             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8805      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8806             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8807      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8808             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8809      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8810             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8811      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8812
8813            enddo
8814       endif
8815       endif
8816       return
8817       end
8818 #ifdef MOMENT
8819 C---------------------------------------------------------------------------
8820       subroutine dipole(i,j,jj)
8821       implicit real*8 (a-h,o-z)
8822       include 'DIMENSIONS'
8823       include 'COMMON.IOUNITS'
8824       include 'COMMON.CHAIN'
8825       include 'COMMON.FFIELD'
8826       include 'COMMON.DERIV'
8827       include 'COMMON.INTERACT'
8828       include 'COMMON.CONTACTS'
8829       include 'COMMON.TORSION'
8830       include 'COMMON.VAR'
8831       include 'COMMON.GEO'
8832       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8833      &  auxmat(2,2)
8834       iti1 = itortyp(itype(i+1))
8835       if (j.lt.nres-1) then
8836         itj1 = itortyp(itype(j+1))
8837       else
8838         itj1=ntortyp
8839       endif
8840       do iii=1,2
8841         dipi(iii,1)=Ub2(iii,i)
8842         dipderi(iii)=Ub2der(iii,i)
8843         dipi(iii,2)=b1(iii,i+1)
8844         dipj(iii,1)=Ub2(iii,j)
8845         dipderj(iii)=Ub2der(iii,j)
8846         dipj(iii,2)=b1(iii,j+1)
8847       enddo
8848       kkk=0
8849       do iii=1,2
8850         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8851         do jjj=1,2
8852           kkk=kkk+1
8853           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8854         enddo
8855       enddo
8856       do kkk=1,5
8857         do lll=1,3
8858           mmm=0
8859           do iii=1,2
8860             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8861      &        auxvec(1))
8862             do jjj=1,2
8863               mmm=mmm+1
8864               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8865             enddo
8866           enddo
8867         enddo
8868       enddo
8869       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8870       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8871       do iii=1,2
8872         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8873       enddo
8874       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8875       do iii=1,2
8876         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8877       enddo
8878       return
8879       end
8880 #endif
8881 C---------------------------------------------------------------------------
8882       subroutine calc_eello(i,j,k,l,jj,kk)
8883 C
8884 C This subroutine computes matrices and vectors needed to calculate
8885 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8886 C
8887       implicit real*8 (a-h,o-z)
8888       include 'DIMENSIONS'
8889       include 'COMMON.IOUNITS'
8890       include 'COMMON.CHAIN'
8891       include 'COMMON.DERIV'
8892       include 'COMMON.INTERACT'
8893       include 'COMMON.CONTACTS'
8894       include 'COMMON.TORSION'
8895       include 'COMMON.VAR'
8896       include 'COMMON.GEO'
8897       include 'COMMON.FFIELD'
8898       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8899      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8900       logical lprn
8901       common /kutas/ lprn
8902 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8903 cd     & ' jj=',jj,' kk=',kk
8904 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8905 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8906 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8907       do iii=1,2
8908         do jjj=1,2
8909           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8910           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8911         enddo
8912       enddo
8913       call transpose2(aa1(1,1),aa1t(1,1))
8914       call transpose2(aa2(1,1),aa2t(1,1))
8915       do kkk=1,5
8916         do lll=1,3
8917           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8918      &      aa1tder(1,1,lll,kkk))
8919           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8920      &      aa2tder(1,1,lll,kkk))
8921         enddo
8922       enddo
8923       if (l.eq.j+1) then
8924 C parallel orientation of the two CA-CA-CA frames.
8925         if (i.gt.1) then
8926           iti=itortyp(itype(i))
8927         else
8928           iti=ntortyp
8929         endif
8930         itk1=itortyp(itype(k+1))
8931         itj=itortyp(itype(j))
8932         if (l.lt.nres-1) then
8933           itl1=itortyp(itype(l+1))
8934         else
8935           itl1=ntortyp
8936         endif
8937 C A1 kernel(j+1) A2T
8938 cd        do iii=1,2
8939 cd          write (iout,'(3f10.5,5x,3f10.5)')
8940 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8941 cd        enddo
8942         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8943      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8944      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8945 C Following matrices are needed only for 6-th order cumulants
8946         IF (wcorr6.gt.0.0d0) THEN
8947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8948      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8949      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8950         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8951      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8952      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8953      &   ADtEAderx(1,1,1,1,1,1))
8954         lprn=.false.
8955         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8956      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8957      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8958      &   ADtEA1derx(1,1,1,1,1,1))
8959         ENDIF
8960 C End 6-th order cumulants
8961 cd        lprn=.false.
8962 cd        if (lprn) then
8963 cd        write (2,*) 'In calc_eello6'
8964 cd        do iii=1,2
8965 cd          write (2,*) 'iii=',iii
8966 cd          do kkk=1,5
8967 cd            write (2,*) 'kkk=',kkk
8968 cd            do jjj=1,2
8969 cd              write (2,'(3(2f10.5),5x)')
8970 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8971 cd            enddo
8972 cd          enddo
8973 cd        enddo
8974 cd        endif
8975         call transpose2(EUgder(1,1,k),auxmat(1,1))
8976         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8977         call transpose2(EUg(1,1,k),auxmat(1,1))
8978         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8979         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8980         do iii=1,2
8981           do kkk=1,5
8982             do lll=1,3
8983               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8984      &          EAEAderx(1,1,lll,kkk,iii,1))
8985             enddo
8986           enddo
8987         enddo
8988 C A1T kernel(i+1) A2
8989         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8990      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8991      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8992 C Following matrices are needed only for 6-th order cumulants
8993         IF (wcorr6.gt.0.0d0) THEN
8994         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8995      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8996      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8997         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8998      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8999      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9000      &   ADtEAderx(1,1,1,1,1,2))
9001         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9002      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9003      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9004      &   ADtEA1derx(1,1,1,1,1,2))
9005         ENDIF
9006 C End 6-th order cumulants
9007         call transpose2(EUgder(1,1,l),auxmat(1,1))
9008         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9009         call transpose2(EUg(1,1,l),auxmat(1,1))
9010         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9011         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9012         do iii=1,2
9013           do kkk=1,5
9014             do lll=1,3
9015               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9016      &          EAEAderx(1,1,lll,kkk,iii,2))
9017             enddo
9018           enddo
9019         enddo
9020 C AEAb1 and AEAb2
9021 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9022 C They are needed only when the fifth- or the sixth-order cumulants are
9023 C indluded.
9024         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9025         call transpose2(AEA(1,1,1),auxmat(1,1))
9026         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9027         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9028         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9029         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9030         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9031         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9032         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9033         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9034         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9035         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9036         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9037         call transpose2(AEA(1,1,2),auxmat(1,1))
9038         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9039         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9040         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9041         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9042         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9043         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9044         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9045         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9046         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9047         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9048         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9049 C Calculate the Cartesian derivatives of the vectors.
9050         do iii=1,2
9051           do kkk=1,5
9052             do lll=1,3
9053               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9054               call matvec2(auxmat(1,1),b1(1,i),
9055      &          AEAb1derx(1,lll,kkk,iii,1,1))
9056               call matvec2(auxmat(1,1),Ub2(1,i),
9057      &          AEAb2derx(1,lll,kkk,iii,1,1))
9058               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9059      &          AEAb1derx(1,lll,kkk,iii,2,1))
9060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9061      &          AEAb2derx(1,lll,kkk,iii,2,1))
9062               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9063               call matvec2(auxmat(1,1),b1(1,j),
9064      &          AEAb1derx(1,lll,kkk,iii,1,2))
9065               call matvec2(auxmat(1,1),Ub2(1,j),
9066      &          AEAb2derx(1,lll,kkk,iii,1,2))
9067               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9068      &          AEAb1derx(1,lll,kkk,iii,2,2))
9069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9070      &          AEAb2derx(1,lll,kkk,iii,2,2))
9071             enddo
9072           enddo
9073         enddo
9074         ENDIF
9075 C End vectors
9076       else
9077 C Antiparallel orientation of the two CA-CA-CA frames.
9078         if (i.gt.1) then
9079           iti=itortyp(itype(i))
9080         else
9081           iti=ntortyp
9082         endif
9083         itk1=itortyp(itype(k+1))
9084         itl=itortyp(itype(l))
9085         itj=itortyp(itype(j))
9086         if (j.lt.nres-1) then
9087           itj1=itortyp(itype(j+1))
9088         else
9089           itj1=ntortyp
9090         endif
9091 C A2 kernel(j-1)T A1T
9092         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9093      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9094      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9095 C Following matrices are needed only for 6-th order cumulants
9096         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9097      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9098         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9099      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9100      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9101         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9102      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9103      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9104      &   ADtEAderx(1,1,1,1,1,1))
9105         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9106      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9107      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9108      &   ADtEA1derx(1,1,1,1,1,1))
9109         ENDIF
9110 C End 6-th order cumulants
9111         call transpose2(EUgder(1,1,k),auxmat(1,1))
9112         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9113         call transpose2(EUg(1,1,k),auxmat(1,1))
9114         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9115         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9116         do iii=1,2
9117           do kkk=1,5
9118             do lll=1,3
9119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9120      &          EAEAderx(1,1,lll,kkk,iii,1))
9121             enddo
9122           enddo
9123         enddo
9124 C A2T kernel(i+1)T A1
9125         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9126      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9127      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9128 C Following matrices are needed only for 6-th order cumulants
9129         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9130      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9132      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9133      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9134         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9135      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9136      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9137      &   ADtEAderx(1,1,1,1,1,2))
9138         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9139      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9140      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9141      &   ADtEA1derx(1,1,1,1,1,2))
9142         ENDIF
9143 C End 6-th order cumulants
9144         call transpose2(EUgder(1,1,j),auxmat(1,1))
9145         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9146         call transpose2(EUg(1,1,j),auxmat(1,1))
9147         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9148         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9149         do iii=1,2
9150           do kkk=1,5
9151             do lll=1,3
9152               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9153      &          EAEAderx(1,1,lll,kkk,iii,2))
9154             enddo
9155           enddo
9156         enddo
9157 C AEAb1 and AEAb2
9158 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9159 C They are needed only when the fifth- or the sixth-order cumulants are
9160 C indluded.
9161         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9162      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9163         call transpose2(AEA(1,1,1),auxmat(1,1))
9164         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9165         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9166         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9167         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9168         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9169         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9170         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9171         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9172         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9173         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9174         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9175         call transpose2(AEA(1,1,2),auxmat(1,1))
9176         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9177         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9178         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9179         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9180         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9181         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9182         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9183         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9184         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9185         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9186         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9187 C Calculate the Cartesian derivatives of the vectors.
9188         do iii=1,2
9189           do kkk=1,5
9190             do lll=1,3
9191               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9192               call matvec2(auxmat(1,1),b1(1,i),
9193      &          AEAb1derx(1,lll,kkk,iii,1,1))
9194               call matvec2(auxmat(1,1),Ub2(1,i),
9195      &          AEAb2derx(1,lll,kkk,iii,1,1))
9196               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9197      &          AEAb1derx(1,lll,kkk,iii,2,1))
9198               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9199      &          AEAb2derx(1,lll,kkk,iii,2,1))
9200               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9201               call matvec2(auxmat(1,1),b1(1,l),
9202      &          AEAb1derx(1,lll,kkk,iii,1,2))
9203               call matvec2(auxmat(1,1),Ub2(1,l),
9204      &          AEAb2derx(1,lll,kkk,iii,1,2))
9205               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9206      &          AEAb1derx(1,lll,kkk,iii,2,2))
9207               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9208      &          AEAb2derx(1,lll,kkk,iii,2,2))
9209             enddo
9210           enddo
9211         enddo
9212         ENDIF
9213 C End vectors
9214       endif
9215       return
9216       end
9217 C---------------------------------------------------------------------------
9218       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9219      &  KK,KKderg,AKA,AKAderg,AKAderx)
9220       implicit none
9221       integer nderg
9222       logical transp
9223       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9224      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9225      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9226       integer iii,kkk,lll
9227       integer jjj,mmm
9228       logical lprn
9229       common /kutas/ lprn
9230       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9231       do iii=1,nderg
9232         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9233      &    AKAderg(1,1,iii))
9234       enddo
9235 cd      if (lprn) write (2,*) 'In kernel'
9236       do kkk=1,5
9237 cd        if (lprn) write (2,*) 'kkk=',kkk
9238         do lll=1,3
9239           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9240      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9241 cd          if (lprn) then
9242 cd            write (2,*) 'lll=',lll
9243 cd            write (2,*) 'iii=1'
9244 cd            do jjj=1,2
9245 cd              write (2,'(3(2f10.5),5x)')
9246 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9247 cd            enddo
9248 cd          endif
9249           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9250      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9251 cd          if (lprn) then
9252 cd            write (2,*) 'lll=',lll
9253 cd            write (2,*) 'iii=2'
9254 cd            do jjj=1,2
9255 cd              write (2,'(3(2f10.5),5x)')
9256 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9257 cd            enddo
9258 cd          endif
9259         enddo
9260       enddo
9261       return
9262       end
9263 C---------------------------------------------------------------------------
9264       double precision function eello4(i,j,k,l,jj,kk)
9265       implicit real*8 (a-h,o-z)
9266       include 'DIMENSIONS'
9267       include 'COMMON.IOUNITS'
9268       include 'COMMON.CHAIN'
9269       include 'COMMON.DERIV'
9270       include 'COMMON.INTERACT'
9271       include 'COMMON.CONTACTS'
9272       include 'COMMON.TORSION'
9273       include 'COMMON.VAR'
9274       include 'COMMON.GEO'
9275       double precision pizda(2,2),ggg1(3),ggg2(3)
9276 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9277 cd        eello4=0.0d0
9278 cd        return
9279 cd      endif
9280 cd      print *,'eello4:',i,j,k,l,jj,kk
9281 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9282 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9283 cold      eij=facont_hb(jj,i)
9284 cold      ekl=facont_hb(kk,k)
9285 cold      ekont=eij*ekl
9286       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9287 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9288       gcorr_loc(k-1)=gcorr_loc(k-1)
9289      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9290       if (l.eq.j+1) then
9291         gcorr_loc(l-1)=gcorr_loc(l-1)
9292      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9293       else
9294         gcorr_loc(j-1)=gcorr_loc(j-1)
9295      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9296       endif
9297       do iii=1,2
9298         do kkk=1,5
9299           do lll=1,3
9300             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9301      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9302 cd            derx(lll,kkk,iii)=0.0d0
9303           enddo
9304         enddo
9305       enddo
9306 cd      gcorr_loc(l-1)=0.0d0
9307 cd      gcorr_loc(j-1)=0.0d0
9308 cd      gcorr_loc(k-1)=0.0d0
9309 cd      eel4=1.0d0
9310 cd      write (iout,*)'Contacts have occurred for peptide groups',
9311 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9312 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9313       if (j.lt.nres-1) then
9314         j1=j+1
9315         j2=j-1
9316       else
9317         j1=j-1
9318         j2=j-2
9319       endif
9320       if (l.lt.nres-1) then
9321         l1=l+1
9322         l2=l-1
9323       else
9324         l1=l-1
9325         l2=l-2
9326       endif
9327       do ll=1,3
9328 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9329 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9330         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9331         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9332 cgrad        ghalf=0.5d0*ggg1(ll)
9333         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9334         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9335         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9336         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9337         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9338         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9339 cgrad        ghalf=0.5d0*ggg2(ll)
9340         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9341         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9342         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9343         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9344         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9345         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9346       enddo
9347 cgrad      do m=i+1,j-1
9348 cgrad        do ll=1,3
9349 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9350 cgrad        enddo
9351 cgrad      enddo
9352 cgrad      do m=k+1,l-1
9353 cgrad        do ll=1,3
9354 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9355 cgrad        enddo
9356 cgrad      enddo
9357 cgrad      do m=i+2,j2
9358 cgrad        do ll=1,3
9359 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9360 cgrad        enddo
9361 cgrad      enddo
9362 cgrad      do m=k+2,l2
9363 cgrad        do ll=1,3
9364 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9365 cgrad        enddo
9366 cgrad      enddo
9367 cd      do iii=1,nres-3
9368 cd        write (2,*) iii,gcorr_loc(iii)
9369 cd      enddo
9370       eello4=ekont*eel4
9371 cd      write (2,*) 'ekont',ekont
9372 cd      write (iout,*) 'eello4',ekont*eel4
9373       return
9374       end
9375 C---------------------------------------------------------------------------
9376       double precision function eello5(i,j,k,l,jj,kk)
9377       implicit real*8 (a-h,o-z)
9378       include 'DIMENSIONS'
9379       include 'COMMON.IOUNITS'
9380       include 'COMMON.CHAIN'
9381       include 'COMMON.DERIV'
9382       include 'COMMON.INTERACT'
9383       include 'COMMON.CONTACTS'
9384       include 'COMMON.TORSION'
9385       include 'COMMON.VAR'
9386       include 'COMMON.GEO'
9387       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9388       double precision ggg1(3),ggg2(3)
9389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9390 C                                                                              C
9391 C                            Parallel chains                                   C
9392 C                                                                              C
9393 C          o             o                   o             o                   C
9394 C         /l\           / \             \   / \           / \   /              C
9395 C        /   \         /   \             \ /   \         /   \ /               C
9396 C       j| o |l1       | o |              o| o |         | o |o                C
9397 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9398 C      \i/   \         /   \ /             /   \         /   \                 C
9399 C       o    k1             o                                                  C
9400 C         (I)          (II)                (III)          (IV)                 C
9401 C                                                                              C
9402 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9403 C                                                                              C
9404 C                            Antiparallel chains                               C
9405 C                                                                              C
9406 C          o             o                   o             o                   C
9407 C         /j\           / \             \   / \           / \   /              C
9408 C        /   \         /   \             \ /   \         /   \ /               C
9409 C      j1| o |l        | o |              o| o |         | o |o                C
9410 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9411 C      \i/   \         /   \ /             /   \         /   \                 C
9412 C       o     k1            o                                                  C
9413 C         (I)          (II)                (III)          (IV)                 C
9414 C                                                                              C
9415 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9416 C                                                                              C
9417 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9418 C                                                                              C
9419 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9420 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9421 cd        eello5=0.0d0
9422 cd        return
9423 cd      endif
9424 cd      write (iout,*)
9425 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9426 cd     &   ' and',k,l
9427       itk=itortyp(itype(k))
9428       itl=itortyp(itype(l))
9429       itj=itortyp(itype(j))
9430       eello5_1=0.0d0
9431       eello5_2=0.0d0
9432       eello5_3=0.0d0
9433       eello5_4=0.0d0
9434 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9435 cd     &   eel5_3_num,eel5_4_num)
9436       do iii=1,2
9437         do kkk=1,5
9438           do lll=1,3
9439             derx(lll,kkk,iii)=0.0d0
9440           enddo
9441         enddo
9442       enddo
9443 cd      eij=facont_hb(jj,i)
9444 cd      ekl=facont_hb(kk,k)
9445 cd      ekont=eij*ekl
9446 cd      write (iout,*)'Contacts have occurred for peptide groups',
9447 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9448 cd      goto 1111
9449 C Contribution from the graph I.
9450 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9451 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9452       call transpose2(EUg(1,1,k),auxmat(1,1))
9453       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9454       vv(1)=pizda(1,1)-pizda(2,2)
9455       vv(2)=pizda(1,2)+pizda(2,1)
9456       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9457      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9458 C Explicit gradient in virtual-dihedral angles.
9459       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9460      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9461      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9462       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9463       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9464       vv(1)=pizda(1,1)-pizda(2,2)
9465       vv(2)=pizda(1,2)+pizda(2,1)
9466       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9467      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9468      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9469       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9470       vv(1)=pizda(1,1)-pizda(2,2)
9471       vv(2)=pizda(1,2)+pizda(2,1)
9472       if (l.eq.j+1) then
9473         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9474      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9475      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9476       else
9477         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9478      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9479      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9480       endif
9481 C Cartesian gradient
9482       do iii=1,2
9483         do kkk=1,5
9484           do lll=1,3
9485             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9486      &        pizda(1,1))
9487             vv(1)=pizda(1,1)-pizda(2,2)
9488             vv(2)=pizda(1,2)+pizda(2,1)
9489             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9490      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9491      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9492           enddo
9493         enddo
9494       enddo
9495 c      goto 1112
9496 c1111  continue
9497 C Contribution from graph II
9498       call transpose2(EE(1,1,itk),auxmat(1,1))
9499       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9500       vv(1)=pizda(1,1)+pizda(2,2)
9501       vv(2)=pizda(2,1)-pizda(1,2)
9502       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9503      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9504 C Explicit gradient in virtual-dihedral angles.
9505       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9506      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9507       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9508       vv(1)=pizda(1,1)+pizda(2,2)
9509       vv(2)=pizda(2,1)-pizda(1,2)
9510       if (l.eq.j+1) then
9511         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9512      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9513      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9514       else
9515         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9516      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9517      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9518       endif
9519 C Cartesian gradient
9520       do iii=1,2
9521         do kkk=1,5
9522           do lll=1,3
9523             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9524      &        pizda(1,1))
9525             vv(1)=pizda(1,1)+pizda(2,2)
9526             vv(2)=pizda(2,1)-pizda(1,2)
9527             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9528      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9529      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9530           enddo
9531         enddo
9532       enddo
9533 cd      goto 1112
9534 cd1111  continue
9535       if (l.eq.j+1) then
9536 cd        goto 1110
9537 C Parallel orientation
9538 C Contribution from graph III
9539         call transpose2(EUg(1,1,l),auxmat(1,1))
9540         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9541         vv(1)=pizda(1,1)-pizda(2,2)
9542         vv(2)=pizda(1,2)+pizda(2,1)
9543         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9544      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9545 C Explicit gradient in virtual-dihedral angles.
9546         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9547      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9548      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9549         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9550         vv(1)=pizda(1,1)-pizda(2,2)
9551         vv(2)=pizda(1,2)+pizda(2,1)
9552         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9553      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9554      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9555         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9556         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9557         vv(1)=pizda(1,1)-pizda(2,2)
9558         vv(2)=pizda(1,2)+pizda(2,1)
9559         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9560      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9561      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9562 C Cartesian gradient
9563         do iii=1,2
9564           do kkk=1,5
9565             do lll=1,3
9566               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9567      &          pizda(1,1))
9568               vv(1)=pizda(1,1)-pizda(2,2)
9569               vv(2)=pizda(1,2)+pizda(2,1)
9570               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9571      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9572      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9573             enddo
9574           enddo
9575         enddo
9576 cd        goto 1112
9577 C Contribution from graph IV
9578 cd1110    continue
9579         call transpose2(EE(1,1,itl),auxmat(1,1))
9580         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9581         vv(1)=pizda(1,1)+pizda(2,2)
9582         vv(2)=pizda(2,1)-pizda(1,2)
9583         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9584      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9585 C Explicit gradient in virtual-dihedral angles.
9586         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9587      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9588         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9589         vv(1)=pizda(1,1)+pizda(2,2)
9590         vv(2)=pizda(2,1)-pizda(1,2)
9591         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9592      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9593      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9594 C Cartesian gradient
9595         do iii=1,2
9596           do kkk=1,5
9597             do lll=1,3
9598               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9599      &          pizda(1,1))
9600               vv(1)=pizda(1,1)+pizda(2,2)
9601               vv(2)=pizda(2,1)-pizda(1,2)
9602               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9603      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9604      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9605             enddo
9606           enddo
9607         enddo
9608       else
9609 C Antiparallel orientation
9610 C Contribution from graph III
9611 c        goto 1110
9612         call transpose2(EUg(1,1,j),auxmat(1,1))
9613         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9614         vv(1)=pizda(1,1)-pizda(2,2)
9615         vv(2)=pizda(1,2)+pizda(2,1)
9616         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9617      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9618 C Explicit gradient in virtual-dihedral angles.
9619         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9620      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9621      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9622         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9623         vv(1)=pizda(1,1)-pizda(2,2)
9624         vv(2)=pizda(1,2)+pizda(2,1)
9625         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9626      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9627      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9628         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9629         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9630         vv(1)=pizda(1,1)-pizda(2,2)
9631         vv(2)=pizda(1,2)+pizda(2,1)
9632         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9633      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9634      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9635 C Cartesian gradient
9636         do iii=1,2
9637           do kkk=1,5
9638             do lll=1,3
9639               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9640      &          pizda(1,1))
9641               vv(1)=pizda(1,1)-pizda(2,2)
9642               vv(2)=pizda(1,2)+pizda(2,1)
9643               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9644      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9645      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9646             enddo
9647           enddo
9648         enddo
9649 cd        goto 1112
9650 C Contribution from graph IV
9651 1110    continue
9652         call transpose2(EE(1,1,itj),auxmat(1,1))
9653         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9654         vv(1)=pizda(1,1)+pizda(2,2)
9655         vv(2)=pizda(2,1)-pizda(1,2)
9656         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9657      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9658 C Explicit gradient in virtual-dihedral angles.
9659         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9660      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9661         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9662         vv(1)=pizda(1,1)+pizda(2,2)
9663         vv(2)=pizda(2,1)-pizda(1,2)
9664         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9665      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9666      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9667 C Cartesian gradient
9668         do iii=1,2
9669           do kkk=1,5
9670             do lll=1,3
9671               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9672      &          pizda(1,1))
9673               vv(1)=pizda(1,1)+pizda(2,2)
9674               vv(2)=pizda(2,1)-pizda(1,2)
9675               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9676      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9677      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9678             enddo
9679           enddo
9680         enddo
9681       endif
9682 1112  continue
9683       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9684 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9685 cd        write (2,*) 'ijkl',i,j,k,l
9686 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9687 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9688 cd      endif
9689 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9690 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9691 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9692 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9693       if (j.lt.nres-1) then
9694         j1=j+1
9695         j2=j-1
9696       else
9697         j1=j-1
9698         j2=j-2
9699       endif
9700       if (l.lt.nres-1) then
9701         l1=l+1
9702         l2=l-1
9703       else
9704         l1=l-1
9705         l2=l-2
9706       endif
9707 cd      eij=1.0d0
9708 cd      ekl=1.0d0
9709 cd      ekont=1.0d0
9710 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9711 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9712 C        summed up outside the subrouine as for the other subroutines
9713 C        handling long-range interactions. The old code is commented out
9714 C        with "cgrad" to keep track of changes.
9715       do ll=1,3
9716 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9717 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9718         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9719         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9720 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9721 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9722 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9723 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9724 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9725 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9726 c     &   gradcorr5ij,
9727 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9728 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9729 cgrad        ghalf=0.5d0*ggg1(ll)
9730 cd        ghalf=0.0d0
9731         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9732         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9733         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9734         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9735         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9736         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9737 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9738 cgrad        ghalf=0.5d0*ggg2(ll)
9739 cd        ghalf=0.0d0
9740         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9741         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9742         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9743         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9744         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9745         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9746       enddo
9747 cd      goto 1112
9748 cgrad      do m=i+1,j-1
9749 cgrad        do ll=1,3
9750 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9751 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9752 cgrad        enddo
9753 cgrad      enddo
9754 cgrad      do m=k+1,l-1
9755 cgrad        do ll=1,3
9756 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9757 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9758 cgrad        enddo
9759 cgrad      enddo
9760 c1112  continue
9761 cgrad      do m=i+2,j2
9762 cgrad        do ll=1,3
9763 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9764 cgrad        enddo
9765 cgrad      enddo
9766 cgrad      do m=k+2,l2
9767 cgrad        do ll=1,3
9768 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9769 cgrad        enddo
9770 cgrad      enddo
9771 cd      do iii=1,nres-3
9772 cd        write (2,*) iii,g_corr5_loc(iii)
9773 cd      enddo
9774       eello5=ekont*eel5
9775 cd      write (2,*) 'ekont',ekont
9776 cd      write (iout,*) 'eello5',ekont*eel5
9777       return
9778       end
9779 c--------------------------------------------------------------------------
9780       double precision function eello6(i,j,k,l,jj,kk)
9781       implicit real*8 (a-h,o-z)
9782       include 'DIMENSIONS'
9783       include 'COMMON.IOUNITS'
9784       include 'COMMON.CHAIN'
9785       include 'COMMON.DERIV'
9786       include 'COMMON.INTERACT'
9787       include 'COMMON.CONTACTS'
9788       include 'COMMON.TORSION'
9789       include 'COMMON.VAR'
9790       include 'COMMON.GEO'
9791       include 'COMMON.FFIELD'
9792       double precision ggg1(3),ggg2(3)
9793 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9794 cd        eello6=0.0d0
9795 cd        return
9796 cd      endif
9797 cd      write (iout,*)
9798 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9799 cd     &   ' and',k,l
9800       eello6_1=0.0d0
9801       eello6_2=0.0d0
9802       eello6_3=0.0d0
9803       eello6_4=0.0d0
9804       eello6_5=0.0d0
9805       eello6_6=0.0d0
9806 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9807 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9808       do iii=1,2
9809         do kkk=1,5
9810           do lll=1,3
9811             derx(lll,kkk,iii)=0.0d0
9812           enddo
9813         enddo
9814       enddo
9815 cd      eij=facont_hb(jj,i)
9816 cd      ekl=facont_hb(kk,k)
9817 cd      ekont=eij*ekl
9818 cd      eij=1.0d0
9819 cd      ekl=1.0d0
9820 cd      ekont=1.0d0
9821       if (l.eq.j+1) then
9822         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9823         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9824         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9825         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9826         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9827         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9828       else
9829         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9830         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9831         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9832         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9833         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9834           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9835         else
9836           eello6_5=0.0d0
9837         endif
9838         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9839       endif
9840 C If turn contributions are considered, they will be handled separately.
9841       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9842 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9843 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9844 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9845 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9846 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9847 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9848 cd      goto 1112
9849       if (j.lt.nres-1) then
9850         j1=j+1
9851         j2=j-1
9852       else
9853         j1=j-1
9854         j2=j-2
9855       endif
9856       if (l.lt.nres-1) then
9857         l1=l+1
9858         l2=l-1
9859       else
9860         l1=l-1
9861         l2=l-2
9862       endif
9863       do ll=1,3
9864 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9865 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9866 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9867 cgrad        ghalf=0.5d0*ggg1(ll)
9868 cd        ghalf=0.0d0
9869         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9870         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9871         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9872         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9873         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9874         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9875         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9876         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9877 cgrad        ghalf=0.5d0*ggg2(ll)
9878 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9879 cd        ghalf=0.0d0
9880         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9881         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9882         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9883         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9884         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9885         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9886       enddo
9887 cd      goto 1112
9888 cgrad      do m=i+1,j-1
9889 cgrad        do ll=1,3
9890 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9891 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9892 cgrad        enddo
9893 cgrad      enddo
9894 cgrad      do m=k+1,l-1
9895 cgrad        do ll=1,3
9896 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9897 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9898 cgrad        enddo
9899 cgrad      enddo
9900 cgrad1112  continue
9901 cgrad      do m=i+2,j2
9902 cgrad        do ll=1,3
9903 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9904 cgrad        enddo
9905 cgrad      enddo
9906 cgrad      do m=k+2,l2
9907 cgrad        do ll=1,3
9908 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9909 cgrad        enddo
9910 cgrad      enddo
9911 cd      do iii=1,nres-3
9912 cd        write (2,*) iii,g_corr6_loc(iii)
9913 cd      enddo
9914       eello6=ekont*eel6
9915 cd      write (2,*) 'ekont',ekont
9916 cd      write (iout,*) 'eello6',ekont*eel6
9917       return
9918       end
9919 c--------------------------------------------------------------------------
9920       double precision function eello6_graph1(i,j,k,l,imat,swap)
9921       implicit real*8 (a-h,o-z)
9922       include 'DIMENSIONS'
9923       include 'COMMON.IOUNITS'
9924       include 'COMMON.CHAIN'
9925       include 'COMMON.DERIV'
9926       include 'COMMON.INTERACT'
9927       include 'COMMON.CONTACTS'
9928       include 'COMMON.TORSION'
9929       include 'COMMON.VAR'
9930       include 'COMMON.GEO'
9931       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9932       logical swap
9933       logical lprn
9934       common /kutas/ lprn
9935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9936 C                                                                              C
9937 C      Parallel       Antiparallel                                             C
9938 C                                                                              C
9939 C          o             o                                                     C
9940 C         /l\           /j\                                                    C
9941 C        /   \         /   \                                                   C
9942 C       /| o |         | o |\                                                  C
9943 C     \ j|/k\|  /   \  |/k\|l /                                                C
9944 C      \ /   \ /     \ /   \ /                                                 C
9945 C       o     o       o     o                                                  C
9946 C       i             i                                                        C
9947 C                                                                              C
9948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9949       itk=itortyp(itype(k))
9950       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9951       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9952       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9953       call transpose2(EUgC(1,1,k),auxmat(1,1))
9954       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9955       vv1(1)=pizda1(1,1)-pizda1(2,2)
9956       vv1(2)=pizda1(1,2)+pizda1(2,1)
9957       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9958       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9959       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9960       s5=scalar2(vv(1),Dtobr2(1,i))
9961 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9962       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9963       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9964      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9965      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9966      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9967      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9968      & +scalar2(vv(1),Dtobr2der(1,i)))
9969       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9970       vv1(1)=pizda1(1,1)-pizda1(2,2)
9971       vv1(2)=pizda1(1,2)+pizda1(2,1)
9972       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9973       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9974       if (l.eq.j+1) then
9975         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9976      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9977      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9978      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9979      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9980       else
9981         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9982      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9983      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9984      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9985      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9986       endif
9987       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9988       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9989       vv1(1)=pizda1(1,1)-pizda1(2,2)
9990       vv1(2)=pizda1(1,2)+pizda1(2,1)
9991       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9992      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9993      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9994      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9995       do iii=1,2
9996         if (swap) then
9997           ind=3-iii
9998         else
9999           ind=iii
10000         endif
10001         do kkk=1,5
10002           do lll=1,3
10003             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10004             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10005             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10006             call transpose2(EUgC(1,1,k),auxmat(1,1))
10007             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10008      &        pizda1(1,1))
10009             vv1(1)=pizda1(1,1)-pizda1(2,2)
10010             vv1(2)=pizda1(1,2)+pizda1(2,1)
10011             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10012             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10013      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10014             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10015      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10016             s5=scalar2(vv(1),Dtobr2(1,i))
10017             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10018           enddo
10019         enddo
10020       enddo
10021       return
10022       end
10023 c----------------------------------------------------------------------------
10024       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10025       implicit real*8 (a-h,o-z)
10026       include 'DIMENSIONS'
10027       include 'COMMON.IOUNITS'
10028       include 'COMMON.CHAIN'
10029       include 'COMMON.DERIV'
10030       include 'COMMON.INTERACT'
10031       include 'COMMON.CONTACTS'
10032       include 'COMMON.TORSION'
10033       include 'COMMON.VAR'
10034       include 'COMMON.GEO'
10035       logical swap
10036       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10037      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10038       logical lprn
10039       common /kutas/ lprn
10040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10041 C                                                                              C
10042 C      Parallel       Antiparallel                                             C
10043 C                                                                              C
10044 C          o             o                                                     C
10045 C     \   /l\           /j\   /                                                C
10046 C      \ /   \         /   \ /                                                 C
10047 C       o| o |         | o |o                                                  C
10048 C     \ j|/k\|      \  |/k\|l                                                  C
10049 C      \ /   \       \ /   \                                                   C
10050 C       o             o                                                        C
10051 C       i             i                                                        C
10052 C                                                                              C
10053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10054 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10055 C AL 7/4/01 s1 would occur in the sixth-order moment,
10056 C           but not in a cluster cumulant
10057 #ifdef MOMENT
10058       s1=dip(1,jj,i)*dip(1,kk,k)
10059 #endif
10060       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10061       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10062       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10063       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10064       call transpose2(EUg(1,1,k),auxmat(1,1))
10065       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10066       vv(1)=pizda(1,1)-pizda(2,2)
10067       vv(2)=pizda(1,2)+pizda(2,1)
10068       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10069 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10070 #ifdef MOMENT
10071       eello6_graph2=-(s1+s2+s3+s4)
10072 #else
10073       eello6_graph2=-(s2+s3+s4)
10074 #endif
10075 c      eello6_graph2=-s3
10076 C Derivatives in gamma(i-1)
10077       if (i.gt.1) then
10078 #ifdef MOMENT
10079         s1=dipderg(1,jj,i)*dip(1,kk,k)
10080 #endif
10081         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10082         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10083         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10084         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10085 #ifdef MOMENT
10086         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10087 #else
10088         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10089 #endif
10090 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10091       endif
10092 C Derivatives in gamma(k-1)
10093 #ifdef MOMENT
10094       s1=dip(1,jj,i)*dipderg(1,kk,k)
10095 #endif
10096       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10097       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10098       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10099       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10100       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10101       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10102       vv(1)=pizda(1,1)-pizda(2,2)
10103       vv(2)=pizda(1,2)+pizda(2,1)
10104       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10105 #ifdef MOMENT
10106       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10107 #else
10108       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10109 #endif
10110 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10111 C Derivatives in gamma(j-1) or gamma(l-1)
10112       if (j.gt.1) then
10113 #ifdef MOMENT
10114         s1=dipderg(3,jj,i)*dip(1,kk,k)
10115 #endif
10116         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10117         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10118         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10119         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10120         vv(1)=pizda(1,1)-pizda(2,2)
10121         vv(2)=pizda(1,2)+pizda(2,1)
10122         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10123 #ifdef MOMENT
10124         if (swap) then
10125           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10126         else
10127           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10128         endif
10129 #endif
10130         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10131 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10132       endif
10133 C Derivatives in gamma(l-1) or gamma(j-1)
10134       if (l.gt.1) then
10135 #ifdef MOMENT
10136         s1=dip(1,jj,i)*dipderg(3,kk,k)
10137 #endif
10138         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10139         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10140         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10141         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10142         call matmat2(ADtEA1derg(1,1,2,1),auxmat(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         if (swap) then
10148           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10149         else
10150           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10151         endif
10152 #endif
10153         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10154 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10155       endif
10156 C Cartesian derivatives.
10157       if (lprn) then
10158         write (2,*) 'In eello6_graph2'
10159         do iii=1,2
10160           write (2,*) 'iii=',iii
10161           do kkk=1,5
10162             write (2,*) 'kkk=',kkk
10163             do jjj=1,2
10164               write (2,'(3(2f10.5),5x)')
10165      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10166             enddo
10167           enddo
10168         enddo
10169       endif
10170       do iii=1,2
10171         do kkk=1,5
10172           do lll=1,3
10173 #ifdef MOMENT
10174             if (iii.eq.1) then
10175               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10176             else
10177               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10178             endif
10179 #endif
10180             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10181      &        auxvec(1))
10182             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10183             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10184      &        auxvec(1))
10185             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10186             call transpose2(EUg(1,1,k),auxmat(1,1))
10187             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10188      &        pizda(1,1))
10189             vv(1)=pizda(1,1)-pizda(2,2)
10190             vv(2)=pizda(1,2)+pizda(2,1)
10191             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10192 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10193 #ifdef MOMENT
10194             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10195 #else
10196             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10197 #endif
10198             if (swap) then
10199               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10200             else
10201               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10202             endif
10203           enddo
10204         enddo
10205       enddo
10206       return
10207       end
10208 c----------------------------------------------------------------------------
10209       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10210       implicit real*8 (a-h,o-z)
10211       include 'DIMENSIONS'
10212       include 'COMMON.IOUNITS'
10213       include 'COMMON.CHAIN'
10214       include 'COMMON.DERIV'
10215       include 'COMMON.INTERACT'
10216       include 'COMMON.CONTACTS'
10217       include 'COMMON.TORSION'
10218       include 'COMMON.VAR'
10219       include 'COMMON.GEO'
10220       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10221       logical swap
10222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10223 C                                                                              C
10224 C      Parallel       Antiparallel                                             C
10225 C                                                                              C
10226 C          o             o                                                     C
10227 C         /l\   /   \   /j\                                                    C
10228 C        /   \ /     \ /   \                                                   C
10229 C       /| o |o       o| o |\                                                  C
10230 C       j|/k\|  /      |/k\|l /                                                C
10231 C        /   \ /       /   \ /                                                 C
10232 C       /     o       /     o                                                  C
10233 C       i             i                                                        C
10234 C                                                                              C
10235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10236 C
10237 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10238 C           energy moment and not to the cluster cumulant.
10239       iti=itortyp(itype(i))
10240       if (j.lt.nres-1) then
10241         itj1=itortyp(itype(j+1))
10242       else
10243         itj1=ntortyp
10244       endif
10245       itk=itortyp(itype(k))
10246       itk1=itortyp(itype(k+1))
10247       if (l.lt.nres-1) then
10248         itl1=itortyp(itype(l+1))
10249       else
10250         itl1=ntortyp
10251       endif
10252 #ifdef MOMENT
10253       s1=dip(4,jj,i)*dip(4,kk,k)
10254 #endif
10255       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10256       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10257       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10258       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10259       call transpose2(EE(1,1,itk),auxmat(1,1))
10260       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10261       vv(1)=pizda(1,1)+pizda(2,2)
10262       vv(2)=pizda(2,1)-pizda(1,2)
10263       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10264 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10265 cd     & "sum",-(s2+s3+s4)
10266 #ifdef MOMENT
10267       eello6_graph3=-(s1+s2+s3+s4)
10268 #else
10269       eello6_graph3=-(s2+s3+s4)
10270 #endif
10271 c      eello6_graph3=-s4
10272 C Derivatives in gamma(k-1)
10273       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10274       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10275       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10276       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10277 C Derivatives in gamma(l-1)
10278       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10279       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10280       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10281       vv(1)=pizda(1,1)+pizda(2,2)
10282       vv(2)=pizda(2,1)-pizda(1,2)
10283       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10284       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10285 C Cartesian derivatives.
10286       do iii=1,2
10287         do kkk=1,5
10288           do lll=1,3
10289 #ifdef MOMENT
10290             if (iii.eq.1) then
10291               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10292             else
10293               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10294             endif
10295 #endif
10296             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10297      &        auxvec(1))
10298             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10299             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10300      &        auxvec(1))
10301             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10302             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10303      &        pizda(1,1))
10304             vv(1)=pizda(1,1)+pizda(2,2)
10305             vv(2)=pizda(2,1)-pizda(1,2)
10306             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10307 #ifdef MOMENT
10308             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10309 #else
10310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10311 #endif
10312             if (swap) then
10313               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10314             else
10315               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10316             endif
10317 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10318           enddo
10319         enddo
10320       enddo
10321       return
10322       end
10323 c----------------------------------------------------------------------------
10324       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10325       implicit real*8 (a-h,o-z)
10326       include 'DIMENSIONS'
10327       include 'COMMON.IOUNITS'
10328       include 'COMMON.CHAIN'
10329       include 'COMMON.DERIV'
10330       include 'COMMON.INTERACT'
10331       include 'COMMON.CONTACTS'
10332       include 'COMMON.TORSION'
10333       include 'COMMON.VAR'
10334       include 'COMMON.GEO'
10335       include 'COMMON.FFIELD'
10336       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10337      & auxvec1(2),auxmat1(2,2)
10338       logical swap
10339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10340 C                                                                              C
10341 C      Parallel       Antiparallel                                             C
10342 C                                                                              C
10343 C          o             o                                                     C
10344 C         /l\   /   \   /j\                                                    C
10345 C        /   \ /     \ /   \                                                   C
10346 C       /| o |o       o| o |\                                                  C
10347 C     \ j|/k\|      \  |/k\|l                                                  C
10348 C      \ /   \       \ /   \                                                   C
10349 C       o     \       o     \                                                  C
10350 C       i             i                                                        C
10351 C                                                                              C
10352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10353 C
10354 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10355 C           energy moment and not to the cluster cumulant.
10356 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10357       iti=itortyp(itype(i))
10358       itj=itortyp(itype(j))
10359       if (j.lt.nres-1) then
10360         itj1=itortyp(itype(j+1))
10361       else
10362         itj1=ntortyp
10363       endif
10364       itk=itortyp(itype(k))
10365       if (k.lt.nres-1) then
10366         itk1=itortyp(itype(k+1))
10367       else
10368         itk1=ntortyp
10369       endif
10370       itl=itortyp(itype(l))
10371       if (l.lt.nres-1) then
10372         itl1=itortyp(itype(l+1))
10373       else
10374         itl1=ntortyp
10375       endif
10376 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10377 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10378 cd     & ' itl',itl,' itl1',itl1
10379 #ifdef MOMENT
10380       if (imat.eq.1) then
10381         s1=dip(3,jj,i)*dip(3,kk,k)
10382       else
10383         s1=dip(2,jj,j)*dip(2,kk,l)
10384       endif
10385 #endif
10386       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10387       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10388       if (j.eq.l+1) then
10389         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10390         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10391       else
10392         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10393         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10394       endif
10395       call transpose2(EUg(1,1,k),auxmat(1,1))
10396       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10397       vv(1)=pizda(1,1)-pizda(2,2)
10398       vv(2)=pizda(2,1)+pizda(1,2)
10399       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10400 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10401 #ifdef MOMENT
10402       eello6_graph4=-(s1+s2+s3+s4)
10403 #else
10404       eello6_graph4=-(s2+s3+s4)
10405 #endif
10406 C Derivatives in gamma(i-1)
10407       if (i.gt.1) then
10408 #ifdef MOMENT
10409         if (imat.eq.1) then
10410           s1=dipderg(2,jj,i)*dip(3,kk,k)
10411         else
10412           s1=dipderg(4,jj,j)*dip(2,kk,l)
10413         endif
10414 #endif
10415         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10416         if (j.eq.l+1) then
10417           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10418           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10419         else
10420           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10421           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10422         endif
10423         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10424         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10425 cd          write (2,*) 'turn6 derivatives'
10426 #ifdef MOMENT
10427           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10428 #else
10429           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10430 #endif
10431         else
10432 #ifdef MOMENT
10433           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10434 #else
10435           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10436 #endif
10437         endif
10438       endif
10439 C Derivatives in gamma(k-1)
10440 #ifdef MOMENT
10441       if (imat.eq.1) then
10442         s1=dip(3,jj,i)*dipderg(2,kk,k)
10443       else
10444         s1=dip(2,jj,j)*dipderg(4,kk,l)
10445       endif
10446 #endif
10447       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10448       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10449       if (j.eq.l+1) then
10450         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10451         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10452       else
10453         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10454         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10455       endif
10456       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10457       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10458       vv(1)=pizda(1,1)-pizda(2,2)
10459       vv(2)=pizda(2,1)+pizda(1,2)
10460       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10461       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10462 #ifdef MOMENT
10463         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10464 #else
10465         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10466 #endif
10467       else
10468 #ifdef MOMENT
10469         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10470 #else
10471         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10472 #endif
10473       endif
10474 C Derivatives in gamma(j-1) or gamma(l-1)
10475       if (l.eq.j+1 .and. l.gt.1) then
10476         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10477         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10478         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10479         vv(1)=pizda(1,1)-pizda(2,2)
10480         vv(2)=pizda(2,1)+pizda(1,2)
10481         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10482         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10483       else if (j.gt.1) then
10484         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10485         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10486         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10487         vv(1)=pizda(1,1)-pizda(2,2)
10488         vv(2)=pizda(2,1)+pizda(1,2)
10489         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10490         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10491           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10492         else
10493           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10494         endif
10495       endif
10496 C Cartesian derivatives.
10497       do iii=1,2
10498         do kkk=1,5
10499           do lll=1,3
10500 #ifdef MOMENT
10501             if (iii.eq.1) then
10502               if (imat.eq.1) then
10503                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10504               else
10505                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10506               endif
10507             else
10508               if (imat.eq.1) then
10509                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10510               else
10511                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10512               endif
10513             endif
10514 #endif
10515             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10516      &        auxvec(1))
10517             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10518             if (j.eq.l+1) then
10519               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10520      &          b1(1,j+1),auxvec(1))
10521               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10522             else
10523               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10524      &          b1(1,l+1),auxvec(1))
10525               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10526             endif
10527             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10528      &        pizda(1,1))
10529             vv(1)=pizda(1,1)-pizda(2,2)
10530             vv(2)=pizda(2,1)+pizda(1,2)
10531             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10532             if (swap) then
10533               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10534 #ifdef MOMENT
10535                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10536      &             -(s1+s2+s4)
10537 #else
10538                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10539      &             -(s2+s4)
10540 #endif
10541                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10542               else
10543 #ifdef MOMENT
10544                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10545 #else
10546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10547 #endif
10548                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10549               endif
10550             else
10551 #ifdef MOMENT
10552               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10553 #else
10554               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10555 #endif
10556               if (l.eq.j+1) then
10557                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10558               else
10559                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10560               endif
10561             endif
10562           enddo
10563         enddo
10564       enddo
10565       return
10566       end
10567 c----------------------------------------------------------------------------
10568       double precision function eello_turn6(i,jj,kk)
10569       implicit real*8 (a-h,o-z)
10570       include 'DIMENSIONS'
10571       include 'COMMON.IOUNITS'
10572       include 'COMMON.CHAIN'
10573       include 'COMMON.DERIV'
10574       include 'COMMON.INTERACT'
10575       include 'COMMON.CONTACTS'
10576       include 'COMMON.TORSION'
10577       include 'COMMON.VAR'
10578       include 'COMMON.GEO'
10579       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10580      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10581      &  ggg1(3),ggg2(3)
10582       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10583      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10584 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10585 C           the respective energy moment and not to the cluster cumulant.
10586       s1=0.0d0
10587       s8=0.0d0
10588       s13=0.0d0
10589 c
10590       eello_turn6=0.0d0
10591       j=i+4
10592       k=i+1
10593       l=i+3
10594       iti=itortyp(itype(i))
10595       itk=itortyp(itype(k))
10596       itk1=itortyp(itype(k+1))
10597       itl=itortyp(itype(l))
10598       itj=itortyp(itype(j))
10599 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10600 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10601 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10602 cd        eello6=0.0d0
10603 cd        return
10604 cd      endif
10605 cd      write (iout,*)
10606 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10607 cd     &   ' and',k,l
10608 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10609       do iii=1,2
10610         do kkk=1,5
10611           do lll=1,3
10612             derx_turn(lll,kkk,iii)=0.0d0
10613           enddo
10614         enddo
10615       enddo
10616 cd      eij=1.0d0
10617 cd      ekl=1.0d0
10618 cd      ekont=1.0d0
10619       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10620 cd      eello6_5=0.0d0
10621 cd      write (2,*) 'eello6_5',eello6_5
10622 #ifdef MOMENT
10623       call transpose2(AEA(1,1,1),auxmat(1,1))
10624       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10625       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10626       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10627 #endif
10628       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10629       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10630       s2 = scalar2(b1(1,k),vtemp1(1))
10631 #ifdef MOMENT
10632       call transpose2(AEA(1,1,2),atemp(1,1))
10633       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10634       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10635       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10636 #endif
10637       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10638       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10639       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10640 #ifdef MOMENT
10641       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10642       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10643       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10644       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10645       ss13 = scalar2(b1(1,k),vtemp4(1))
10646       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10647 #endif
10648 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10649 c      s1=0.0d0
10650 c      s2=0.0d0
10651 c      s8=0.0d0
10652 c      s12=0.0d0
10653 c      s13=0.0d0
10654       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10655 C Derivatives in gamma(i+2)
10656       s1d =0.0d0
10657       s8d =0.0d0
10658 #ifdef MOMENT
10659       call transpose2(AEA(1,1,1),auxmatd(1,1))
10660       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10661       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10662       call transpose2(AEAderg(1,1,2),atempd(1,1))
10663       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10664       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10665 #endif
10666       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10667       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10668       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10669 c      s1d=0.0d0
10670 c      s2d=0.0d0
10671 c      s8d=0.0d0
10672 c      s12d=0.0d0
10673 c      s13d=0.0d0
10674       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10675 C Derivatives in gamma(i+3)
10676 #ifdef MOMENT
10677       call transpose2(AEA(1,1,1),auxmatd(1,1))
10678       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10679       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10680       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10681 #endif
10682       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10683       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10684       s2d = scalar2(b1(1,k),vtemp1d(1))
10685 #ifdef MOMENT
10686       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10687       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10688 #endif
10689       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10690 #ifdef MOMENT
10691       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10692       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10693       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10694 #endif
10695 c      s1d=0.0d0
10696 c      s2d=0.0d0
10697 c      s8d=0.0d0
10698 c      s12d=0.0d0
10699 c      s13d=0.0d0
10700 #ifdef MOMENT
10701       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10702      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10703 #else
10704       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10705      &               -0.5d0*ekont*(s2d+s12d)
10706 #endif
10707 C Derivatives in gamma(i+4)
10708       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10709       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10710       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10711 #ifdef MOMENT
10712       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10713       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10714       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10715 #endif
10716 c      s1d=0.0d0
10717 c      s2d=0.0d0
10718 c      s8d=0.0d0
10719 C      s12d=0.0d0
10720 c      s13d=0.0d0
10721 #ifdef MOMENT
10722       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10723 #else
10724       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10725 #endif
10726 C Derivatives in gamma(i+5)
10727 #ifdef MOMENT
10728       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10729       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10730       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10731 #endif
10732       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10733       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10734       s2d = scalar2(b1(1,k),vtemp1d(1))
10735 #ifdef MOMENT
10736       call transpose2(AEA(1,1,2),atempd(1,1))
10737       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10738       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10739 #endif
10740       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10741       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10742 #ifdef MOMENT
10743       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10744       ss13d = scalar2(b1(1,k),vtemp4d(1))
10745       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10746 #endif
10747 c      s1d=0.0d0
10748 c      s2d=0.0d0
10749 c      s8d=0.0d0
10750 c      s12d=0.0d0
10751 c      s13d=0.0d0
10752 #ifdef MOMENT
10753       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10754      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10755 #else
10756       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10757      &               -0.5d0*ekont*(s2d+s12d)
10758 #endif
10759 C Cartesian derivatives
10760       do iii=1,2
10761         do kkk=1,5
10762           do lll=1,3
10763 #ifdef MOMENT
10764             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10765             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10766             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10767 #endif
10768             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10769             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10770      &          vtemp1d(1))
10771             s2d = scalar2(b1(1,k),vtemp1d(1))
10772 #ifdef MOMENT
10773             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10774             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10775             s8d = -(atempd(1,1)+atempd(2,2))*
10776      &           scalar2(cc(1,1,itl),vtemp2(1))
10777 #endif
10778             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10779      &           auxmatd(1,1))
10780             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10781             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10782 c      s1d=0.0d0
10783 c      s2d=0.0d0
10784 c      s8d=0.0d0
10785 c      s12d=0.0d0
10786 c      s13d=0.0d0
10787 #ifdef MOMENT
10788             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10789      &        - 0.5d0*(s1d+s2d)
10790 #else
10791             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10792      &        - 0.5d0*s2d
10793 #endif
10794 #ifdef MOMENT
10795             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10796      &        - 0.5d0*(s8d+s12d)
10797 #else
10798             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10799      &        - 0.5d0*s12d
10800 #endif
10801           enddo
10802         enddo
10803       enddo
10804 #ifdef MOMENT
10805       do kkk=1,5
10806         do lll=1,3
10807           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10808      &      achuj_tempd(1,1))
10809           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10810           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10811           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10812           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10813           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10814      &      vtemp4d(1))
10815           ss13d = scalar2(b1(1,k),vtemp4d(1))
10816           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10817           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10818         enddo
10819       enddo
10820 #endif
10821 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10822 cd     &  16*eel_turn6_num
10823 cd      goto 1112
10824       if (j.lt.nres-1) then
10825         j1=j+1
10826         j2=j-1
10827       else
10828         j1=j-1
10829         j2=j-2
10830       endif
10831       if (l.lt.nres-1) then
10832         l1=l+1
10833         l2=l-1
10834       else
10835         l1=l-1
10836         l2=l-2
10837       endif
10838       do ll=1,3
10839 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10840 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10841 cgrad        ghalf=0.5d0*ggg1(ll)
10842 cd        ghalf=0.0d0
10843         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10844         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10845         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10846      &    +ekont*derx_turn(ll,2,1)
10847         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10848         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10849      &    +ekont*derx_turn(ll,4,1)
10850         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10851         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10852         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10853 cgrad        ghalf=0.5d0*ggg2(ll)
10854 cd        ghalf=0.0d0
10855         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10856      &    +ekont*derx_turn(ll,2,2)
10857         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10858         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10859      &    +ekont*derx_turn(ll,4,2)
10860         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10861         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10862         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10863       enddo
10864 cd      goto 1112
10865 cgrad      do m=i+1,j-1
10866 cgrad        do ll=1,3
10867 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10868 cgrad        enddo
10869 cgrad      enddo
10870 cgrad      do m=k+1,l-1
10871 cgrad        do ll=1,3
10872 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10873 cgrad        enddo
10874 cgrad      enddo
10875 cgrad1112  continue
10876 cgrad      do m=i+2,j2
10877 cgrad        do ll=1,3
10878 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10879 cgrad        enddo
10880 cgrad      enddo
10881 cgrad      do m=k+2,l2
10882 cgrad        do ll=1,3
10883 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10884 cgrad        enddo
10885 cgrad      enddo
10886 cd      do iii=1,nres-3
10887 cd        write (2,*) iii,g_corr6_loc(iii)
10888 cd      enddo
10889       eello_turn6=ekont*eel_turn6
10890 cd      write (2,*) 'ekont',ekont
10891 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10892       return
10893       end
10894
10895 C-----------------------------------------------------------------------------
10896       double precision function scalar(u,v)
10897 !DIR$ INLINEALWAYS scalar
10898 #ifndef OSF
10899 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10900 #endif
10901       implicit none
10902       double precision u(3),v(3)
10903 cd      double precision sc
10904 cd      integer i
10905 cd      sc=0.0d0
10906 cd      do i=1,3
10907 cd        sc=sc+u(i)*v(i)
10908 cd      enddo
10909 cd      scalar=sc
10910
10911       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10912       return
10913       end
10914 crc-------------------------------------------------
10915       SUBROUTINE MATVEC2(A1,V1,V2)
10916 !DIR$ INLINEALWAYS MATVEC2
10917 #ifndef OSF
10918 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10919 #endif
10920       implicit real*8 (a-h,o-z)
10921       include 'DIMENSIONS'
10922       DIMENSION A1(2,2),V1(2),V2(2)
10923 c      DO 1 I=1,2
10924 c        VI=0.0
10925 c        DO 3 K=1,2
10926 c    3     VI=VI+A1(I,K)*V1(K)
10927 c        Vaux(I)=VI
10928 c    1 CONTINUE
10929
10930       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10931       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10932
10933       v2(1)=vaux1
10934       v2(2)=vaux2
10935       END
10936 C---------------------------------------
10937       SUBROUTINE MATMAT2(A1,A2,A3)
10938 #ifndef OSF
10939 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10940 #endif
10941       implicit real*8 (a-h,o-z)
10942       include 'DIMENSIONS'
10943       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10944 c      DIMENSION AI3(2,2)
10945 c        DO  J=1,2
10946 c          A3IJ=0.0
10947 c          DO K=1,2
10948 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10949 c          enddo
10950 c          A3(I,J)=A3IJ
10951 c       enddo
10952 c      enddo
10953
10954       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10955       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10956       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10957       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10958
10959       A3(1,1)=AI3_11
10960       A3(2,1)=AI3_21
10961       A3(1,2)=AI3_12
10962       A3(2,2)=AI3_22
10963       END
10964
10965 c-------------------------------------------------------------------------
10966       double precision function scalar2(u,v)
10967 !DIR$ INLINEALWAYS scalar2
10968       implicit none
10969       double precision u(2),v(2)
10970       double precision sc
10971       integer i
10972       scalar2=u(1)*v(1)+u(2)*v(2)
10973       return
10974       end
10975
10976 C-----------------------------------------------------------------------------
10977
10978       subroutine transpose2(a,at)
10979 !DIR$ INLINEALWAYS transpose2
10980 #ifndef OSF
10981 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10982 #endif
10983       implicit none
10984       double precision a(2,2),at(2,2)
10985       at(1,1)=a(1,1)
10986       at(1,2)=a(2,1)
10987       at(2,1)=a(1,2)
10988       at(2,2)=a(2,2)
10989       return
10990       end
10991 c--------------------------------------------------------------------------
10992       subroutine transpose(n,a,at)
10993       implicit none
10994       integer n,i,j
10995       double precision a(n,n),at(n,n)
10996       do i=1,n
10997         do j=1,n
10998           at(j,i)=a(i,j)
10999         enddo
11000       enddo
11001       return
11002       end
11003 C---------------------------------------------------------------------------
11004       subroutine prodmat3(a1,a2,kk,transp,prod)
11005 !DIR$ INLINEALWAYS prodmat3
11006 #ifndef OSF
11007 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11008 #endif
11009       implicit none
11010       integer i,j
11011       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11012       logical transp
11013 crc      double precision auxmat(2,2),prod_(2,2)
11014
11015       if (transp) then
11016 crc        call transpose2(kk(1,1),auxmat(1,1))
11017 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11018 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11019
11020            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11021      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11022            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11023      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11024            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11025      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11026            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11027      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11028
11029       else
11030 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11031 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11032
11033            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11034      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11035            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11036      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11037            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11038      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11039            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11040      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11041
11042       endif
11043 c      call transpose2(a2(1,1),a2t(1,1))
11044
11045 crc      print *,transp
11046 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11047 crc      print *,((prod(i,j),i=1,2),j=1,2)
11048
11049       return
11050       end
11051 CCC----------------------------------------------
11052       subroutine Eliptransfer(eliptran)
11053       implicit real*8 (a-h,o-z)
11054       include 'DIMENSIONS'
11055       include 'COMMON.GEO'
11056       include 'COMMON.VAR'
11057       include 'COMMON.LOCAL'
11058       include 'COMMON.CHAIN'
11059       include 'COMMON.DERIV'
11060       include 'COMMON.NAMES'
11061       include 'COMMON.INTERACT'
11062       include 'COMMON.IOUNITS'
11063       include 'COMMON.CALC'
11064       include 'COMMON.CONTROL'
11065       include 'COMMON.SPLITELE'
11066       include 'COMMON.SBRIDGE'
11067 C this is done by Adasko
11068 C      print *,"wchodze"
11069 C structure of box:
11070 C      water
11071 C--bordliptop-- buffore starts
11072 C--bufliptop--- here true lipid starts
11073 C      lipid
11074 C--buflipbot--- lipid ends buffore starts
11075 C--bordlipbot--buffore ends
11076       eliptran=0.0
11077       do i=ilip_start,ilip_end
11078 C       do i=1,1
11079         if (itype(i).eq.ntyp1) cycle
11080
11081         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11082         if (positi.le.0) positi=positi+boxzsize
11083 C        print *,i
11084 C first for peptide groups
11085 c for each residue check if it is in lipid or lipid water border area
11086        if ((positi.gt.bordlipbot)
11087      &.and.(positi.lt.bordliptop)) then
11088 C the energy transfer exist
11089         if (positi.lt.buflipbot) then
11090 C what fraction I am in
11091          fracinbuf=1.0d0-
11092      &        ((positi-bordlipbot)/lipbufthick)
11093 C lipbufthick is thickenes of lipid buffore
11094          sslip=sscalelip(fracinbuf)
11095          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11096          eliptran=eliptran+sslip*pepliptran
11097          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11098          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11099 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11100
11101 C        print *,"doing sccale for lower part"
11102 C         print *,i,sslip,fracinbuf,ssgradlip
11103         elseif (positi.gt.bufliptop) then
11104          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11105          sslip=sscalelip(fracinbuf)
11106          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11107          eliptran=eliptran+sslip*pepliptran
11108          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11109          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11110 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11111 C          print *, "doing sscalefor top part"
11112 C         print *,i,sslip,fracinbuf,ssgradlip
11113         else
11114          eliptran=eliptran+pepliptran
11115 C         print *,"I am in true lipid"
11116         endif
11117 C       else
11118 C       eliptran=elpitran+0.0 ! I am in water
11119        endif
11120        enddo
11121 C       print *, "nic nie bylo w lipidzie?"
11122 C now multiply all by the peptide group transfer factor
11123 C       eliptran=eliptran*pepliptran
11124 C now the same for side chains
11125 CV       do i=1,1
11126        do i=ilip_start,ilip_end
11127         if (itype(i).eq.ntyp1) cycle
11128         positi=(mod(c(3,i+nres),boxzsize))
11129         if (positi.le.0) positi=positi+boxzsize
11130 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11131 c for each residue check if it is in lipid or lipid water border area
11132 C       respos=mod(c(3,i+nres),boxzsize)
11133 C       print *,positi,bordlipbot,buflipbot
11134        if ((positi.gt.bordlipbot)
11135      & .and.(positi.lt.bordliptop)) then
11136 C the energy transfer exist
11137         if (positi.lt.buflipbot) then
11138          fracinbuf=1.0d0-
11139      &     ((positi-bordlipbot)/lipbufthick)
11140 C lipbufthick is thickenes of lipid buffore
11141          sslip=sscalelip(fracinbuf)
11142          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11143          eliptran=eliptran+sslip*liptranene(itype(i))
11144          gliptranx(3,i)=gliptranx(3,i)
11145      &+ssgradlip*liptranene(itype(i))
11146          gliptranc(3,i-1)= gliptranc(3,i-1)
11147      &+ssgradlip*liptranene(itype(i))
11148 C         print *,"doing sccale for lower part"
11149         elseif (positi.gt.bufliptop) then
11150          fracinbuf=1.0d0-
11151      &((bordliptop-positi)/lipbufthick)
11152          sslip=sscalelip(fracinbuf)
11153          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11154          eliptran=eliptran+sslip*liptranene(itype(i))
11155          gliptranx(3,i)=gliptranx(3,i)
11156      &+ssgradlip*liptranene(itype(i))
11157          gliptranc(3,i-1)= gliptranc(3,i-1)
11158      &+ssgradlip*liptranene(itype(i))
11159 C          print *, "doing sscalefor top part",sslip,fracinbuf
11160         else
11161          eliptran=eliptran+liptranene(itype(i))
11162 C         print *,"I am in true lipid"
11163         endif
11164         endif ! if in lipid or buffor
11165 C       else
11166 C       eliptran=elpitran+0.0 ! I am in water
11167        enddo
11168        return
11169        end
11170 C---------------------------------------------------------
11171 C AFM soubroutine for constant force
11172        subroutine AFMforce(Eafmforce)
11173        implicit real*8 (a-h,o-z)
11174       include 'DIMENSIONS'
11175       include 'COMMON.GEO'
11176       include 'COMMON.VAR'
11177       include 'COMMON.LOCAL'
11178       include 'COMMON.CHAIN'
11179       include 'COMMON.DERIV'
11180       include 'COMMON.NAMES'
11181       include 'COMMON.INTERACT'
11182       include 'COMMON.IOUNITS'
11183       include 'COMMON.CALC'
11184       include 'COMMON.CONTROL'
11185       include 'COMMON.SPLITELE'
11186       include 'COMMON.SBRIDGE'
11187       real*8 diffafm(3)
11188       dist=0.0d0
11189       Eafmforce=0.0d0
11190       do i=1,3
11191       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11192       dist=dist+diffafm(i)**2
11193       enddo
11194       dist=dsqrt(dist)
11195       Eafmforce=-forceAFMconst*(dist-distafminit)
11196       do i=1,3
11197       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11198       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11199       enddo
11200 C      print *,'AFM',Eafmforce
11201       return
11202       end
11203 C---------------------------------------------------------
11204 C AFM subroutine with pseudoconstant velocity
11205        subroutine AFMvel(Eafmforce)
11206        implicit real*8 (a-h,o-z)
11207       include 'DIMENSIONS'
11208       include 'COMMON.GEO'
11209       include 'COMMON.VAR'
11210       include 'COMMON.LOCAL'
11211       include 'COMMON.CHAIN'
11212       include 'COMMON.DERIV'
11213       include 'COMMON.NAMES'
11214       include 'COMMON.INTERACT'
11215       include 'COMMON.IOUNITS'
11216       include 'COMMON.CALC'
11217       include 'COMMON.CONTROL'
11218       include 'COMMON.SPLITELE'
11219       include 'COMMON.SBRIDGE'
11220       real*8 diffafm(3)
11221 C Only for check grad COMMENT if not used for checkgrad
11222 C      totT=3.0d0
11223 C--------------------------------------------------------
11224 C      print *,"wchodze"
11225       dist=0.0d0
11226       Eafmforce=0.0d0
11227       do i=1,3
11228       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11229       dist=dist+diffafm(i)**2
11230       enddo
11231       dist=dsqrt(dist)
11232       Eafmforce=0.5d0*forceAFMconst
11233      & *(distafminit+totTafm*velAFMconst-dist)**2
11234 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11235       do i=1,3
11236       gradafm(i,afmend-1)=-forceAFMconst*
11237      &(distafminit+totTafm*velAFMconst-dist)
11238      &*diffafm(i)/dist
11239       gradafm(i,afmbeg-1)=forceAFMconst*
11240      &(distafminit+totTafm*velAFMconst-dist)
11241      &*diffafm(i)/dist
11242       enddo
11243 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11244       return
11245       end
11246 C-----------------------------------------------------------
11247 C first for shielding is setting of function of side-chains
11248        subroutine set_shield_fac
11249       implicit real*8 (a-h,o-z)
11250       include 'DIMENSIONS'
11251       include 'COMMON.CHAIN'
11252       include 'COMMON.DERIV'
11253       include 'COMMON.IOUNITS'
11254       include 'COMMON.SHIELD'
11255       include 'COMMON.INTERACT'
11256 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11257       double precision div77_81/0.974996043d0/,
11258      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11259
11260 C the vector between center of side_chain and peptide group
11261        double precision pep_side(3),long,side_calf(3),
11262      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11263      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11264 C the line belowe needs to be changed for FGPROC>1
11265       do i=1,nres-1
11266       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11267       ishield_list(i)=0
11268 Cif there two consequtive dummy atoms there is no peptide group between them
11269 C the line below has to be changed for FGPROC>1
11270       VolumeTotal=0.0
11271       do k=1,nres
11272        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11273        dist_pep_side=0.0
11274        dist_side_calf=0.0
11275        do j=1,3
11276 C first lets set vector conecting the ithe side-chain with kth side-chain
11277       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11278 C      pep_side(j)=2.0d0
11279 C and vector conecting the side-chain with its proper calfa
11280       side_calf(j)=c(j,k+nres)-c(j,k)
11281 C      side_calf(j)=2.0d0
11282       pept_group(j)=c(j,i)-c(j,i+1)
11283 C lets have their lenght
11284       dist_pep_side=pep_side(j)**2+dist_pep_side
11285       dist_side_calf=dist_side_calf+side_calf(j)**2
11286       dist_pept_group=dist_pept_group+pept_group(j)**2
11287       enddo
11288        dist_pep_side=dsqrt(dist_pep_side)
11289        dist_pept_group=dsqrt(dist_pept_group)
11290        dist_side_calf=dsqrt(dist_side_calf)
11291       do j=1,3
11292         pep_side_norm(j)=pep_side(j)/dist_pep_side
11293         side_calf_norm(j)=dist_side_calf
11294       enddo
11295 C now sscale fraction
11296        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11297 C       print *,buff_shield,"buff"
11298 C now sscale
11299         if (sh_frac_dist.le.0.0) cycle
11300 C If we reach here it means that this side chain reaches the shielding sphere
11301 C Lets add him to the list for gradient
11302         ishield_list(i)=ishield_list(i)+1
11303 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11304 C this list is essential otherwise problem would be O3
11305         shield_list(ishield_list(i),i)=k
11306 C Lets have the sscale value
11307         if (sh_frac_dist.gt.1.0) then
11308          scale_fac_dist=1.0d0
11309          do j=1,3
11310          sh_frac_dist_grad(j)=0.0d0
11311          enddo
11312         else
11313          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11314      &                   *(2.0*sh_frac_dist-3.0d0)
11315          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11316      &                  /dist_pep_side/buff_shield*0.5
11317 C remember for the final gradient multiply sh_frac_dist_grad(j)
11318 C for side_chain by factor -2 !
11319          do j=1,3
11320          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11321 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11322 C     &                    sh_frac_dist_grad(j)
11323          enddo
11324         endif
11325 C        if ((i.eq.3).and.(k.eq.2)) then
11326 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11327 C     & ,"TU"
11328 C        endif
11329
11330 C this is what is now we have the distance scaling now volume...
11331       short=short_r_sidechain(itype(k))
11332       long=long_r_sidechain(itype(k))
11333       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11334 C now costhet_grad
11335 C       costhet=0.0d0
11336        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11337 C       costhet_fac=0.0d0
11338        do j=1,3
11339          costhet_grad(j)=costhet_fac*pep_side(j)
11340        enddo
11341 C remember for the final gradient multiply costhet_grad(j)
11342 C for side_chain by factor -2 !
11343 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11344 C pep_side0pept_group is vector multiplication
11345       pep_side0pept_group=0.0
11346       do j=1,3
11347       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11348       enddo
11349       cosalfa=(pep_side0pept_group/
11350      & (dist_pep_side*dist_side_calf))
11351       fac_alfa_sin=1.0-cosalfa**2
11352       fac_alfa_sin=dsqrt(fac_alfa_sin)
11353       rkprim=fac_alfa_sin*(long-short)+short
11354 C now costhet_grad
11355        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11356        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11357
11358        do j=1,3
11359          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11360      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11361      &*(long-short)/fac_alfa_sin*cosalfa/
11362      &((dist_pep_side*dist_side_calf))*
11363      &((side_calf(j))-cosalfa*
11364      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11365
11366         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11367      &*(long-short)/fac_alfa_sin*cosalfa
11368      &/((dist_pep_side*dist_side_calf))*
11369      &(pep_side(j)-
11370      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11371        enddo
11372
11373       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11374      &                    /VSolvSphere_div
11375      &                    *wshield
11376 C now the gradient...
11377 C grad_shield is gradient of Calfa for peptide groups
11378 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11379 C     &               costhet,cosphi
11380 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11381 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11382       do j=1,3
11383       grad_shield(j,i)=grad_shield(j,i)
11384 C gradient po skalowaniu
11385      &                +(sh_frac_dist_grad(j)
11386 C  gradient po costhet
11387      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11388      &-scale_fac_dist*(cosphi_grad_long(j))
11389      &/(1.0-cosphi) )*div77_81
11390      &*VofOverlap
11391 C grad_shield_side is Cbeta sidechain gradient
11392       grad_shield_side(j,ishield_list(i),i)=
11393      &        (sh_frac_dist_grad(j)*-2.0d0
11394      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11395      &       +scale_fac_dist*(cosphi_grad_long(j))
11396      &        *2.0d0/(1.0-cosphi))
11397      &        *div77_81*VofOverlap
11398
11399        grad_shield_loc(j,ishield_list(i),i)=
11400      &   scale_fac_dist*cosphi_grad_loc(j)
11401      &        *2.0d0/(1.0-cosphi)
11402      &        *div77_81*VofOverlap
11403       enddo
11404       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11405       enddo
11406       fac_shield(i)=VolumeTotal*div77_81+div4_81
11407 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11408       enddo
11409       return
11410       end
11411 C--------------------------------------------------------------------------
11412       double precision function tschebyshev(m,n,x,y)
11413       implicit none
11414       include "DIMENSIONS"
11415       integer i,m,n
11416       double precision x(n),y,yy(0:maxvar),aux
11417 c Tschebyshev polynomial. Note that the first term is omitted
11418 c m=0: the constant term is included
11419 c m=1: the constant term is not included
11420       yy(0)=1.0d0
11421       yy(1)=y
11422       do i=2,n
11423         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11424       enddo
11425       aux=0.0d0
11426       do i=m,n
11427         aux=aux+x(i)*yy(i)
11428       enddo
11429       tschebyshev=aux
11430       return
11431       end
11432 C--------------------------------------------------------------------------
11433       double precision function gradtschebyshev(m,n,x,y)
11434       implicit none
11435       include "DIMENSIONS"
11436       integer i,m,n
11437       double precision x(n+1),y,yy(0:maxvar),aux
11438 c Tschebyshev polynomial. Note that the first term is omitted
11439 c m=0: the constant term is included
11440 c m=1: the constant term is not included
11441       yy(0)=1.0d0
11442       yy(1)=2.0d0*y
11443       do i=2,n
11444         yy(i)=2*y*yy(i-1)-yy(i-2)
11445       enddo
11446       aux=0.0d0
11447       do i=m,n
11448         aux=aux+x(i+1)*yy(i)*(i+1)
11449 C        print *, x(i+1),yy(i),i
11450       enddo
11451       gradtschebyshev=aux
11452       return
11453       end
11454 C------------------------------------------------------------------------
11455 C first for shielding is setting of function of side-chains
11456        subroutine set_shield_fac2
11457       implicit real*8 (a-h,o-z)
11458       include 'DIMENSIONS'
11459       include 'COMMON.CHAIN'
11460       include 'COMMON.DERIV'
11461       include 'COMMON.IOUNITS'
11462       include 'COMMON.SHIELD'
11463       include 'COMMON.INTERACT'
11464 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11465       double precision div77_81/0.974996043d0/,
11466      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11467
11468 C the vector between center of side_chain and peptide group
11469        double precision pep_side(3),long,side_calf(3),
11470      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11471      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11472 C the line belowe needs to be changed for FGPROC>1
11473       do i=1,nres-1
11474       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11475       ishield_list(i)=0
11476 Cif there two consequtive dummy atoms there is no peptide group between them
11477 C the line below has to be changed for FGPROC>1
11478       VolumeTotal=0.0
11479       do k=1,nres
11480        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11481        dist_pep_side=0.0
11482        dist_side_calf=0.0
11483        do j=1,3
11484 C first lets set vector conecting the ithe side-chain with kth side-chain
11485       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11486 C      pep_side(j)=2.0d0
11487 C and vector conecting the side-chain with its proper calfa
11488       side_calf(j)=c(j,k+nres)-c(j,k)
11489 C      side_calf(j)=2.0d0
11490       pept_group(j)=c(j,i)-c(j,i+1)
11491 C lets have their lenght
11492       dist_pep_side=pep_side(j)**2+dist_pep_side
11493       dist_side_calf=dist_side_calf+side_calf(j)**2
11494       dist_pept_group=dist_pept_group+pept_group(j)**2
11495       enddo
11496        dist_pep_side=dsqrt(dist_pep_side)
11497        dist_pept_group=dsqrt(dist_pept_group)
11498        dist_side_calf=dsqrt(dist_side_calf)
11499       do j=1,3
11500         pep_side_norm(j)=pep_side(j)/dist_pep_side
11501         side_calf_norm(j)=dist_side_calf
11502       enddo
11503 C now sscale fraction
11504        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11505 C       print *,buff_shield,"buff"
11506 C now sscale
11507         if (sh_frac_dist.le.0.0) cycle
11508 C If we reach here it means that this side chain reaches the shielding sphere
11509 C Lets add him to the list for gradient
11510         ishield_list(i)=ishield_list(i)+1
11511 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11512 C this list is essential otherwise problem would be O3
11513         shield_list(ishield_list(i),i)=k
11514 C Lets have the sscale value
11515         if (sh_frac_dist.gt.1.0) then
11516          scale_fac_dist=1.0d0
11517          do j=1,3
11518          sh_frac_dist_grad(j)=0.0d0
11519          enddo
11520         else
11521          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11522      &                   *(2.0d0*sh_frac_dist-3.0d0)
11523          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11524      &                  /dist_pep_side/buff_shield*0.5d0
11525 C remember for the final gradient multiply sh_frac_dist_grad(j)
11526 C for side_chain by factor -2 !
11527          do j=1,3
11528          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11529 C         sh_frac_dist_grad(j)=0.0d0
11530 C         scale_fac_dist=1.0d0
11531 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11532 C     &                    sh_frac_dist_grad(j)
11533          enddo
11534         endif
11535 C this is what is now we have the distance scaling now volume...
11536       short=short_r_sidechain(itype(k))
11537       long=long_r_sidechain(itype(k))
11538       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11539       sinthet=short/dist_pep_side*costhet
11540 C now costhet_grad
11541 C       costhet=0.6d0
11542 C       sinthet=0.8
11543        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11544 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11545 C     &             -short/dist_pep_side**2/costhet)
11546 C       costhet_fac=0.0d0
11547        do j=1,3
11548          costhet_grad(j)=costhet_fac*pep_side(j)
11549        enddo
11550 C remember for the final gradient multiply costhet_grad(j)
11551 C for side_chain by factor -2 !
11552 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11553 C pep_side0pept_group is vector multiplication
11554       pep_side0pept_group=0.0d0
11555       do j=1,3
11556       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11557       enddo
11558       cosalfa=(pep_side0pept_group/
11559      & (dist_pep_side*dist_side_calf))
11560       fac_alfa_sin=1.0d0-cosalfa**2
11561       fac_alfa_sin=dsqrt(fac_alfa_sin)
11562       rkprim=fac_alfa_sin*(long-short)+short
11563 C      rkprim=short
11564
11565 C now costhet_grad
11566        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11567 C       cosphi=0.6
11568        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11569        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11570      &      dist_pep_side**2)
11571 C       sinphi=0.8
11572        do j=1,3
11573          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11574      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11575      &*(long-short)/fac_alfa_sin*cosalfa/
11576      &((dist_pep_side*dist_side_calf))*
11577      &((side_calf(j))-cosalfa*
11578      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11579 C       cosphi_grad_long(j)=0.0d0
11580         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11581      &*(long-short)/fac_alfa_sin*cosalfa
11582      &/((dist_pep_side*dist_side_calf))*
11583      &(pep_side(j)-
11584      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11585 C       cosphi_grad_loc(j)=0.0d0
11586        enddo
11587 C      print *,sinphi,sinthet
11588       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11589      &                    /VSolvSphere_div
11590      &                    *wshield
11591 C now the gradient...
11592       do j=1,3
11593       grad_shield(j,i)=grad_shield(j,i)
11594 C gradient po skalowaniu
11595      &                +(sh_frac_dist_grad(j)*VofOverlap
11596 C  gradient po costhet
11597      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11598      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11599      &       sinphi/sinthet*costhet*costhet_grad(j)
11600      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11601      & )*div77_81
11602 C grad_shield_side is Cbeta sidechain gradient
11603       grad_shield_side(j,ishield_list(i),i)=
11604      &        (sh_frac_dist_grad(j)*-2.0d0
11605      &        *VofOverlap
11606      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11607      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11608      &       sinphi/sinthet*costhet*costhet_grad(j)
11609      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11610      &       )*div77_81
11611
11612        grad_shield_loc(j,ishield_list(i),i)=
11613      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11614      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11615      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11616      &        ))
11617      &        *div77_81
11618       enddo
11619       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11620       enddo
11621       fac_shield(i)=VolumeTotal*div77_81+div4_81
11622 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11623       enddo
11624       return
11625       end
11626