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 c      write (iout,*) "SCSC computed OK"
 134 c      call flush_(iout)
 135 #ifdef TIMING
 136       time01=MPI_Wtime()
 137 #endif
 138       call vec_and_deriv
 139 #ifdef TIMING
 140       time_vec=time_vec+MPI_Wtime()-time01
 141 #endif
 142 C Introduction of shielding effect first for each peptide group
 143 C the shielding factor is set this factor is describing how each
 144 C peptide group is shielded by side-chains
 145 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 146 C      write (iout,*) "shield_mode",shield_mode
 147       if (shield_mode.gt.0) then
 148        call set_shield_fac
 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      write (iout,*) "eelec computed OK"
 177 c      call flush_(iout)
 178 c      print *,"Processor",myrank," computed UELEC"
 179 C
 180 C Calculate excluded-volume interaction energy between peptide groups
 181 C and side chains.
 182 C
 183       if (ipot.lt.6) then
 184        if(wscp.gt.0d0) then
 185         call escp(evdw2,evdw2_14)
 186        else
 187         evdw2=0
 188         evdw2_14=0
 189        endif
 190       else
 191 c        write (iout,*) "Soft-sphere SCP potential"
 192         call escp_soft_sphere(evdw2,evdw2_14)
 193       endif
 194 c      write (iout,*) "escp computed OK"
 195 c      call flush_(iout)
 196 c
 197 c Calculate the bond-stretching energy
 198 c
 199       call ebond(estr)
 200 c      write (iout,*) "ebond computed OK"
 201 c      call flush_(iout)
 202 C
 203 C Calculate the disulfide-bridge and other energy and the contributions
 204 C from other distance constraints.
 205 cd    print *,'Calling EHPB'
 206       call edis(ehpb)
 207 cd    print *,'EHPB exitted succesfully.'
 208 C
 209 C Calculate the virtual-bond-angle energy.
 210 C
 211       if (wang.gt.0d0) then
 212         call ebend(ebe,ethetacnstr)
 213       else
 214         ebe=0
 215         ethetacnstr=0
 216       endif
 217 c      write (iout,*) "ebend computed OK"
 218 c      call flush_(iout)
 219 c      print *,"Processor",myrank," computed UB"
 220 C
 221 C Calculate the SC local energy.
 222 C
 223 C      print *,"TU DOCHODZE?"
 224       call esc(escloc)
 225 c      write (iout,*) "esc computed OK"
 226 c      call flush_(iout)
 227 c      print *,"Processor",myrank," computed USC"
 228 C
 229 C Calculate the virtual-bond torsional energy.
 230 C
 231 cd    print *,'nterm=',nterm
 232       if (wtor.gt.0) then
 233        call etor(etors,edihcnstr)
 234       else
 235        etors=0
 236        edihcnstr=0
 237       endif
 238 c      write (iout,*) "etor computed OK"
 239 c      call flush_(iout)
 240 c      print *,"Processor",myrank," computed Utor"
 241 C
 242 C 6/23/01 Calculate double-torsional energy
 243 C
 244       if (wtor_d.gt.0) then
 245        call etor_d(etors_d)
 246       else
 247        etors_d=0
 248       endif
 249 c      write (iout,*) "etor_d computed OK"
 250 c      call flush_(iout)
 251 c      print *,"Processor",myrank," computed Utord"
 252 C
 253 C 21/5/07 Calculate local sicdechain correlation energy
 254 C
 255       if (wsccor.gt.0.0d0) then
 256         call eback_sc_corr(esccor)
 257       else
 258         esccor=0.0d0
 259       endif
 260 c      write (iout,*) "eback_sc_corr computed OK"
 261 c      call flush_(iout)
 262 C      print *,"PRZED MULIt"
 263 c      print *,"Processor",myrank," computed Usccorr"
 264 C
 265 C 12/1/95 Multi-body terms
 266 C
 267       n_corr=0
 268       n_corr1=0
 269       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 270      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 271 c         write (iout,*) "Calling multibody_eello"
 272 c         call flush_(iout)
 273          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 274 c         write(iout,*)
 275 c     & 'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 276 c     & " ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 277 c         call flush_(iout)
 278       else
 279          ecorr=0.0d0
 280          ecorr5=0.0d0
 281          ecorr6=0.0d0
 282          eturn6=0.0d0
 283       endif
 284       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 285 c         write (iout,*) "Calling multibody_gb_ecorr"
 286 c         call flush_(iout)
 287          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 288 c         write (iout,*) "Exited multibody_hb ecorr",ecorr
 289 c         call flush_(iout)
 290       endif
 291 c      write (iout,*) "multibody computed OK"
 292 c      call flush_(iout)
 293 c      print *,"Processor",myrank," computed Ucorr"
 294 C
 295 C If performing constraint dynamics, call the constraint energy
 296 C  after the equilibration time
 297       if(usampl.and.totT.gt.eq_time) then
 298          call EconstrQ
 299          call Econstr_back
 300       else
 301          Uconst=0.0d0
 302          Uconst_back=0.0d0
 303       endif
 304 C 01/27/2015 added by adasko
 305 C the energy component below is energy transfer into lipid environment
 306 C based on partition function
 307 C      print *,"przed lipidami"
 308       if (wliptran.gt.0) then
 309         call Eliptransfer(eliptran)
 310       endif
 311 c      write (iout,*) "lipid energy computed OK"
 312 c      call flush_(iout)
 313       if (AFMlog.gt.0) then
 314         call AFMforce(Eafmforce)
 315       else if (selfguide.gt.0) then
 316         call AFMvel(Eafmforce)
 317       endif
 318 c      write (iout,*) "AFMforce computed OK"
 319 c      call flush_(iout)
 320 #ifdef TIMING
 321       time_enecalc=time_enecalc+MPI_Wtime()-time00
 322 #endif
 323 c      print *,"Processor",myrank," computed Uconstr"
 324 #ifdef TIMING
 325       time00=MPI_Wtime()
 326 #endif
 327 c
 328 C Sum the energies
 329 C
 330       energia(1)=evdw
 331 #ifdef SCP14
 332       energia(2)=evdw2-evdw2_14
 333       energia(18)=evdw2_14
 334 #else
 335       energia(2)=evdw2
 336       energia(18)=0.0d0
 337 #endif
 338 #ifdef SPLITELE
 339       energia(3)=ees
 340       energia(16)=evdw1
 341 #else
 342       energia(3)=ees+evdw1
 343       energia(16)=0.0d0
 344 #endif
 345       energia(4)=ecorr
 346       energia(5)=ecorr5
 347       energia(6)=ecorr6
 348       energia(7)=eel_loc
 349       energia(8)=eello_turn3
 350       energia(9)=eello_turn4
 351       energia(10)=eturn6
 352       energia(11)=ebe
 353       energia(12)=escloc
 354       energia(13)=etors
 355       energia(14)=etors_d
 356       energia(15)=ehpb
 357       energia(19)=edihcnstr
 358       energia(17)=estr
 359       energia(20)=Uconst+Uconst_back
 360       energia(21)=esccor
 361       energia(22)=eliptran
 362       energia(23)=Eafmforce
 363       energia(24)=ethetacnstr
 364 c    Here are the energies showed per procesor if the are more processors
 365 c    per molecule then we sum it up in sum_energy subroutine
 366 c      print *," Processor",myrank," calls SUM_ENERGY"
 367       call sum_energy(energia,.true.)
 368 c      write (iout,*) "sum energy OK"
 369 c      call flush_(iout)
 370       if (dyn_ss) call dyn_set_nss
 371 c      write (iout,*) "Exiting energy"
 372 c      call flush_(iout)
 373 c      print *," Processor",myrank," left SUM_ENERGY"
 374 #ifdef TIMING
 375       time_sumene=time_sumene+MPI_Wtime()-time00
 376 #endif
 377       return
 378       end
 379 c-------------------------------------------------------------------------------
 380       subroutine sum_energy(energia,reduce)
 381       implicit real*8 (a-h,o-z)
 382       include 'DIMENSIONS'
 383 #ifndef ISNAN
 384       external proc_proc
 385 #ifdef WINPGI
 386 cMS$ATTRIBUTES C ::  proc_proc
 387 #endif
 388 #endif
 389 #ifdef MPI
 390       include "mpif.h"
 391 #endif
 392       include 'COMMON.SETUP'
 393       include 'COMMON.IOUNITS'
 394       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 395       include 'COMMON.FFIELD'
 396       include 'COMMON.DERIV'
 397       include 'COMMON.INTERACT'
 398       include 'COMMON.SBRIDGE'
 399       include 'COMMON.CHAIN'
 400       include 'COMMON.VAR'
 401       include 'COMMON.CONTROL'
 402       include 'COMMON.TIME1'
 403       logical reduce
 404 #ifdef MPI
 405       if (nfgtasks.gt.1 .and. reduce) then
 406 #ifdef DEBUG
 407         write (iout,*) "energies before REDUCE"
 408         call enerprint(energia)
 409         call flush(iout)
 410 #endif
 411         do i=0,n_ene
 412           enebuff(i)=energia(i)
 413         enddo
 414         time00=MPI_Wtime()
 415         call MPI_Barrier(FG_COMM,IERR)
 416         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 417         time00=MPI_Wtime()
 418         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 419      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 420 #ifdef DEBUG
 421         write (iout,*) "energies after REDUCE"
 422         call enerprint(energia)
 423         call flush(iout)
 424 #endif
 425         time_Reduce=time_Reduce+MPI_Wtime()-time00
 426       endif
 427       if (fg_rank.eq.0) then
 428 #endif
 429       evdw=energia(1)
 430 #ifdef SCP14
 431       evdw2=energia(2)+energia(18)
 432       evdw2_14=energia(18)
 433 #else
 434       evdw2=energia(2)
 435 #endif
 436 #ifdef SPLITELE
 437       ees=energia(3)
 438       evdw1=energia(16)
 439 #else
 440       ees=energia(3)
 441       evdw1=0.0d0
 442 #endif
 443       ecorr=energia(4)
 444       ecorr5=energia(5)
 445       ecorr6=energia(6)
 446       eel_loc=energia(7)
 447       eello_turn3=energia(8)
 448       eello_turn4=energia(9)
 449       eturn6=energia(10)
 450       ebe=energia(11)
 451       escloc=energia(12)
 452       etors=energia(13)
 453       etors_d=energia(14)
 454       ehpb=energia(15)
 455       edihcnstr=energia(19)
 456       estr=energia(17)
 457       Uconst=energia(20)
 458       esccor=energia(21)
 459       eliptran=energia(22)
 460       Eafmforce=energia(23)
 461       ethetacnstr=energia(24)
 462 #ifdef SPLITELE
 463       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 464      & +wang*ebe+wtor*etors+wscloc*escloc
 465      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 466      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 467      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 468      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 469      & +ethetacnstr
 470 #else
 471       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 472      & +wang*ebe+wtor*etors+wscloc*escloc
 473      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 474      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 475      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 476      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 477      & +Eafmforce
 478      & +ethetacnstr
 479 #endif
 480       energia(0)=etot
 481 c detecting NaNQ
 482 #ifdef ISNAN
 483 #ifdef AIX
 484       if (isnan(etot).ne.0) energia(0)=1.0d+99
 485 #else
 486       if (isnan(etot)) energia(0)=1.0d+99
 487 #endif
 488 #else
 489       i=0
 490 #ifdef WINPGI
 491       idumm=proc_proc(etot,i)
 492 #else
 493       call proc_proc(etot,i)
 494 #endif
 495       if(i.eq.1)energia(0)=1.0d+99
 496 #endif
 497 #ifdef MPI
 498       endif
 499 #endif
 500       return
 501       end
 502 c-------------------------------------------------------------------------------
 503       subroutine sum_gradient
 504       implicit real*8 (a-h,o-z)
 505       include 'DIMENSIONS'
 506 #ifndef ISNAN
 507       external proc_proc
 508 #ifdef WINPGI
 509 cMS$ATTRIBUTES C ::  proc_proc
 510 #endif
 511 #endif
 512 #ifdef MPI
 513       include 'mpif.h'
 514 #endif
 515       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 516      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 517      & ,gloc_scbuf(3,-1:maxres)
 518       include 'COMMON.SETUP'
 519       include 'COMMON.IOUNITS'
 520       include 'COMMON.FFIELD'
 521       include 'COMMON.DERIV'
 522       include 'COMMON.INTERACT'
 523       include 'COMMON.SBRIDGE'
 524       include 'COMMON.CHAIN'
 525       include 'COMMON.VAR'
 526       include 'COMMON.CONTROL'
 527       include 'COMMON.TIME1'
 528       include 'COMMON.MAXGRAD'
 529       include 'COMMON.SCCOR'
 530 #ifdef TIMING
 531       time01=MPI_Wtime()
 532 #endif
 533 #ifdef DEBUG
 534       write (iout,*) "sum_gradient gvdwc, gvdwx"
 535       do i=1,nres
 536         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 537      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 538       enddo
 539       call flush(iout)
 540 #endif
 541 #ifdef MPI
 542 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 543         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 544      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 545 #endif
 546 C
 547 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 548 C            in virtual-bond-vector coordinates
 549 C
 550 #ifdef DEBUG
 551 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 552 c      do i=1,nres-1
 553 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 554 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 555 c      enddo
 556 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 557 c      do i=1,nres-1
 558 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 559 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 560 c      enddo
 561       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 562       do i=1,nres
 563         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 564      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 565      &   g_corr5_loc(i)
 566       enddo
 567       call flush(iout)
 568 #endif
 569 #ifdef SPLITELE
 570       do i=0,nct
 571         do j=1,3
 572           gradbufc(j,i)=wsc*gvdwc(j,i)+
 573      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 574      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 575      &                wel_loc*gel_loc_long(j,i)+
 576      &                wcorr*gradcorr_long(j,i)+
 577      &                wcorr5*gradcorr5_long(j,i)+
 578      &                wcorr6*gradcorr6_long(j,i)+
 579      &                wturn6*gcorr6_turn_long(j,i)+
 580      &                wstrain*ghpbc(j,i)
 581      &                +wliptran*gliptranc(j,i)
 582      &                +gradafm(j,i)
 583      &                 +welec*gshieldc(j,i)
 584
 585         enddo
 586       enddo
 587 #else
 588       do i=0,nct
 589         do j=1,3
 590           gradbufc(j,i)=wsc*gvdwc(j,i)+
 591      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 592      &                welec*gelc_long(j,i)+
 593      &                wbond*gradb(j,i)+
 594      &                wel_loc*gel_loc_long(j,i)+
 595      &                wcorr*gradcorr_long(j,i)+
 596      &                wcorr5*gradcorr5_long(j,i)+
 597      &                wcorr6*gradcorr6_long(j,i)+
 598      &                wturn6*gcorr6_turn_long(j,i)+
 599      &                wstrain*ghpbc(j,i)
 600      &                +wliptran*gliptranc(j,i)
 601      &                +gradafm(j,i)
 602      &                 +welec*gshieldc(j,i)
 603
 604         enddo
 605       enddo
 606 #endif
 607 #ifdef MPI
 608       if (nfgtasks.gt.1) then
 609       time00=MPI_Wtime()
 610 #ifdef DEBUG
 611       write (iout,*) "gradbufc before allreduce"
 612       do i=1,nres
 613         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 614       enddo
 615       call flush(iout)
 616 #endif
 617       do i=0,nres
 618         do j=1,3
 619           gradbufc_sum(j,i)=gradbufc(j,i)
 620         enddo
 621       enddo
 622 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 623 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 624 c      time_reduce=time_reduce+MPI_Wtime()-time00
 625 #ifdef DEBUG
 626 c      write (iout,*) "gradbufc_sum after allreduce"
 627 c      do i=1,nres
 628 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 629 c      enddo
 630 c      call flush(iout)
 631 #endif
 632 #ifdef TIMING
 633 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 634 #endif
 635       do i=nnt,nres
 636         do k=1,3
 637           gradbufc(k,i)=0.0d0
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 642       write (iout,*) (i," jgrad_start",jgrad_start(i),
 643      &                  " jgrad_end  ",jgrad_end(i),
 644      &                  i=igrad_start,igrad_end)
 645 #endif
 646 c
 647 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 648 c do not parallelize this part.
 649 c
 650 c      do i=igrad_start,igrad_end
 651 c        do j=jgrad_start(i),jgrad_end(i)
 652 c          do k=1,3
 653 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 654 c          enddo
 655 c        enddo
 656 c      enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,-1,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 #ifdef DEBUG
 666       write (iout,*) "gradbufc after summing"
 667       do i=1,nres
 668         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 669       enddo
 670       call flush(iout)
 671 #endif
 672       else
 673 #endif
 674 #ifdef DEBUG
 675       write (iout,*) "gradbufc"
 676       do i=1,nres
 677         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 678       enddo
 679       call flush(iout)
 680 #endif
 681       do i=-1,nres
 682         do j=1,3
 683           gradbufc_sum(j,i)=gradbufc(j,i)
 684           gradbufc(j,i)=0.0d0
 685         enddo
 686       enddo
 687       do j=1,3
 688         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 689       enddo
 690       do i=nres-2,-1,-1
 691         do j=1,3
 692           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 693         enddo
 694       enddo
 695 c      do i=nnt,nres-1
 696 c        do k=1,3
 697 c          gradbufc(k,i)=0.0d0
 698 c        enddo
 699 c        do j=i+1,nres
 700 c          do k=1,3
 701 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 702 c          enddo
 703 c        enddo
 704 c      enddo
 705 #ifdef DEBUG
 706       write (iout,*) "gradbufc after summing"
 707       do i=1,nres
 708         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 709       enddo
 710       call flush(iout)
 711 #endif
 712 #ifdef MPI
 713       endif
 714 #endif
 715       do k=1,3
 716         gradbufc(k,nres)=0.0d0
 717       enddo
 718       do i=-1,nct
 719         do j=1,3
 720 #ifdef SPLITELE
 721 C          print *,gradbufc(1,13)
 722 C          print *,welec*gelc(1,13)
 723 C          print *,wel_loc*gel_loc(1,13)
 724 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 725 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 726 C          print *,wel_loc*gel_loc_long(1,13)
 727 C          print *,gradafm(1,13),"AFM"
 728           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 729      &                wel_loc*gel_loc(j,i)+
 730      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 731      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 732      &                wel_loc*gel_loc_long(j,i)+
 733      &                wcorr*gradcorr_long(j,i)+
 734      &                wcorr5*gradcorr5_long(j,i)+
 735      &                wcorr6*gradcorr6_long(j,i)+
 736      &                wturn6*gcorr6_turn_long(j,i))+
 737      &                wbond*gradb(j,i)+
 738      &                wcorr*gradcorr(j,i)+
 739      &                wturn3*gcorr3_turn(j,i)+
 740      &                wturn4*gcorr4_turn(j,i)+
 741      &                wcorr5*gradcorr5(j,i)+
 742      &                wcorr6*gradcorr6(j,i)+
 743      &                wturn6*gcorr6_turn(j,i)+
 744      &                wsccor*gsccorc(j,i)
 745      &               +wscloc*gscloc(j,i)
 746      &               +wliptran*gliptranc(j,i)
 747      &                +gradafm(j,i)
 748      &                 +welec*gshieldc(j,i)
 749      &                 +welec*gshieldc_loc(j,i)
 750
 751
 752 #else
 753           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 754      &                wel_loc*gel_loc(j,i)+
 755      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 756      &                welec*gelc_long(j,i)
 757      &                wel_loc*gel_loc_long(j,i)+
 758      &                wcorr*gcorr_long(j,i)+
 759      &                wcorr5*gradcorr5_long(j,i)+
 760      &                wcorr6*gradcorr6_long(j,i)+
 761      &                wturn6*gcorr6_turn_long(j,i))+
 762      &                wbond*gradb(j,i)+
 763      &                wcorr*gradcorr(j,i)+
 764      &                wturn3*gcorr3_turn(j,i)+
 765      &                wturn4*gcorr4_turn(j,i)+
 766      &                wcorr5*gradcorr5(j,i)+
 767      &                wcorr6*gradcorr6(j,i)+
 768      &                wturn6*gcorr6_turn(j,i)+
 769      &                wsccor*gsccorc(j,i)
 770      &               +wscloc*gscloc(j,i)
 771      &               +wliptran*gliptranc(j,i)
 772      &                +gradafm(j,i)
 773      &                 +welec*gshieldc(j,i)
 774      &                 +welec*gshieldc_loc(j,i)
 775
 776
 777 #endif
 778           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 779      &                  wbond*gradbx(j,i)+
 780      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 781      &                  wsccor*gsccorx(j,i)
 782      &                 +wscloc*gsclocx(j,i)
 783      &                 +wliptran*gliptranx(j,i)
 784      &                 +welec*gshieldx(j,i)
 785         enddo
 786       enddo
 787 #ifdef DEBUG
 788       write (iout,*) "gloc before adding corr"
 789       do i=1,4*nres
 790         write (iout,*) i,gloc(i,icg)
 791       enddo
 792 #endif
 793       do i=1,nres-3
 794         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 795      &   +wcorr5*g_corr5_loc(i)
 796      &   +wcorr6*g_corr6_loc(i)
 797      &   +wturn4*gel_loc_turn4(i)
 798      &   +wturn3*gel_loc_turn3(i)
 799      &   +wturn6*gel_loc_turn6(i)
 800      &   +wel_loc*gel_loc_loc(i)
 801       enddo
 802 #ifdef DEBUG
 803       write (iout,*) "gloc after adding corr"
 804       do i=1,4*nres
 805         write (iout,*) i,gloc(i,icg)
 806       enddo
 807 #endif
 808 #ifdef MPI
 809       if (nfgtasks.gt.1) then
 810         do j=1,3
 811           do i=1,nres
 812             gradbufc(j,i)=gradc(j,i,icg)
 813             gradbufx(j,i)=gradx(j,i,icg)
 814           enddo
 815         enddo
 816         do i=1,4*nres
 817           glocbuf(i)=gloc(i,icg)
 818         enddo
 819 c#define DEBUG
 820 #ifdef DEBUG
 821       write (iout,*) "gloc_sc before reduce"
 822       do i=1,nres
 823        do j=1,1
 824         write (iout,*) i,j,gloc_sc(j,i,icg)
 825        enddo
 826       enddo
 827 #endif
 828 c#undef DEBUG
 829         do i=1,nres
 830          do j=1,3
 831           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 832          enddo
 833         enddo
 834         time00=MPI_Wtime()
 835         call MPI_Barrier(FG_COMM,IERR)
 836         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 837         time00=MPI_Wtime()
 838         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 839      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 840         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 841      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 842         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 843      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 844         time_reduce=time_reduce+MPI_Wtime()-time00
 845         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 846      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 847         time_reduce=time_reduce+MPI_Wtime()-time00
 848 c#define DEBUG
 849 #ifdef DEBUG
 850       write (iout,*) "gloc_sc after reduce"
 851       do i=1,nres
 852        do j=1,1
 853         write (iout,*) i,j,gloc_sc(j,i,icg)
 854        enddo
 855       enddo
 856 #endif
 857 c#undef DEBUG
 858 #ifdef DEBUG
 859       write (iout,*) "gloc after reduce"
 860       do i=1,4*nres
 861         write (iout,*) i,gloc(i,icg)
 862       enddo
 863 #endif
 864       endif
 865 #endif
 866       if (gnorm_check) then
 867 c
 868 c Compute the maximum elements of the gradient
 869 c
 870       gvdwc_max=0.0d0
 871       gvdwc_scp_max=0.0d0
 872       gelc_max=0.0d0
 873       gvdwpp_max=0.0d0
 874       gradb_max=0.0d0
 875       ghpbc_max=0.0d0
 876       gradcorr_max=0.0d0
 877       gel_loc_max=0.0d0
 878       gcorr3_turn_max=0.0d0
 879       gcorr4_turn_max=0.0d0
 880       gradcorr5_max=0.0d0
 881       gradcorr6_max=0.0d0
 882       gcorr6_turn_max=0.0d0
 883       gsccorc_max=0.0d0
 884       gscloc_max=0.0d0
 885       gvdwx_max=0.0d0
 886       gradx_scp_max=0.0d0
 887       ghpbx_max=0.0d0
 888       gradxorr_max=0.0d0
 889       gsccorx_max=0.0d0
 890       gsclocx_max=0.0d0
 891       do i=1,nct
 892         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 893         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 894         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 895         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 896      &   gvdwc_scp_max=gvdwc_scp_norm
 897         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 898         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 899         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 900         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 901         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 902         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 903         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 904         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 905         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 906         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 907         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 908         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 909         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 910      &    gcorr3_turn(1,i)))
 911         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 912      &    gcorr3_turn_max=gcorr3_turn_norm
 913         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 914      &    gcorr4_turn(1,i)))
 915         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 916      &    gcorr4_turn_max=gcorr4_turn_norm
 917         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 918         if (gradcorr5_norm.gt.gradcorr5_max)
 919      &    gradcorr5_max=gradcorr5_norm
 920         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 921         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 922         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 923      &    gcorr6_turn(1,i)))
 924         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 925      &    gcorr6_turn_max=gcorr6_turn_norm
 926         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 927         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 928         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 929         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 930         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 931         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 932         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 933         if (gradx_scp_norm.gt.gradx_scp_max)
 934      &    gradx_scp_max=gradx_scp_norm
 935         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 936         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 937         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 938         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 939         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 940         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 941         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 942         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 943       enddo
 944       if (gradout) then
 945 #ifdef AIX
 946         open(istat,file=statname,position="append")
 947 #else
 948         open(istat,file=statname,access="append")
 949 #endif
 950         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 951      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 952      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 953      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 954      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 955      &     gsccorx_max,gsclocx_max
 956         close(istat)
 957         if (gvdwc_max.gt.1.0d4) then
 958           write (iout,*) "gvdwc gvdwx gradb gradbx"
 959           do i=nnt,nct
 960             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 961      &        gradb(j,i),gradbx(j,i),j=1,3)
 962           enddo
 963           call pdbout(0.0d0,'cipiszcze',iout)
 964           call flush(iout)
 965         endif
 966       endif
 967       endif
 968 #ifdef DEBUG
 969       write (iout,*) "gradc gradx gloc"
 970       do i=1,nres
 971         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 972      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 973       enddo
 974 #endif
 975 #ifdef TIMING
 976       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 977 #endif
 978       return
 979       end
 980 c-------------------------------------------------------------------------------
 981       subroutine rescale_weights(t_bath)
 982       implicit real*8 (a-h,o-z)
 983       include 'DIMENSIONS'
 984       include 'COMMON.IOUNITS'
 985       include 'COMMON.FFIELD'
 986       include 'COMMON.SBRIDGE'
 987       double precision kfac /2.4d0/
 988       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 989 c      facT=temp0/t_bath
 990 c      facT=2*temp0/(t_bath+temp0)
 991       if (rescale_mode.eq.0) then
 992         facT=1.0d0
 993         facT2=1.0d0
 994         facT3=1.0d0
 995         facT4=1.0d0
 996         facT5=1.0d0
 997       else if (rescale_mode.eq.1) then
 998         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 999         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1000         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1001         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1002         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1003       else if (rescale_mode.eq.2) then
1004         x=t_bath/temp0
1005         x2=x*x
1006         x3=x2*x
1007         x4=x3*x
1008         x5=x4*x
1009         facT=licznik/dlog(dexp(x)+dexp(-x))
1010         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1011         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1012         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1013         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1014       else
1015         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1016         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1017 #ifdef MPI
1018        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1019 #endif
1020        stop 555
1021       endif
1022       welec=weights(3)*fact
1023       wcorr=weights(4)*fact3
1024       wcorr5=weights(5)*fact4
1025       wcorr6=weights(6)*fact5
1026       wel_loc=weights(7)*fact2
1027       wturn3=weights(8)*fact2
1028       wturn4=weights(9)*fact3
1029       wturn6=weights(10)*fact5
1030       wtor=weights(13)*fact
1031       wtor_d=weights(14)*fact2
1032       wsccor=weights(21)*fact
1033
1034       return
1035       end
1036 C------------------------------------------------------------------------
1037       subroutine enerprint(energia)
1038       implicit real*8 (a-h,o-z)
1039       include 'DIMENSIONS'
1040       include 'COMMON.IOUNITS'
1041       include 'COMMON.FFIELD'
1042       include 'COMMON.SBRIDGE'
1043       include 'COMMON.MD'
1044       double precision energia(0:n_ene)
1045       etot=energia(0)
1046       evdw=energia(1)
1047       evdw2=energia(2)
1048 #ifdef SCP14
1049       evdw2=energia(2)+energia(18)
1050 #else
1051       evdw2=energia(2)
1052 #endif
1053       ees=energia(3)
1054 #ifdef SPLITELE
1055       evdw1=energia(16)
1056 #endif
1057       ecorr=energia(4)
1058       ecorr5=energia(5)
1059       ecorr6=energia(6)
1060       eel_loc=energia(7)
1061       eello_turn3=energia(8)
1062       eello_turn4=energia(9)
1063       eello_turn6=energia(10)
1064       ebe=energia(11)
1065       escloc=energia(12)
1066       etors=energia(13)
1067       etors_d=energia(14)
1068       ehpb=energia(15)
1069       edihcnstr=energia(19)
1070       estr=energia(17)
1071       Uconst=energia(20)
1072       esccor=energia(21)
1073       eliptran=energia(22)
1074       Eafmforce=energia(23)
1075       ethetacnstr=energia(24)
1076 #ifdef SPLITELE
1077       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1078      &  estr,wbond,ebe,wang,
1079      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1080      &  ecorr,wcorr,
1081      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1082      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1083      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1084      &  etot
1085    10 format (/'Virtual-chain energies:'//
1086      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1087      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1088      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1089      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1090      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1091      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1092      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1093      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1094      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1095      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1096      & ' (SS bridges & dist. cnstr.)'/
1097      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1098      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1099      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1100      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1101      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1102      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1103      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1104      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1105      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1106      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1107      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1108      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1109      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1110      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1111      & 'ETOT=  ',1pE16.6,' (total)')
1112
1113 #else
1114       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1115      &  estr,wbond,ebe,wang,
1116      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1117      &  ecorr,wcorr,
1118      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1119      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1120      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1121      &  etot
1122    10 format (/'Virtual-chain energies:'//
1123      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1124      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1125      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1126      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1127      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1128      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1129      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1130      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1131      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1132      & ' (SS bridges & dist. cnstr.)'/
1133      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1134      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1135      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1136      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1137      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1138      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1139      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1140      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1141      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1142      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1143      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1144      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1145      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1146      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1147      & 'ETOT=  ',1pE16.6,' (total)')
1148 #endif
1149       return
1150       end
1151 C-----------------------------------------------------------------------
1152       subroutine elj(evdw)
1153 C
1154 C This subroutine calculates the interaction energy of nonbonded side chains
1155 C assuming the LJ potential of interaction.
1156 C
1157       implicit real*8 (a-h,o-z)
1158       include 'DIMENSIONS'
1159       parameter (accur=1.0d-10)
1160       include 'COMMON.GEO'
1161       include 'COMMON.VAR'
1162       include 'COMMON.LOCAL'
1163       include 'COMMON.CHAIN'
1164       include 'COMMON.DERIV'
1165       include 'COMMON.INTERACT'
1166       include 'COMMON.TORSION'
1167       include 'COMMON.SBRIDGE'
1168       include 'COMMON.NAMES'
1169       include 'COMMON.IOUNITS'
1170       include 'COMMON.CONTACTS'
1171       dimension gg(3)
1172 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1173       evdw=0.0D0
1174       do i=iatsc_s,iatsc_e
1175         itypi=iabs(itype(i))
1176         if (itypi.eq.ntyp1) cycle
1177         itypi1=iabs(itype(i+1))
1178         xi=c(1,nres+i)
1179         yi=c(2,nres+i)
1180         zi=c(3,nres+i)
1181 C Change 12/1/95
1182         num_conti=0
1183 C
1184 C Calculate SC interaction energy.
1185 C
1186         do iint=1,nint_gr(i)
1187 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1188 cd   &                  'iend=',iend(i,iint)
1189           do j=istart(i,iint),iend(i,iint)
1190             itypj=iabs(itype(j))
1191             if (itypj.eq.ntyp1) cycle
1192             xj=c(1,nres+j)-xi
1193             yj=c(2,nres+j)-yi
1194             zj=c(3,nres+j)-zi
1195 C Change 12/1/95 to calculate four-body interactions
1196             rij=xj*xj+yj*yj+zj*zj
1197             rrij=1.0D0/rij
1198 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1199             eps0ij=eps(itypi,itypj)
1200             fac=rrij**expon2
1201 C have you changed here?
1202             e1=fac*fac*aa
1203             e2=fac*bb
1204             evdwij=e1+e2
1205 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1206 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1207 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1208 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1209 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1210 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1211             evdw=evdw+evdwij
1212 C
1213 C Calculate the components of the gradient in DC and X
1214 C
1215             fac=-rrij*(e1+evdwij)
1216             gg(1)=xj*fac
1217             gg(2)=yj*fac
1218             gg(3)=zj*fac
1219             do k=1,3
1220               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1221               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1222               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1223               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1224             enddo
1225 cgrad            do k=i,j-1
1226 cgrad              do l=1,3
1227 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1228 cgrad              enddo
1229 cgrad            enddo
1230 C
1231 C 12/1/95, revised on 5/20/97
1232 C
1233 C Calculate the contact function. The ith column of the array JCONT will
1234 C contain the numbers of atoms that make contacts with the atom I (of numbers
1235 C greater than I). The arrays FACONT and GACONT will contain the values of
1236 C the contact function and its derivative.
1237 C
1238 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1239 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1240 C Uncomment next line, if the correlation interactions are contact function only
1241             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1242               rij=dsqrt(rij)
1243               sigij=sigma(itypi,itypj)
1244               r0ij=rs0(itypi,itypj)
1245 C
1246 C Check whether the SC's are not too far to make a contact.
1247 C
1248               rcut=1.5d0*r0ij
1249               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1250 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1251 C
1252               if (fcont.gt.0.0D0) then
1253 C If the SC-SC distance if close to sigma, apply spline.
1254 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1255 cAdam &             fcont1,fprimcont1)
1256 cAdam           fcont1=1.0d0-fcont1
1257 cAdam           if (fcont1.gt.0.0d0) then
1258 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1259 cAdam             fcont=fcont*fcont1
1260 cAdam           endif
1261 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1262 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1263 cga             do k=1,3
1264 cga               gg(k)=gg(k)*eps0ij
1265 cga             enddo
1266 cga             eps0ij=-evdwij*eps0ij
1267 C Uncomment for AL's type of SC correlation interactions.
1268 cadam           eps0ij=-evdwij
1269                 num_conti=num_conti+1
1270                 jcont(num_conti,i)=j
1271                 facont(num_conti,i)=fcont*eps0ij
1272                 fprimcont=eps0ij*fprimcont/rij
1273                 fcont=expon*fcont
1274 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1275 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1276 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1277 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1278                 gacont(1,num_conti,i)=-fprimcont*xj
1279                 gacont(2,num_conti,i)=-fprimcont*yj
1280                 gacont(3,num_conti,i)=-fprimcont*zj
1281 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1282 cd              write (iout,'(2i3,3f10.5)')
1283 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1284               endif
1285             endif
1286           enddo      ! j
1287         enddo        ! iint
1288 C Change 12/1/95
1289         num_cont(i)=num_conti
1290       enddo          ! i
1291       do i=1,nct
1292         do j=1,3
1293           gvdwc(j,i)=expon*gvdwc(j,i)
1294           gvdwx(j,i)=expon*gvdwx(j,i)
1295         enddo
1296       enddo
1297 C******************************************************************************
1298 C
1299 C                              N O T E !!!
1300 C
1301 C To save time, the factor of EXPON has been extracted from ALL components
1302 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1303 C use!
1304 C
1305 C******************************************************************************
1306       return
1307       end
1308 C-----------------------------------------------------------------------------
1309       subroutine eljk(evdw)
1310 C
1311 C This subroutine calculates the interaction energy of nonbonded side chains
1312 C assuming the LJK potential of interaction.
1313 C
1314       implicit real*8 (a-h,o-z)
1315       include 'DIMENSIONS'
1316       include 'COMMON.GEO'
1317       include 'COMMON.VAR'
1318       include 'COMMON.LOCAL'
1319       include 'COMMON.CHAIN'
1320       include 'COMMON.DERIV'
1321       include 'COMMON.INTERACT'
1322       include 'COMMON.IOUNITS'
1323       include 'COMMON.NAMES'
1324       dimension gg(3)
1325       logical scheck
1326 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1327       evdw=0.0D0
1328       do i=iatsc_s,iatsc_e
1329         itypi=iabs(itype(i))
1330         if (itypi.eq.ntyp1) cycle
1331         itypi1=iabs(itype(i+1))
1332         xi=c(1,nres+i)
1333         yi=c(2,nres+i)
1334         zi=c(3,nres+i)
1335 C
1336 C Calculate SC interaction energy.
1337 C
1338         do iint=1,nint_gr(i)
1339           do j=istart(i,iint),iend(i,iint)
1340             itypj=iabs(itype(j))
1341             if (itypj.eq.ntyp1) cycle
1342             xj=c(1,nres+j)-xi
1343             yj=c(2,nres+j)-yi
1344             zj=c(3,nres+j)-zi
1345             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1346             fac_augm=rrij**expon
1347             e_augm=augm(itypi,itypj)*fac_augm
1348             r_inv_ij=dsqrt(rrij)
1349             rij=1.0D0/r_inv_ij
1350             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1351             fac=r_shift_inv**expon
1352 C have you changed here?
1353             e1=fac*fac*aa
1354             e2=fac*bb
1355             evdwij=e_augm+e1+e2
1356 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1357 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1358 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1359 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1360 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1361 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1362 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1363             evdw=evdw+evdwij
1364 C
1365 C Calculate the components of the gradient in DC and X
1366 C
1367             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1368             gg(1)=xj*fac
1369             gg(2)=yj*fac
1370             gg(3)=zj*fac
1371             do k=1,3
1372               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1373               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1374               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1375               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1376             enddo
1377 cgrad            do k=i,j-1
1378 cgrad              do l=1,3
1379 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1380 cgrad              enddo
1381 cgrad            enddo
1382           enddo      ! j
1383         enddo        ! iint
1384       enddo          ! i
1385       do i=1,nct
1386         do j=1,3
1387           gvdwc(j,i)=expon*gvdwc(j,i)
1388           gvdwx(j,i)=expon*gvdwx(j,i)
1389         enddo
1390       enddo
1391       return
1392       end
1393 C-----------------------------------------------------------------------------
1394       subroutine ebp(evdw)
1395 C
1396 C This subroutine calculates the interaction energy of nonbonded side chains
1397 C assuming the Berne-Pechukas potential of interaction.
1398 C
1399       implicit real*8 (a-h,o-z)
1400       include 'DIMENSIONS'
1401       include 'COMMON.GEO'
1402       include 'COMMON.VAR'
1403       include 'COMMON.LOCAL'
1404       include 'COMMON.CHAIN'
1405       include 'COMMON.DERIV'
1406       include 'COMMON.NAMES'
1407       include 'COMMON.INTERACT'
1408       include 'COMMON.IOUNITS'
1409       include 'COMMON.CALC'
1410       common /srutu/ icall
1411 c     double precision rrsave(maxdim)
1412       logical lprn
1413       evdw=0.0D0
1414 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1415       evdw=0.0D0
1416 c     if (icall.eq.0) then
1417 c       lprn=.true.
1418 c     else
1419         lprn=.false.
1420 c     endif
1421       ind=0
1422       do i=iatsc_s,iatsc_e
1423         itypi=iabs(itype(i))
1424         if (itypi.eq.ntyp1) cycle
1425         itypi1=iabs(itype(i+1))
1426         xi=c(1,nres+i)
1427         yi=c(2,nres+i)
1428         zi=c(3,nres+i)
1429         dxi=dc_norm(1,nres+i)
1430         dyi=dc_norm(2,nres+i)
1431         dzi=dc_norm(3,nres+i)
1432 c        dsci_inv=dsc_inv(itypi)
1433         dsci_inv=vbld_inv(i+nres)
1434 C
1435 C Calculate SC interaction energy.
1436 C
1437         do iint=1,nint_gr(i)
1438           do j=istart(i,iint),iend(i,iint)
1439             ind=ind+1
1440             itypj=iabs(itype(j))
1441             if (itypj.eq.ntyp1) cycle
1442 c            dscj_inv=dsc_inv(itypj)
1443             dscj_inv=vbld_inv(j+nres)
1444             chi1=chi(itypi,itypj)
1445             chi2=chi(itypj,itypi)
1446             chi12=chi1*chi2
1447             chip1=chip(itypi)
1448             chip2=chip(itypj)
1449             chip12=chip1*chip2
1450             alf1=alp(itypi)
1451             alf2=alp(itypj)
1452             alf12=0.5D0*(alf1+alf2)
1453 C For diagnostics only!!!
1454 c           chi1=0.0D0
1455 c           chi2=0.0D0
1456 c           chi12=0.0D0
1457 c           chip1=0.0D0
1458 c           chip2=0.0D0
1459 c           chip12=0.0D0
1460 c           alf1=0.0D0
1461 c           alf2=0.0D0
1462 c           alf12=0.0D0
1463             xj=c(1,nres+j)-xi
1464             yj=c(2,nres+j)-yi
1465             zj=c(3,nres+j)-zi
1466             dxj=dc_norm(1,nres+j)
1467             dyj=dc_norm(2,nres+j)
1468             dzj=dc_norm(3,nres+j)
1469             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1470 cd          if (icall.eq.0) then
1471 cd            rrsave(ind)=rrij
1472 cd          else
1473 cd            rrij=rrsave(ind)
1474 cd          endif
1475             rij=dsqrt(rrij)
1476 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1477             call sc_angular
1478 C Calculate whole angle-dependent part of epsilon and contributions
1479 C to its derivatives
1480 C have you changed here?
1481             fac=(rrij*sigsq)**expon2
1482             e1=fac*fac*aa
1483             e2=fac*bb
1484             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1485             eps2der=evdwij*eps3rt
1486             eps3der=evdwij*eps2rt
1487             evdwij=evdwij*eps2rt*eps3rt
1488             evdw=evdw+evdwij
1489             if (lprn) then
1490             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1491             epsi=bb**2/aa
1492 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1495 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1496 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1497 cd     &        evdwij
1498             endif
1499 C Calculate gradient components.
1500             e1=e1*eps1*eps2rt**2*eps3rt**2
1501             fac=-expon*(e1+evdwij)
1502             sigder=fac/sigsq
1503             fac=rrij*fac
1504 C Calculate radial part of the gradient
1505             gg(1)=xj*fac
1506             gg(2)=yj*fac
1507             gg(3)=zj*fac
1508 C Calculate the angular part of the gradient and sum add the contributions
1509 C to the appropriate components of the Cartesian gradient.
1510             call sc_grad
1511           enddo      ! j
1512         enddo        ! iint
1513       enddo          ! i
1514 c     stop
1515       return
1516       end
1517 C-----------------------------------------------------------------------------
1518       subroutine egb(evdw)
1519 C
1520 C This subroutine calculates the interaction energy of nonbonded side chains
1521 C assuming the Gay-Berne potential of interaction.
1522 C
1523       implicit real*8 (a-h,o-z)
1524       include 'DIMENSIONS'
1525       include 'COMMON.GEO'
1526       include 'COMMON.VAR'
1527       include 'COMMON.LOCAL'
1528       include 'COMMON.CHAIN'
1529       include 'COMMON.DERIV'
1530       include 'COMMON.NAMES'
1531       include 'COMMON.INTERACT'
1532       include 'COMMON.IOUNITS'
1533       include 'COMMON.CALC'
1534       include 'COMMON.CONTROL'
1535       include 'COMMON.SPLITELE'
1536       include 'COMMON.SBRIDGE'
1537       logical lprn
1538       integer xshift,yshift,zshift
1539
1540       evdw=0.0D0
1541 ccccc      energy_dec=.false.
1542 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1543       evdw=0.0D0
1544       lprn=.false.
1545 c     if (icall.eq.0) lprn=.false.
1546       ind=0
1547 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1548 C we have the original box)
1549 C      do xshift=-1,1
1550 C      do yshift=-1,1
1551 C      do zshift=-1,1
1552       do i=iatsc_s,iatsc_e
1553         itypi=iabs(itype(i))
1554         if (itypi.eq.ntyp1) cycle
1555         itypi1=iabs(itype(i+1))
1556         xi=c(1,nres+i)
1557         yi=c(2,nres+i)
1558         zi=c(3,nres+i)
1559 C Return atom into box, boxxsize is size of box in x dimension
1560 c  134   continue
1561 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1562 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1563 C Condition for being inside the proper box
1564 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1565 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1566 c        go to 134
1567 c        endif
1568 c  135   continue
1569 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1570 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1571 C Condition for being inside the proper box
1572 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1573 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1574 c        go to 135
1575 c        endif
1576 c  136   continue
1577 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1578 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1579 C Condition for being inside the proper box
1580 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1581 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1582 c        go to 136
1583 c        endif
1584           xi=mod(xi,boxxsize)
1585           if (xi.lt.0) xi=xi+boxxsize
1586           yi=mod(yi,boxysize)
1587           if (yi.lt.0) yi=yi+boxysize
1588           zi=mod(zi,boxzsize)
1589           if (zi.lt.0) zi=zi+boxzsize
1590 C define scaling factor for lipids
1591
1592 C        if (positi.le.0) positi=positi+boxzsize
1593 C        print *,i
1594 C first for peptide groups
1595 c for each residue check if it is in lipid or lipid water border area
1596        if ((zi.gt.bordlipbot)
1597      &.and.(zi.lt.bordliptop)) then
1598 C the energy transfer exist
1599         if (zi.lt.buflipbot) then
1600 C what fraction I am in
1601          fracinbuf=1.0d0-
1602      &        ((zi-bordlipbot)/lipbufthick)
1603 C lipbufthick is thickenes of lipid buffore
1604          sslipi=sscalelip(fracinbuf)
1605          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1606         elseif (zi.gt.bufliptop) then
1607          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1608          sslipi=sscalelip(fracinbuf)
1609          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1610         else
1611          sslipi=1.0d0
1612          ssgradlipi=0.0
1613         endif
1614        else
1615          sslipi=0.0d0
1616          ssgradlipi=0.0
1617        endif
1618
1619 C          xi=xi+xshift*boxxsize
1620 C          yi=yi+yshift*boxysize
1621 C          zi=zi+zshift*boxzsize
1622
1623         dxi=dc_norm(1,nres+i)
1624         dyi=dc_norm(2,nres+i)
1625         dzi=dc_norm(3,nres+i)
1626 c        dsci_inv=dsc_inv(itypi)
1627         dsci_inv=vbld_inv(i+nres)
1628 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1629 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1630 C
1631 C Calculate SC interaction energy.
1632 C
1633         do iint=1,nint_gr(i)
1634           do j=istart(i,iint),iend(i,iint)
1635             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1636
1637 c              write(iout,*) "PRZED ZWYKLE", evdwij
1638               call dyn_ssbond_ene(i,j,evdwij)
1639 c              write(iout,*) "PO ZWYKLE", evdwij
1640
1641               evdw=evdw+evdwij
1642               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1643      &                        'evdw',i,j,evdwij,' ss'
1644 C triple bond artifac removal
1645              do k=j+1,iend(i,iint)
1646 C search over all next residues
1647               if (dyn_ss_mask(k)) then
1648 C check if they are cysteins
1649 C              write(iout,*) 'k=',k
1650
1651 c              write(iout,*) "PRZED TRI", evdwij
1652                evdwij_przed_tri=evdwij
1653               call triple_ssbond_ene(i,j,k,evdwij)
1654 c               if(evdwij_przed_tri.ne.evdwij) then
1655 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1656 c               endif
1657
1658 c              write(iout,*) "PO TRI", evdwij
1659 C call the energy function that removes the artifical triple disulfide
1660 C bond the soubroutine is located in ssMD.F
1661               evdw=evdw+evdwij
1662               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1663      &                        'evdw',i,j,evdwij,'tss'
1664               endif!dyn_ss_mask(k)
1665              enddo! k
1666             ELSE
1667             ind=ind+1
1668             itypj=iabs(itype(j))
1669             if (itypj.eq.ntyp1) cycle
1670 c            dscj_inv=dsc_inv(itypj)
1671             dscj_inv=vbld_inv(j+nres)
1672 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1673 c     &       1.0d0/vbld(j+nres)
1674 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1675             sig0ij=sigma(itypi,itypj)
1676             chi1=chi(itypi,itypj)
1677             chi2=chi(itypj,itypi)
1678             chi12=chi1*chi2
1679             chip1=chip(itypi)
1680             chip2=chip(itypj)
1681             chip12=chip1*chip2
1682             alf1=alp(itypi)
1683             alf2=alp(itypj)
1684             alf12=0.5D0*(alf1+alf2)
1685 C For diagnostics only!!!
1686 c           chi1=0.0D0
1687 c           chi2=0.0D0
1688 c           chi12=0.0D0
1689 c           chip1=0.0D0
1690 c           chip2=0.0D0
1691 c           chip12=0.0D0
1692 c           alf1=0.0D0
1693 c           alf2=0.0D0
1694 c           alf12=0.0D0
1695             xj=c(1,nres+j)
1696             yj=c(2,nres+j)
1697             zj=c(3,nres+j)
1698 C Return atom J into box the original box
1699 c  137   continue
1700 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1701 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1702 C Condition for being inside the proper box
1703 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1704 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1705 c        go to 137
1706 c        endif
1707 c  138   continue
1708 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1709 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1710 C Condition for being inside the proper box
1711 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1712 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1713 c        go to 138
1714 c        endif
1715 c  139   continue
1716 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1717 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1718 C Condition for being inside the proper box
1719 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1720 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1721 c        go to 139
1722 c        endif
1723           xj=mod(xj,boxxsize)
1724           if (xj.lt.0) xj=xj+boxxsize
1725           yj=mod(yj,boxysize)
1726           if (yj.lt.0) yj=yj+boxysize
1727           zj=mod(zj,boxzsize)
1728           if (zj.lt.0) zj=zj+boxzsize
1729        if ((zj.gt.bordlipbot)
1730      &.and.(zj.lt.bordliptop)) then
1731 C the energy transfer exist
1732         if (zj.lt.buflipbot) then
1733 C what fraction I am in
1734          fracinbuf=1.0d0-
1735      &        ((zj-bordlipbot)/lipbufthick)
1736 C lipbufthick is thickenes of lipid buffore
1737          sslipj=sscalelip(fracinbuf)
1738          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1739         elseif (zj.gt.bufliptop) then
1740          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1741          sslipj=sscalelip(fracinbuf)
1742          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1743         else
1744          sslipj=1.0d0
1745          ssgradlipj=0.0
1746         endif
1747        else
1748          sslipj=0.0d0
1749          ssgradlipj=0.0
1750        endif
1751       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1752      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1753       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1754      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1755 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1756 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1757 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1758 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1759       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1760       xj_safe=xj
1761       yj_safe=yj
1762       zj_safe=zj
1763       subchap=0
1764       do xshift=-1,1
1765       do yshift=-1,1
1766       do zshift=-1,1
1767           xj=xj_safe+xshift*boxxsize
1768           yj=yj_safe+yshift*boxysize
1769           zj=zj_safe+zshift*boxzsize
1770           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1771           if(dist_temp.lt.dist_init) then
1772             dist_init=dist_temp
1773             xj_temp=xj
1774             yj_temp=yj
1775             zj_temp=zj
1776             subchap=1
1777           endif
1778        enddo
1779        enddo
1780        enddo
1781        if (subchap.eq.1) then
1782           xj=xj_temp-xi
1783           yj=yj_temp-yi
1784           zj=zj_temp-zi
1785        else
1786           xj=xj_safe-xi
1787           yj=yj_safe-yi
1788           zj=zj_safe-zi
1789        endif
1790             dxj=dc_norm(1,nres+j)
1791             dyj=dc_norm(2,nres+j)
1792             dzj=dc_norm(3,nres+j)
1793 C            xj=xj-xi
1794 C            yj=yj-yi
1795 C            zj=zj-zi
1796 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1797 c            write (iout,*) "j",j," dc_norm",
1798 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1799             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1800             rij=dsqrt(rrij)
1801             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1802             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1803
1804 c            write (iout,'(a7,4f8.3)')
1805 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1806             if (sss.gt.0.0d0) then
1807 C Calculate angle-dependent terms of energy and contributions to their
1808 C derivatives.
1809             call sc_angular
1810             sigsq=1.0D0/sigsq
1811             sig=sig0ij*dsqrt(sigsq)
1812             rij_shift=1.0D0/rij-sig+sig0ij
1813 c for diagnostics; uncomment
1814 c            rij_shift=1.2*sig0ij
1815 C I hate to put IF's in the loops, but here don't have another choice!!!!
1816             if (rij_shift.le.0.0D0) then
1817               evdw=1.0D20
1818 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1819 cd     &        restyp(itypi),i,restyp(itypj),j,
1820 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1821               return
1822             endif
1823             sigder=-sig*sigsq
1824 c---------------------------------------------------------------
1825             rij_shift=1.0D0/rij_shift
1826             fac=rij_shift**expon
1827 C here to start with
1828 C            if (c(i,3).gt.
1829             faclip=fac
1830             e1=fac*fac*aa
1831             e2=fac*bb
1832             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1833             eps2der=evdwij*eps3rt
1834             eps3der=evdwij*eps2rt
1835 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1836 C     &((sslipi+sslipj)/2.0d0+
1837 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1838 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1839 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1840             evdwij=evdwij*eps2rt*eps3rt
1841             evdw=evdw+evdwij*sss
1842             if (lprn) then
1843             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1844             epsi=bb**2/aa
1845             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1846      &        restyp(itypi),i,restyp(itypj),j,
1847      &        epsi,sigm,chi1,chi2,chip1,chip2,
1848      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1849      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1850      &        evdwij
1851             endif
1852
1853             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1854      &                        'evdw',i,j,evdwij
1855
1856 C Calculate gradient components.
1857             e1=e1*eps1*eps2rt**2*eps3rt**2
1858             fac=-expon*(e1+evdwij)*rij_shift
1859             sigder=fac*sigder
1860             fac=rij*fac
1861 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1862 c     &      evdwij,fac,sigma(itypi,itypj),expon
1863             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1864 c            fac=0.0d0
1865 C Calculate the radial part of the gradient
1866             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1867      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1868      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1869      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1870             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1871             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1872 C            gg_lipi(3)=0.0d0
1873 C            gg_lipj(3)=0.0d0
1874             gg(1)=xj*fac
1875             gg(2)=yj*fac
1876             gg(3)=zj*fac
1877 C Calculate angular part of the gradient.
1878             call sc_grad
1879             endif
1880             ENDIF    ! dyn_ss
1881           enddo      ! j
1882         enddo        ! iint
1883       enddo          ! i
1884 C      enddo          ! zshift
1885 C      enddo          ! yshift
1886 C      enddo          ! xshift
1887 c      write (iout,*) "Number of loop steps in EGB:",ind
1888 cccc      energy_dec=.false.
1889       return
1890       end
1891 C-----------------------------------------------------------------------------
1892       subroutine egbv(evdw)
1893 C
1894 C This subroutine calculates the interaction energy of nonbonded side chains
1895 C assuming the Gay-Berne-Vorobjev potential of interaction.
1896 C
1897       implicit real*8 (a-h,o-z)
1898       include 'DIMENSIONS'
1899       include 'COMMON.GEO'
1900       include 'COMMON.VAR'
1901       include 'COMMON.LOCAL'
1902       include 'COMMON.CHAIN'
1903       include 'COMMON.DERIV'
1904       include 'COMMON.NAMES'
1905       include 'COMMON.INTERACT'
1906       include 'COMMON.IOUNITS'
1907       include 'COMMON.CALC'
1908       common /srutu/ icall
1909       logical lprn
1910       evdw=0.0D0
1911 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1912       evdw=0.0D0
1913       lprn=.false.
1914 c     if (icall.eq.0) lprn=.true.
1915       ind=0
1916       do i=iatsc_s,iatsc_e
1917         itypi=iabs(itype(i))
1918         if (itypi.eq.ntyp1) cycle
1919         itypi1=iabs(itype(i+1))
1920         xi=c(1,nres+i)
1921         yi=c(2,nres+i)
1922         zi=c(3,nres+i)
1923           xi=mod(xi,boxxsize)
1924           if (xi.lt.0) xi=xi+boxxsize
1925           yi=mod(yi,boxysize)
1926           if (yi.lt.0) yi=yi+boxysize
1927           zi=mod(zi,boxzsize)
1928           if (zi.lt.0) zi=zi+boxzsize
1929 C define scaling factor for lipids
1930
1931 C        if (positi.le.0) positi=positi+boxzsize
1932 C        print *,i
1933 C first for peptide groups
1934 c for each residue check if it is in lipid or lipid water border area
1935        if ((zi.gt.bordlipbot)
1936      &.and.(zi.lt.bordliptop)) then
1937 C the energy transfer exist
1938         if (zi.lt.buflipbot) then
1939 C what fraction I am in
1940          fracinbuf=1.0d0-
1941      &        ((zi-bordlipbot)/lipbufthick)
1942 C lipbufthick is thickenes of lipid buffore
1943          sslipi=sscalelip(fracinbuf)
1944          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1945         elseif (zi.gt.bufliptop) then
1946          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1947          sslipi=sscalelip(fracinbuf)
1948          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1949         else
1950          sslipi=1.0d0
1951          ssgradlipi=0.0
1952         endif
1953        else
1954          sslipi=0.0d0
1955          ssgradlipi=0.0
1956        endif
1957
1958         dxi=dc_norm(1,nres+i)
1959         dyi=dc_norm(2,nres+i)
1960         dzi=dc_norm(3,nres+i)
1961 c        dsci_inv=dsc_inv(itypi)
1962         dsci_inv=vbld_inv(i+nres)
1963 C
1964 C Calculate SC interaction energy.
1965 C
1966         do iint=1,nint_gr(i)
1967           do j=istart(i,iint),iend(i,iint)
1968             ind=ind+1
1969             itypj=iabs(itype(j))
1970             if (itypj.eq.ntyp1) cycle
1971 c            dscj_inv=dsc_inv(itypj)
1972             dscj_inv=vbld_inv(j+nres)
1973             sig0ij=sigma(itypi,itypj)
1974             r0ij=r0(itypi,itypj)
1975             chi1=chi(itypi,itypj)
1976             chi2=chi(itypj,itypi)
1977             chi12=chi1*chi2
1978             chip1=chip(itypi)
1979             chip2=chip(itypj)
1980             chip12=chip1*chip2
1981             alf1=alp(itypi)
1982             alf2=alp(itypj)
1983             alf12=0.5D0*(alf1+alf2)
1984 C For diagnostics only!!!
1985 c           chi1=0.0D0
1986 c           chi2=0.0D0
1987 c           chi12=0.0D0
1988 c           chip1=0.0D0
1989 c           chip2=0.0D0
1990 c           chip12=0.0D0
1991 c           alf1=0.0D0
1992 c           alf2=0.0D0
1993 c           alf12=0.0D0
1994 C            xj=c(1,nres+j)-xi
1995 C            yj=c(2,nres+j)-yi
1996 C            zj=c(3,nres+j)-zi
1997           xj=mod(xj,boxxsize)
1998           if (xj.lt.0) xj=xj+boxxsize
1999           yj=mod(yj,boxysize)
2000           if (yj.lt.0) yj=yj+boxysize
2001           zj=mod(zj,boxzsize)
2002           if (zj.lt.0) zj=zj+boxzsize
2003        if ((zj.gt.bordlipbot)
2004      &.and.(zj.lt.bordliptop)) then
2005 C the energy transfer exist
2006         if (zj.lt.buflipbot) then
2007 C what fraction I am in
2008          fracinbuf=1.0d0-
2009      &        ((zj-bordlipbot)/lipbufthick)
2010 C lipbufthick is thickenes of lipid buffore
2011          sslipj=sscalelip(fracinbuf)
2012          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2013         elseif (zj.gt.bufliptop) then
2014          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2015          sslipj=sscalelip(fracinbuf)
2016          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2017         else
2018          sslipj=1.0d0
2019          ssgradlipj=0.0
2020         endif
2021        else
2022          sslipj=0.0d0
2023          ssgradlipj=0.0
2024        endif
2025       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2026      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2027       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2028      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2029 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2030 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2031       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2032       xj_safe=xj
2033       yj_safe=yj
2034       zj_safe=zj
2035       subchap=0
2036       do xshift=-1,1
2037       do yshift=-1,1
2038       do zshift=-1,1
2039           xj=xj_safe+xshift*boxxsize
2040           yj=yj_safe+yshift*boxysize
2041           zj=zj_safe+zshift*boxzsize
2042           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2043           if(dist_temp.lt.dist_init) then
2044             dist_init=dist_temp
2045             xj_temp=xj
2046             yj_temp=yj
2047             zj_temp=zj
2048             subchap=1
2049           endif
2050        enddo
2051        enddo
2052        enddo
2053        if (subchap.eq.1) then
2054           xj=xj_temp-xi
2055           yj=yj_temp-yi
2056           zj=zj_temp-zi
2057        else
2058           xj=xj_safe-xi
2059           yj=yj_safe-yi
2060           zj=zj_safe-zi
2061        endif
2062             dxj=dc_norm(1,nres+j)
2063             dyj=dc_norm(2,nres+j)
2064             dzj=dc_norm(3,nres+j)
2065             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2066             rij=dsqrt(rrij)
2067 C Calculate angle-dependent terms of energy and contributions to their
2068 C derivatives.
2069             call sc_angular
2070             sigsq=1.0D0/sigsq
2071             sig=sig0ij*dsqrt(sigsq)
2072             rij_shift=1.0D0/rij-sig+r0ij
2073 C I hate to put IF's in the loops, but here don't have another choice!!!!
2074             if (rij_shift.le.0.0D0) then
2075               evdw=1.0D20
2076               return
2077             endif
2078             sigder=-sig*sigsq
2079 c---------------------------------------------------------------
2080             rij_shift=1.0D0/rij_shift
2081             fac=rij_shift**expon
2082             e1=fac*fac*aa
2083             e2=fac*bb
2084             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2085             eps2der=evdwij*eps3rt
2086             eps3der=evdwij*eps2rt
2087             fac_augm=rrij**expon
2088             e_augm=augm(itypi,itypj)*fac_augm
2089             evdwij=evdwij*eps2rt*eps3rt
2090             evdw=evdw+evdwij+e_augm
2091             if (lprn) then
2092             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2093             epsi=bb**2/aa
2094             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2095      &        restyp(itypi),i,restyp(itypj),j,
2096      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2097      &        chi1,chi2,chip1,chip2,
2098      &        eps1,eps2rt**2,eps3rt**2,
2099      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2100      &        evdwij+e_augm
2101             endif
2102 C Calculate gradient components.
2103             e1=e1*eps1*eps2rt**2*eps3rt**2
2104             fac=-expon*(e1+evdwij)*rij_shift
2105             sigder=fac*sigder
2106             fac=rij*fac-2*expon*rrij*e_augm
2107             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2108 C Calculate the radial part of the gradient
2109             gg(1)=xj*fac
2110             gg(2)=yj*fac
2111             gg(3)=zj*fac
2112 C Calculate angular part of the gradient.
2113             call sc_grad
2114           enddo      ! j
2115         enddo        ! iint
2116       enddo          ! i
2117       end
2118 C-----------------------------------------------------------------------------
2119       subroutine sc_angular
2120 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2121 C om12. Called by ebp, egb, and egbv.
2122       implicit none
2123       include 'COMMON.CALC'
2124       include 'COMMON.IOUNITS'
2125       erij(1)=xj*rij
2126       erij(2)=yj*rij
2127       erij(3)=zj*rij
2128       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2129       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2130       om12=dxi*dxj+dyi*dyj+dzi*dzj
2131       chiom12=chi12*om12
2132 C Calculate eps1(om12) and its derivative in om12
2133       faceps1=1.0D0-om12*chiom12
2134       faceps1_inv=1.0D0/faceps1
2135       eps1=dsqrt(faceps1_inv)
2136 C Following variable is eps1*deps1/dom12
2137       eps1_om12=faceps1_inv*chiom12
2138 c diagnostics only
2139 c      faceps1_inv=om12
2140 c      eps1=om12
2141 c      eps1_om12=1.0d0
2142 c      write (iout,*) "om12",om12," eps1",eps1
2143 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2144 C and om12.
2145       om1om2=om1*om2
2146       chiom1=chi1*om1
2147       chiom2=chi2*om2
2148       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2149       sigsq=1.0D0-facsig*faceps1_inv
2150       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2151       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2152       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2153 c diagnostics only
2154 c      sigsq=1.0d0
2155 c      sigsq_om1=0.0d0
2156 c      sigsq_om2=0.0d0
2157 c      sigsq_om12=0.0d0
2158 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2159 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2160 c     &    " eps1",eps1
2161 C Calculate eps2 and its derivatives in om1, om2, and om12.
2162       chipom1=chip1*om1
2163       chipom2=chip2*om2
2164       chipom12=chip12*om12
2165       facp=1.0D0-om12*chipom12
2166       facp_inv=1.0D0/facp
2167       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2168 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2169 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2170 C Following variable is the square root of eps2
2171       eps2rt=1.0D0-facp1*facp_inv
2172 C Following three variables are the derivatives of the square root of eps
2173 C in om1, om2, and om12.
2174       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2175       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2176       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2177 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2178       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2179 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2180 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2181 c     &  " eps2rt_om12",eps2rt_om12
2182 C Calculate whole angle-dependent part of epsilon and contributions
2183 C to its derivatives
2184       return
2185       end
2186 C----------------------------------------------------------------------------
2187       subroutine sc_grad
2188       implicit real*8 (a-h,o-z)
2189       include 'DIMENSIONS'
2190       include 'COMMON.CHAIN'
2191       include 'COMMON.DERIV'
2192       include 'COMMON.CALC'
2193       include 'COMMON.IOUNITS'
2194       double precision dcosom1(3),dcosom2(3)
2195 cc      print *,'sss=',sss
2196       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2197       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2198       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2199      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2200 c diagnostics only
2201 c      eom1=0.0d0
2202 c      eom2=0.0d0
2203 c      eom12=evdwij*eps1_om12
2204 c end diagnostics
2205 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2206 c     &  " sigder",sigder
2207 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2208 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2209       do k=1,3
2210         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2211         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2212       enddo
2213       do k=1,3
2214         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2215       enddo
2216 c      write (iout,*) "gg",(gg(k),k=1,3)
2217       do k=1,3
2218         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2219      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2220      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2221         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2222      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2223      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2224 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2225 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2226 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2227 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2228       enddo
2229 C
2230 C Calculate the components of the gradient in DC and X
2231 C
2232 cgrad      do k=i,j-1
2233 cgrad        do l=1,3
2234 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2235 cgrad        enddo
2236 cgrad      enddo
2237       do l=1,3
2238         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2239         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2240       enddo
2241       return
2242       end
2243 C-----------------------------------------------------------------------
2244       subroutine e_softsphere(evdw)
2245 C
2246 C This subroutine calculates the interaction energy of nonbonded side chains
2247 C assuming the LJ potential of interaction.
2248 C
2249       implicit real*8 (a-h,o-z)
2250       include 'DIMENSIONS'
2251       parameter (accur=1.0d-10)
2252       include 'COMMON.GEO'
2253       include 'COMMON.VAR'
2254       include 'COMMON.LOCAL'
2255       include 'COMMON.CHAIN'
2256       include 'COMMON.DERIV'
2257       include 'COMMON.INTERACT'
2258       include 'COMMON.TORSION'
2259       include 'COMMON.SBRIDGE'
2260       include 'COMMON.NAMES'
2261       include 'COMMON.IOUNITS'
2262       include 'COMMON.CONTACTS'
2263       dimension gg(3)
2264 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2265       evdw=0.0D0
2266       do i=iatsc_s,iatsc_e
2267         itypi=iabs(itype(i))
2268         if (itypi.eq.ntyp1) cycle
2269         itypi1=iabs(itype(i+1))
2270         xi=c(1,nres+i)
2271         yi=c(2,nres+i)
2272         zi=c(3,nres+i)
2273 C
2274 C Calculate SC interaction energy.
2275 C
2276         do iint=1,nint_gr(i)
2277 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2278 cd   &                  'iend=',iend(i,iint)
2279           do j=istart(i,iint),iend(i,iint)
2280             itypj=iabs(itype(j))
2281             if (itypj.eq.ntyp1) cycle
2282             xj=c(1,nres+j)-xi
2283             yj=c(2,nres+j)-yi
2284             zj=c(3,nres+j)-zi
2285             rij=xj*xj+yj*yj+zj*zj
2286 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2287             r0ij=r0(itypi,itypj)
2288             r0ijsq=r0ij*r0ij
2289 c            print *,i,j,r0ij,dsqrt(rij)
2290             if (rij.lt.r0ijsq) then
2291               evdwij=0.25d0*(rij-r0ijsq)**2
2292               fac=rij-r0ijsq
2293             else
2294               evdwij=0.0d0
2295               fac=0.0d0
2296             endif
2297             evdw=evdw+evdwij
2298 C
2299 C Calculate the components of the gradient in DC and X
2300 C
2301             gg(1)=xj*fac
2302             gg(2)=yj*fac
2303             gg(3)=zj*fac
2304             do k=1,3
2305               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2306               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2307               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2308               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2309             enddo
2310 cgrad            do k=i,j-1
2311 cgrad              do l=1,3
2312 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2313 cgrad              enddo
2314 cgrad            enddo
2315           enddo ! j
2316         enddo ! iint
2317       enddo ! i
2318       return
2319       end
2320 C--------------------------------------------------------------------------
2321       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2322      &              eello_turn4)
2323 C
2324 C Soft-sphere potential of p-p interaction
2325 C
2326       implicit real*8 (a-h,o-z)
2327       include 'DIMENSIONS'
2328       include 'COMMON.CONTROL'
2329       include 'COMMON.IOUNITS'
2330       include 'COMMON.GEO'
2331       include 'COMMON.VAR'
2332       include 'COMMON.LOCAL'
2333       include 'COMMON.CHAIN'
2334       include 'COMMON.DERIV'
2335       include 'COMMON.INTERACT'
2336       include 'COMMON.CONTACTS'
2337       include 'COMMON.TORSION'
2338       include 'COMMON.VECTORS'
2339       include 'COMMON.FFIELD'
2340       dimension ggg(3)
2341 C      write(iout,*) 'In EELEC_soft_sphere'
2342       ees=0.0D0
2343       evdw1=0.0D0
2344       eel_loc=0.0d0
2345       eello_turn3=0.0d0
2346       eello_turn4=0.0d0
2347       ind=0
2348       do i=iatel_s,iatel_e
2349         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2350         dxi=dc(1,i)
2351         dyi=dc(2,i)
2352         dzi=dc(3,i)
2353         xmedi=c(1,i)+0.5d0*dxi
2354         ymedi=c(2,i)+0.5d0*dyi
2355         zmedi=c(3,i)+0.5d0*dzi
2356           xmedi=mod(xmedi,boxxsize)
2357           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2358           ymedi=mod(ymedi,boxysize)
2359           if (ymedi.lt.0) ymedi=ymedi+boxysize
2360           zmedi=mod(zmedi,boxzsize)
2361           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2362         num_conti=0
2363 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2364         do j=ielstart(i),ielend(i)
2365           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2366           ind=ind+1
2367           iteli=itel(i)
2368           itelj=itel(j)
2369           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2370           r0ij=rpp(iteli,itelj)
2371           r0ijsq=r0ij*r0ij
2372           dxj=dc(1,j)
2373           dyj=dc(2,j)
2374           dzj=dc(3,j)
2375           xj=c(1,j)+0.5D0*dxj
2376           yj=c(2,j)+0.5D0*dyj
2377           zj=c(3,j)+0.5D0*dzj
2378           xj=mod(xj,boxxsize)
2379           if (xj.lt.0) xj=xj+boxxsize
2380           yj=mod(yj,boxysize)
2381           if (yj.lt.0) yj=yj+boxysize
2382           zj=mod(zj,boxzsize)
2383           if (zj.lt.0) zj=zj+boxzsize
2384       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2385       xj_safe=xj
2386       yj_safe=yj
2387       zj_safe=zj
2388       isubchap=0
2389       do xshift=-1,1
2390       do yshift=-1,1
2391       do zshift=-1,1
2392           xj=xj_safe+xshift*boxxsize
2393           yj=yj_safe+yshift*boxysize
2394           zj=zj_safe+zshift*boxzsize
2395           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2396           if(dist_temp.lt.dist_init) then
2397             dist_init=dist_temp
2398             xj_temp=xj
2399             yj_temp=yj
2400             zj_temp=zj
2401             isubchap=1
2402           endif
2403        enddo
2404        enddo
2405        enddo
2406        if (isubchap.eq.1) then
2407           xj=xj_temp-xmedi
2408           yj=yj_temp-ymedi
2409           zj=zj_temp-zmedi
2410        else
2411           xj=xj_safe-xmedi
2412           yj=yj_safe-ymedi
2413           zj=zj_safe-zmedi
2414        endif
2415           rij=xj*xj+yj*yj+zj*zj
2416             sss=sscale(sqrt(rij))
2417             sssgrad=sscagrad(sqrt(rij))
2418           if (rij.lt.r0ijsq) then
2419             evdw1ij=0.25d0*(rij-r0ijsq)**2
2420             fac=rij-r0ijsq
2421           else
2422             evdw1ij=0.0d0
2423             fac=0.0d0
2424           endif
2425           evdw1=evdw1+evdw1ij*sss
2426 C
2427 C Calculate contributions to the Cartesian gradient.
2428 C
2429           ggg(1)=fac*xj*sssgrad
2430           ggg(2)=fac*yj*sssgrad
2431           ggg(3)=fac*zj*sssgrad
2432           do k=1,3
2433             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2434             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2435           enddo
2436 *
2437 * Loop over residues i+1 thru j-1.
2438 *
2439 cgrad          do k=i+1,j-1
2440 cgrad            do l=1,3
2441 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2442 cgrad            enddo
2443 cgrad          enddo
2444         enddo ! j
2445       enddo   ! i
2446 cgrad      do i=nnt,nct-1
2447 cgrad        do k=1,3
2448 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2449 cgrad        enddo
2450 cgrad        do j=i+1,nct-1
2451 cgrad          do k=1,3
2452 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2453 cgrad          enddo
2454 cgrad        enddo
2455 cgrad      enddo
2456       return
2457       end
2458 c------------------------------------------------------------------------------
2459       subroutine vec_and_deriv
2460       implicit real*8 (a-h,o-z)
2461       include 'DIMENSIONS'
2462 #ifdef MPI
2463       include 'mpif.h'
2464 #endif
2465       include 'COMMON.IOUNITS'
2466       include 'COMMON.GEO'
2467       include 'COMMON.VAR'
2468       include 'COMMON.LOCAL'
2469       include 'COMMON.CHAIN'
2470       include 'COMMON.VECTORS'
2471       include 'COMMON.SETUP'
2472       include 'COMMON.TIME1'
2473       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2474 C Compute the local reference systems. For reference system (i), the
2475 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2476 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2477 #ifdef PARVEC
2478       do i=ivec_start,ivec_end
2479 #else
2480       do i=1,nres-1
2481 #endif
2482           if (i.eq.nres-1) then
2483 C Case of the last full residue
2484 C Compute the Z-axis
2485             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2486             costh=dcos(pi-theta(nres))
2487             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2488             do k=1,3
2489               uz(k,i)=fac*uz(k,i)
2490             enddo
2491 C Compute the derivatives of uz
2492             uzder(1,1,1)= 0.0d0
2493             uzder(2,1,1)=-dc_norm(3,i-1)
2494             uzder(3,1,1)= dc_norm(2,i-1)
2495             uzder(1,2,1)= dc_norm(3,i-1)
2496             uzder(2,2,1)= 0.0d0
2497             uzder(3,2,1)=-dc_norm(1,i-1)
2498             uzder(1,3,1)=-dc_norm(2,i-1)
2499             uzder(2,3,1)= dc_norm(1,i-1)
2500             uzder(3,3,1)= 0.0d0
2501             uzder(1,1,2)= 0.0d0
2502             uzder(2,1,2)= dc_norm(3,i)
2503             uzder(3,1,2)=-dc_norm(2,i)
2504             uzder(1,2,2)=-dc_norm(3,i)
2505             uzder(2,2,2)= 0.0d0
2506             uzder(3,2,2)= dc_norm(1,i)
2507             uzder(1,3,2)= dc_norm(2,i)
2508             uzder(2,3,2)=-dc_norm(1,i)
2509             uzder(3,3,2)= 0.0d0
2510 C Compute the Y-axis
2511             facy=fac
2512             do k=1,3
2513               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2514             enddo
2515 C Compute the derivatives of uy
2516             do j=1,3
2517               do k=1,3
2518                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2519      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2520                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2521               enddo
2522               uyder(j,j,1)=uyder(j,j,1)-costh
2523               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2524             enddo
2525             do j=1,2
2526               do k=1,3
2527                 do l=1,3
2528                   uygrad(l,k,j,i)=uyder(l,k,j)
2529                   uzgrad(l,k,j,i)=uzder(l,k,j)
2530                 enddo
2531               enddo
2532             enddo
2533             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2534             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2535             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2536             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2537           else
2538 C Other residues
2539 C Compute the Z-axis
2540             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2541             costh=dcos(pi-theta(i+2))
2542             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2543             do k=1,3
2544               uz(k,i)=fac*uz(k,i)
2545             enddo
2546 C Compute the derivatives of uz
2547             uzder(1,1,1)= 0.0d0
2548             uzder(2,1,1)=-dc_norm(3,i+1)
2549             uzder(3,1,1)= dc_norm(2,i+1)
2550             uzder(1,2,1)= dc_norm(3,i+1)
2551             uzder(2,2,1)= 0.0d0
2552             uzder(3,2,1)=-dc_norm(1,i+1)
2553             uzder(1,3,1)=-dc_norm(2,i+1)
2554             uzder(2,3,1)= dc_norm(1,i+1)
2555             uzder(3,3,1)= 0.0d0
2556             uzder(1,1,2)= 0.0d0
2557             uzder(2,1,2)= dc_norm(3,i)
2558             uzder(3,1,2)=-dc_norm(2,i)
2559             uzder(1,2,2)=-dc_norm(3,i)
2560             uzder(2,2,2)= 0.0d0
2561             uzder(3,2,2)= dc_norm(1,i)
2562             uzder(1,3,2)= dc_norm(2,i)
2563             uzder(2,3,2)=-dc_norm(1,i)
2564             uzder(3,3,2)= 0.0d0
2565 C Compute the Y-axis
2566             facy=fac
2567             do k=1,3
2568               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2569             enddo
2570 C Compute the derivatives of uy
2571             do j=1,3
2572               do k=1,3
2573                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2574      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2575                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2576               enddo
2577               uyder(j,j,1)=uyder(j,j,1)-costh
2578               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2579             enddo
2580             do j=1,2
2581               do k=1,3
2582                 do l=1,3
2583                   uygrad(l,k,j,i)=uyder(l,k,j)
2584                   uzgrad(l,k,j,i)=uzder(l,k,j)
2585                 enddo
2586               enddo
2587             enddo
2588             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2589             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2590             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2591             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2592           endif
2593       enddo
2594       do i=1,nres-1
2595         vbld_inv_temp(1)=vbld_inv(i+1)
2596         if (i.lt.nres-1) then
2597           vbld_inv_temp(2)=vbld_inv(i+2)
2598           else
2599           vbld_inv_temp(2)=vbld_inv(i)
2600           endif
2601         do j=1,2
2602           do k=1,3
2603             do l=1,3
2604               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2605               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2606             enddo
2607           enddo
2608         enddo
2609       enddo
2610 #if defined(PARVEC) && defined(MPI)
2611       if (nfgtasks1.gt.1) then
2612         time00=MPI_Wtime()
2613 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2614 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2615 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2616         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2617      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2618      &   FG_COMM1,IERR)
2619         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2620      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2621      &   FG_COMM1,IERR)
2622         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2623      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2624      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2625         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2626      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2627      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2628         time_gather=time_gather+MPI_Wtime()-time00
2629       endif
2630 c      if (fg_rank.eq.0) then
2631 c        write (iout,*) "Arrays UY and UZ"
2632 c        do i=1,nres-1
2633 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2634 c     &     (uz(k,i),k=1,3)
2635 c        enddo
2636 c      endif
2637 #endif
2638       return
2639       end
2640 C-----------------------------------------------------------------------------
2641       subroutine check_vecgrad
2642       implicit real*8 (a-h,o-z)
2643       include 'DIMENSIONS'
2644       include 'COMMON.IOUNITS'
2645       include 'COMMON.GEO'
2646       include 'COMMON.VAR'
2647       include 'COMMON.LOCAL'
2648       include 'COMMON.CHAIN'
2649       include 'COMMON.VECTORS'
2650       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2651       dimension uyt(3,maxres),uzt(3,maxres)
2652       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2653       double precision delta /1.0d-7/
2654       call vec_and_deriv
2655 cd      do i=1,nres
2656 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2657 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2658 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2659 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2660 cd     &     (dc_norm(if90,i),if90=1,3)
2661 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2662 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2663 cd          write(iout,'(a)')
2664 cd      enddo
2665       do i=1,nres
2666         do j=1,2
2667           do k=1,3
2668             do l=1,3
2669               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2670               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2671             enddo
2672           enddo
2673         enddo
2674       enddo
2675       call vec_and_deriv
2676       do i=1,nres
2677         do j=1,3
2678           uyt(j,i)=uy(j,i)
2679           uzt(j,i)=uz(j,i)
2680         enddo
2681       enddo
2682       do i=1,nres
2683 cd        write (iout,*) 'i=',i
2684         do k=1,3
2685           erij(k)=dc_norm(k,i)
2686         enddo
2687         do j=1,3
2688           do k=1,3
2689             dc_norm(k,i)=erij(k)
2690           enddo
2691           dc_norm(j,i)=dc_norm(j,i)+delta
2692 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2693 c          do k=1,3
2694 c            dc_norm(k,i)=dc_norm(k,i)/fac
2695 c          enddo
2696 c          write (iout,*) (dc_norm(k,i),k=1,3)
2697 c          write (iout,*) (erij(k),k=1,3)
2698           call vec_and_deriv
2699           do k=1,3
2700             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2701             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2702             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2703             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2704           enddo
2705 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2706 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2707 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2708         enddo
2709         do k=1,3
2710           dc_norm(k,i)=erij(k)
2711         enddo
2712 cd        do k=1,3
2713 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2714 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2715 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2716 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2717 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2718 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2719 cd          write (iout,'(a)')
2720 cd        enddo
2721       enddo
2722       return
2723       end
2724 C--------------------------------------------------------------------------
2725       subroutine set_matrices
2726       implicit real*8 (a-h,o-z)
2727       include 'DIMENSIONS'
2728 #ifdef MPI
2729       include "mpif.h"
2730       include "COMMON.SETUP"
2731       integer IERR
2732       integer status(MPI_STATUS_SIZE)
2733 #endif
2734       include 'COMMON.IOUNITS'
2735       include 'COMMON.GEO'
2736       include 'COMMON.VAR'
2737       include 'COMMON.LOCAL'
2738       include 'COMMON.CHAIN'
2739       include 'COMMON.DERIV'
2740       include 'COMMON.INTERACT'
2741       include 'COMMON.CONTACTS'
2742       include 'COMMON.TORSION'
2743       include 'COMMON.VECTORS'
2744       include 'COMMON.FFIELD'
2745       double precision auxvec(2),auxmat(2,2)
2746 C
2747 C Compute the virtual-bond-torsional-angle dependent quantities needed
2748 C to calculate the el-loc multibody terms of various order.
2749 C
2750 c      write(iout,*) 'nphi=',nphi,nres
2751 #ifdef PARMAT
2752       do i=ivec_start+2,ivec_end+2
2753 #else
2754       do i=3,nres+1
2755 #endif
2756 #ifdef NEWCORR
2757         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2758           iti = itortyp(itype(i-2))
2759         else
2760           iti=ntortyp+1
2761         endif
2762 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2763         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2764           iti1 = itortyp(itype(i-1))
2765         else
2766           iti1=ntortyp+1
2767         endif
2768 c        write(iout,*),i
2769         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2770      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2771      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2772         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2773      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2774      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2775 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2776 c     &*(cos(theta(i)/2.0)
2777         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2778      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2779      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2780 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2781 c     &*(cos(theta(i)/2.0)
2782         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2783      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2784      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2785 c        if (ggb1(1,i).eq.0.0d0) then
2786 c        write(iout,*) 'i=',i,ggb1(1,i),
2787 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2788 c     &bnew1(2,1,iti)*cos(theta(i)),
2789 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2790 c        endif
2791         b1(2,i-2)=bnew1(1,2,iti)
2792         gtb1(2,i-2)=0.0
2793         b2(2,i-2)=bnew2(1,2,iti)
2794         gtb2(2,i-2)=0.0
2795         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2796         EE(1,2,i-2)=eeold(1,2,iti)
2797         EE(2,1,i-2)=eeold(2,1,iti)
2798         EE(2,2,i-2)=eeold(2,2,iti)
2799         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2800         gtEE(1,2,i-2)=0.0d0
2801         gtEE(2,2,i-2)=0.0d0
2802         gtEE(2,1,i-2)=0.0d0
2803 c        EE(2,2,iti)=0.0d0
2804 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2805 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2806 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2807 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2808        b1tilde(1,i-2)=b1(1,i-2)
2809        b1tilde(2,i-2)=-b1(2,i-2)
2810        b2tilde(1,i-2)=b2(1,i-2)
2811        b2tilde(2,i-2)=-b2(2,i-2)
2812 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2813 c       write(iout,*)  'b1=',b1(1,i-2)
2814 c       write (iout,*) 'theta=', theta(i-1)
2815        enddo
2816 #else
2817         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2818           iti = itortyp(itype(i-2))
2819         else
2820           iti=ntortyp+1
2821         endif
2822 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2823         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2824           iti1 = itortyp(itype(i-1))
2825         else
2826           iti1=ntortyp+1
2827         endif
2828         b1(1,i-2)=b(3,iti)
2829         b1(2,i-2)=b(5,iti)
2830         b2(1,i-2)=b(2,iti)
2831         b2(2,i-2)=b(4,iti)
2832        b1tilde(1,i-2)=b1(1,i-2)
2833        b1tilde(2,i-2)=-b1(2,i-2)
2834        b2tilde(1,i-2)=b2(1,i-2)
2835        b2tilde(2,i-2)=-b2(2,i-2)
2836         EE(1,2,i-2)=eeold(1,2,iti)
2837         EE(2,1,i-2)=eeold(2,1,iti)
2838         EE(2,2,i-2)=eeold(2,2,iti)
2839         EE(1,1,i-2)=eeold(1,1,iti)
2840       enddo
2841 #endif
2842 #ifdef PARMAT
2843       do i=ivec_start+2,ivec_end+2
2844 #else
2845       do i=3,nres+1
2846 #endif
2847         if (i .lt. nres+1) then
2848           sin1=dsin(phi(i))
2849           cos1=dcos(phi(i))
2850           sintab(i-2)=sin1
2851           costab(i-2)=cos1
2852           obrot(1,i-2)=cos1
2853           obrot(2,i-2)=sin1
2854           sin2=dsin(2*phi(i))
2855           cos2=dcos(2*phi(i))
2856           sintab2(i-2)=sin2
2857           costab2(i-2)=cos2
2858           obrot2(1,i-2)=cos2
2859           obrot2(2,i-2)=sin2
2860           Ug(1,1,i-2)=-cos1
2861           Ug(1,2,i-2)=-sin1
2862           Ug(2,1,i-2)=-sin1
2863           Ug(2,2,i-2)= cos1
2864           Ug2(1,1,i-2)=-cos2
2865           Ug2(1,2,i-2)=-sin2
2866           Ug2(2,1,i-2)=-sin2
2867           Ug2(2,2,i-2)= cos2
2868         else
2869           costab(i-2)=1.0d0
2870           sintab(i-2)=0.0d0
2871           obrot(1,i-2)=1.0d0
2872           obrot(2,i-2)=0.0d0
2873           obrot2(1,i-2)=0.0d0
2874           obrot2(2,i-2)=0.0d0
2875           Ug(1,1,i-2)=1.0d0
2876           Ug(1,2,i-2)=0.0d0
2877           Ug(2,1,i-2)=0.0d0
2878           Ug(2,2,i-2)=1.0d0
2879           Ug2(1,1,i-2)=0.0d0
2880           Ug2(1,2,i-2)=0.0d0
2881           Ug2(2,1,i-2)=0.0d0
2882           Ug2(2,2,i-2)=0.0d0
2883         endif
2884         if (i .gt. 3 .and. i .lt. nres+1) then
2885           obrot_der(1,i-2)=-sin1
2886           obrot_der(2,i-2)= cos1
2887           Ugder(1,1,i-2)= sin1
2888           Ugder(1,2,i-2)=-cos1
2889           Ugder(2,1,i-2)=-cos1
2890           Ugder(2,2,i-2)=-sin1
2891           dwacos2=cos2+cos2
2892           dwasin2=sin2+sin2
2893           obrot2_der(1,i-2)=-dwasin2
2894           obrot2_der(2,i-2)= dwacos2
2895           Ug2der(1,1,i-2)= dwasin2
2896           Ug2der(1,2,i-2)=-dwacos2
2897           Ug2der(2,1,i-2)=-dwacos2
2898           Ug2der(2,2,i-2)=-dwasin2
2899         else
2900           obrot_der(1,i-2)=0.0d0
2901           obrot_der(2,i-2)=0.0d0
2902           Ugder(1,1,i-2)=0.0d0
2903           Ugder(1,2,i-2)=0.0d0
2904           Ugder(2,1,i-2)=0.0d0
2905           Ugder(2,2,i-2)=0.0d0
2906           obrot2_der(1,i-2)=0.0d0
2907           obrot2_der(2,i-2)=0.0d0
2908           Ug2der(1,1,i-2)=0.0d0
2909           Ug2der(1,2,i-2)=0.0d0
2910           Ug2der(2,1,i-2)=0.0d0
2911           Ug2der(2,2,i-2)=0.0d0
2912         endif
2913 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2914         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2915           iti = itortyp(itype(i-2))
2916         else
2917           iti=ntortyp
2918         endif
2919 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2920         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2921           iti1 = itortyp(itype(i-1))
2922         else
2923           iti1=ntortyp
2924         endif
2925 cd        write (iout,*) '*******i',i,' iti1',iti
2926 cd        write (iout,*) 'b1',b1(:,iti)
2927 cd        write (iout,*) 'b2',b2(:,iti)
2928 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2929 c        if (i .gt. iatel_s+2) then
2930         if (i .gt. nnt+2) then
2931           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2932 #ifdef NEWCORR
2933           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2934 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2935 #endif
2936 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2937 c     &    EE(1,2,iti),EE(2,2,iti)
2938           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2939           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2940 c          write(iout,*) "Macierz EUG",
2941 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2942 c     &    eug(2,2,i-2)
2943           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2944      &    then
2945           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2946           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2947           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2948           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2949           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2950           endif
2951         else
2952           do k=1,2
2953             Ub2(k,i-2)=0.0d0
2954             Ctobr(k,i-2)=0.0d0
2955             Dtobr2(k,i-2)=0.0d0
2956             do l=1,2
2957               EUg(l,k,i-2)=0.0d0
2958               CUg(l,k,i-2)=0.0d0
2959               DUg(l,k,i-2)=0.0d0
2960               DtUg2(l,k,i-2)=0.0d0
2961             enddo
2962           enddo
2963         endif
2964         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2965         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2966         do k=1,2
2967           muder(k,i-2)=Ub2der(k,i-2)
2968         enddo
2969 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2970         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2971           if (itype(i-1).le.ntyp) then
2972             iti1 = itortyp(itype(i-1))
2973           else
2974             iti1=ntortyp
2975           endif
2976         else
2977           iti1=ntortyp
2978         endif
2979         do k=1,2
2980           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2981         enddo
2982 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2983 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2984 cd        write (iout,*) 'mu1',mu1(:,i-2)
2985 cd        write (iout,*) 'mu2',mu2(:,i-2)
2986         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2987      &  then
2988         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2989         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2990         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2991         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2992         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2993 C Vectors and matrices dependent on a single virtual-bond dihedral.
2994         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2995         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2996         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2997         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2998         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2999         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3000         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3001         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3002         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3003         endif
3004       enddo
3005 C Matrices dependent on two consecutive virtual-bond dihedrals.
3006 C The order of matrices is from left to right.
3007       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3008      &then
3009 c      do i=max0(ivec_start,2),ivec_end
3010       do i=2,nres-1
3011         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3012         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3013         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3014         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3015         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3016         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3017         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3018         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3019       enddo
3020       endif
3021 #if defined(MPI) && defined(PARMAT)
3022 #ifdef DEBUG
3023 c      if (fg_rank.eq.0) then
3024         write (iout,*) "Arrays UG and UGDER before GATHER"
3025         do i=1,nres-1
3026           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3027      &     ((ug(l,k,i),l=1,2),k=1,2),
3028      &     ((ugder(l,k,i),l=1,2),k=1,2)
3029         enddo
3030         write (iout,*) "Arrays UG2 and UG2DER"
3031         do i=1,nres-1
3032           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3033      &     ((ug2(l,k,i),l=1,2),k=1,2),
3034      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3035         enddo
3036         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3037         do i=1,nres-1
3038           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3039      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3040      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3041         enddo
3042         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3043         do i=1,nres-1
3044           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3045      &     costab(i),sintab(i),costab2(i),sintab2(i)
3046         enddo
3047         write (iout,*) "Array MUDER"
3048         do i=1,nres-1
3049           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3050         enddo
3051 c      endif
3052 #endif
3053       if (nfgtasks.gt.1) then
3054         time00=MPI_Wtime()
3055 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3056 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3057 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3058 #ifdef MATGATHER
3059         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3060      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3061      &   FG_COMM1,IERR)
3062         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3063      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3064      &   FG_COMM1,IERR)
3065         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3066      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3067      &   FG_COMM1,IERR)
3068         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3069      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3070      &   FG_COMM1,IERR)
3071         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3072      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3073      &   FG_COMM1,IERR)
3074         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3075      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3076      &   FG_COMM1,IERR)
3077         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3078      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3079      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3080         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3081      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3082      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3083         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3084      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3085      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3086         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3087      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3088      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3089         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3090      &  then
3091         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3098      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3099      &   FG_COMM1,IERR)
3100        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3101      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3102      &   FG_COMM1,IERR)
3103         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3104      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3105      &   FG_COMM1,IERR)
3106         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3107      &   ivec_count(fg_rank1),
3108      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3109      &   FG_COMM1,IERR)
3110         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3115      &   FG_COMM1,IERR)
3116         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3118      &   FG_COMM1,IERR)
3119         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3121      &   FG_COMM1,IERR)
3122         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3123      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3124      &   FG_COMM1,IERR)
3125         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3126      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3127      &   FG_COMM1,IERR)
3128         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3129      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3130      &   FG_COMM1,IERR)
3131         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3132      &   ivec_count(fg_rank1),
3133      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3134      &   FG_COMM1,IERR)
3135         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3136      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3137      &   FG_COMM1,IERR)
3138        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3139      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3140      &   FG_COMM1,IERR)
3141         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3142      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3143      &   FG_COMM1,IERR)
3144        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3145      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3146      &   FG_COMM1,IERR)
3147         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3148      &   ivec_count(fg_rank1),
3149      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3150      &   FG_COMM1,IERR)
3151         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3152      &   ivec_count(fg_rank1),
3153      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3154      &   FG_COMM1,IERR)
3155         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3156      &   ivec_count(fg_rank1),
3157      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3158      &   MPI_MAT2,FG_COMM1,IERR)
3159         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3160      &   ivec_count(fg_rank1),
3161      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3162      &   MPI_MAT2,FG_COMM1,IERR)
3163         endif
3164 #else
3165 c Passes matrix info through the ring
3166       isend=fg_rank1
3167       irecv=fg_rank1-1
3168       if (irecv.lt.0) irecv=nfgtasks1-1
3169       iprev=irecv
3170       inext=fg_rank1+1
3171       if (inext.ge.nfgtasks1) inext=0
3172       do i=1,nfgtasks1-1
3173 c        write (iout,*) "isend",isend," irecv",irecv
3174 c        call flush(iout)
3175         lensend=lentyp(isend)
3176         lenrecv=lentyp(irecv)
3177 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3178 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3179 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3180 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3181 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3182 c        write (iout,*) "Gather ROTAT1"
3183 c        call flush(iout)
3184 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3185 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3186 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3187 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3188 c        write (iout,*) "Gather ROTAT2"
3189 c        call flush(iout)
3190         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3191      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3192      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3193      &   iprev,4400+irecv,FG_COMM,status,IERR)
3194 c        write (iout,*) "Gather ROTAT_OLD"
3195 c        call flush(iout)
3196         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3197      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3198      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3199      &   iprev,5500+irecv,FG_COMM,status,IERR)
3200 c        write (iout,*) "Gather PRECOMP11"
3201 c        call flush(iout)
3202         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3203      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3204      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3205      &   iprev,6600+irecv,FG_COMM,status,IERR)
3206 c        write (iout,*) "Gather PRECOMP12"
3207 c        call flush(iout)
3208         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3209      &  then
3210         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3211      &   MPI_ROTAT2(lensend),inext,7700+isend,
3212      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3213      &   iprev,7700+irecv,FG_COMM,status,IERR)
3214 c        write (iout,*) "Gather PRECOMP21"
3215 c        call flush(iout)
3216         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3217      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3218      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3219      &   iprev,8800+irecv,FG_COMM,status,IERR)
3220 c        write (iout,*) "Gather PRECOMP22"
3221 c        call flush(iout)
3222         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3223      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3224      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3225      &   MPI_PRECOMP23(lenrecv),
3226      &   iprev,9900+irecv,FG_COMM,status,IERR)
3227 c        write (iout,*) "Gather PRECOMP23"
3228 c        call flush(iout)
3229         endif
3230         isend=irecv
3231         irecv=irecv-1
3232         if (irecv.lt.0) irecv=nfgtasks1-1
3233       enddo
3234 #endif
3235         time_gather=time_gather+MPI_Wtime()-time00
3236       endif
3237 #ifdef DEBUG
3238 c      if (fg_rank.eq.0) then
3239         write (iout,*) "Arrays UG and UGDER"
3240         do i=1,nres-1
3241           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3242      &     ((ug(l,k,i),l=1,2),k=1,2),
3243      &     ((ugder(l,k,i),l=1,2),k=1,2)
3244         enddo
3245         write (iout,*) "Arrays UG2 and UG2DER"
3246         do i=1,nres-1
3247           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3248      &     ((ug2(l,k,i),l=1,2),k=1,2),
3249      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3250         enddo
3251         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3252         do i=1,nres-1
3253           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3254      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3255      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3256         enddo
3257         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3258         do i=1,nres-1
3259           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3260      &     costab(i),sintab(i),costab2(i),sintab2(i)
3261         enddo
3262         write (iout,*) "Array MUDER"
3263         do i=1,nres-1
3264           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3265         enddo
3266 c      endif
3267 #endif
3268 #endif
3269 cd      do i=1,nres
3270 cd        iti = itortyp(itype(i))
3271 cd        write (iout,*) i
3272 cd        do j=1,2
3273 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3274 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3275 cd        enddo
3276 cd      enddo
3277       return
3278       end
3279 C--------------------------------------------------------------------------
3280       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3281 C
3282 C This subroutine calculates the average interaction energy and its gradient
3283 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3284 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3285 C The potential depends both on the distance of peptide-group centers and on
3286 C the orientation of the CA-CA virtual bonds.
3287 C
3288       implicit real*8 (a-h,o-z)
3289 #ifdef MPI
3290       include 'mpif.h'
3291 #endif
3292       include 'DIMENSIONS'
3293       include 'COMMON.CONTROL'
3294       include 'COMMON.SETUP'
3295       include 'COMMON.IOUNITS'
3296       include 'COMMON.GEO'
3297       include 'COMMON.VAR'
3298       include 'COMMON.LOCAL'
3299       include 'COMMON.CHAIN'
3300       include 'COMMON.DERIV'
3301       include 'COMMON.INTERACT'
3302       include 'COMMON.CONTACTS'
3303       include 'COMMON.TORSION'
3304       include 'COMMON.VECTORS'
3305       include 'COMMON.FFIELD'
3306       include 'COMMON.TIME1'
3307       include 'COMMON.SPLITELE'
3308       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3309      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3310       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3311      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3312       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3313      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3314      &    num_conti,j1,j2
3315 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3316 #ifdef MOMENT
3317       double precision scal_el /1.0d0/
3318 #else
3319       double precision scal_el /0.5d0/
3320 #endif
3321 C 12/13/98
3322 C 13-go grudnia roku pamietnego...
3323       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3324      &                   0.0d0,1.0d0,0.0d0,
3325      &                   0.0d0,0.0d0,1.0d0/
3326 cd      write(iout,*) 'In EELEC'
3327 cd      do i=1,nloctyp
3328 cd        write(iout,*) 'Type',i
3329 cd        write(iout,*) 'B1',B1(:,i)
3330 cd        write(iout,*) 'B2',B2(:,i)
3331 cd        write(iout,*) 'CC',CC(:,:,i)
3332 cd        write(iout,*) 'DD',DD(:,:,i)
3333 cd        write(iout,*) 'EE',EE(:,:,i)
3334 cd      enddo
3335 cd      call check_vecgrad
3336 cd      stop
3337       if (icheckgrad.eq.1) then
3338         do i=1,nres-1
3339           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3340           do k=1,3
3341             dc_norm(k,i)=dc(k,i)*fac
3342           enddo
3343 c          write (iout,*) 'i',i,' fac',fac
3344         enddo
3345       endif
3346       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3347      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3348      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3349 c        call vec_and_deriv
3350 #ifdef TIMING
3351         time01=MPI_Wtime()
3352 #endif
3353         call set_matrices
3354 #ifdef TIMING
3355         time_mat=time_mat+MPI_Wtime()-time01
3356 #endif
3357       endif
3358 cd      do i=1,nres-1
3359 cd        write (iout,*) 'i=',i
3360 cd        do k=1,3
3361 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3362 cd        enddo
3363 cd        do k=1,3
3364 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3365 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3366 cd        enddo
3367 cd      enddo
3368       t_eelecij=0.0d0
3369       ees=0.0D0
3370       evdw1=0.0D0
3371       eel_loc=0.0d0
3372       eello_turn3=0.0d0
3373       eello_turn4=0.0d0
3374       ind=0
3375       do i=1,nres
3376         num_cont_hb(i)=0
3377       enddo
3378 cd      print '(a)','Enter EELEC'
3379 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3380       do i=1,nres
3381         gel_loc_loc(i)=0.0d0
3382         gcorr_loc(i)=0.0d0
3383       enddo
3384 c
3385 c
3386 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3387 C
3388 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3389 C
3390 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3391       do i=iturn3_start,iturn3_end
3392         if (i.le.1) cycle
3393 C        write(iout,*) "tu jest i",i
3394         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3395 C changes suggested by Ana to avoid out of bounds
3396      & .or.((i+4).gt.nres)
3397      & .or.((i-1).le.0)
3398 C end of changes by Ana
3399      &  .or. itype(i+2).eq.ntyp1
3400      &  .or. itype(i+3).eq.ntyp1) cycle
3401         if(i.gt.1)then
3402           if(itype(i-1).eq.ntyp1)cycle
3403         end if
3404         if(i.LT.nres-3)then
3405           if (itype(i+4).eq.ntyp1) cycle
3406         end if
3407         dxi=dc(1,i)
3408         dyi=dc(2,i)
3409         dzi=dc(3,i)
3410         dx_normi=dc_norm(1,i)
3411         dy_normi=dc_norm(2,i)
3412         dz_normi=dc_norm(3,i)
3413         xmedi=c(1,i)+0.5d0*dxi
3414         ymedi=c(2,i)+0.5d0*dyi
3415         zmedi=c(3,i)+0.5d0*dzi
3416           xmedi=mod(xmedi,boxxsize)
3417           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3418           ymedi=mod(ymedi,boxysize)
3419           if (ymedi.lt.0) ymedi=ymedi+boxysize
3420           zmedi=mod(zmedi,boxzsize)
3421           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3422         num_conti=0
3423         call eelecij(i,i+2,ees,evdw1,eel_loc)
3424         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3425         num_cont_hb(i)=num_conti
3426       enddo
3427       do i=iturn4_start,iturn4_end
3428         if (i.le.1) cycle
3429         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3430 C changes suggested by Ana to avoid out of bounds
3431      & .or.((i+5).gt.nres)
3432      & .or.((i-1).le.0)
3433 C end of changes suggested by Ana
3434      &    .or. itype(i+3).eq.ntyp1
3435      &    .or. itype(i+4).eq.ntyp1
3436      &    .or. itype(i+5).eq.ntyp1
3437      &    .or. itype(i).eq.ntyp1
3438      &    .or. itype(i-1).eq.ntyp1
3439      &                             ) cycle
3440         dxi=dc(1,i)
3441         dyi=dc(2,i)
3442         dzi=dc(3,i)
3443         dx_normi=dc_norm(1,i)
3444         dy_normi=dc_norm(2,i)
3445         dz_normi=dc_norm(3,i)
3446         xmedi=c(1,i)+0.5d0*dxi
3447         ymedi=c(2,i)+0.5d0*dyi
3448         zmedi=c(3,i)+0.5d0*dzi
3449 C Return atom into box, boxxsize is size of box in x dimension
3450 c  194   continue
3451 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3452 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3453 C Condition for being inside the proper box
3454 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3455 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3456 c        go to 194
3457 c        endif
3458 c  195   continue
3459 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3460 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3461 C Condition for being inside the proper box
3462 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3463 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3464 c        go to 195
3465 c        endif
3466 c  196   continue
3467 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3468 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3469 C Condition for being inside the proper box
3470 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3471 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3472 c        go to 196
3473 c        endif
3474           xmedi=mod(xmedi,boxxsize)
3475           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3476           ymedi=mod(ymedi,boxysize)
3477           if (ymedi.lt.0) ymedi=ymedi+boxysize
3478           zmedi=mod(zmedi,boxzsize)
3479           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3480
3481         num_conti=num_cont_hb(i)
3482 c        write(iout,*) "JESTEM W PETLI"
3483         call eelecij(i,i+3,ees,evdw1,eel_loc)
3484         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3485      &   call eturn4(i,eello_turn4)
3486         num_cont_hb(i)=num_conti
3487       enddo   ! i
3488 C Loop over all neighbouring boxes
3489 C      do xshift=-1,1
3490 C      do yshift=-1,1
3491 C      do zshift=-1,1
3492 c
3493 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3494 c
3495 CTU KURWA
3496       do i=iatel_s,iatel_e
3497 C        do i=75,75
3498         if (i.le.1) cycle
3499         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3500 C changes suggested by Ana to avoid out of bounds
3501      & .or.((i+2).gt.nres)
3502      & .or.((i-1).le.0)
3503 C end of changes by Ana
3504      &  .or. itype(i+2).eq.ntyp1
3505      &  .or. itype(i-1).eq.ntyp1
3506      &                ) cycle
3507         dxi=dc(1,i)
3508         dyi=dc(2,i)
3509         dzi=dc(3,i)
3510         dx_normi=dc_norm(1,i)
3511         dy_normi=dc_norm(2,i)
3512         dz_normi=dc_norm(3,i)
3513         xmedi=c(1,i)+0.5d0*dxi
3514         ymedi=c(2,i)+0.5d0*dyi
3515         zmedi=c(3,i)+0.5d0*dzi
3516           xmedi=mod(xmedi,boxxsize)
3517           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3518           ymedi=mod(ymedi,boxysize)
3519           if (ymedi.lt.0) ymedi=ymedi+boxysize
3520           zmedi=mod(zmedi,boxzsize)
3521           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3522 C          xmedi=xmedi+xshift*boxxsize
3523 C          ymedi=ymedi+yshift*boxysize
3524 C          zmedi=zmedi+zshift*boxzsize
3525
3526 C Return tom into box, boxxsize is size of box in x dimension
3527 c  164   continue
3528 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3529 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3530 C Condition for being inside the proper box
3531 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3532 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3533 c        go to 164
3534 c        endif
3535 c  165   continue
3536 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3537 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3538 C Condition for being inside the proper box
3539 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3540 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3541 c        go to 165
3542 c        endif
3543 c  166   continue
3544 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3545 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3546 cC Condition for being inside the proper box
3547 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3548 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3549 c        go to 166
3550 c        endif
3551
3552 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3553         num_conti=num_cont_hb(i)
3554 C I TU KURWA
3555         do j=ielstart(i),ielend(i)
3556 C          do j=16,17
3557 C          write (iout,*) i,j
3558          if (j.le.1) cycle
3559           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3560 C changes suggested by Ana to avoid out of bounds
3561      & .or.((j+2).gt.nres)
3562      & .or.((j-1).le.0)
3563 C end of changes by Ana
3564      & .or.itype(j+2).eq.ntyp1
3565      & .or.itype(j-1).eq.ntyp1
3566      &) cycle
3567           call eelecij(i,j,ees,evdw1,eel_loc)
3568         enddo ! j
3569         num_cont_hb(i)=num_conti
3570       enddo   ! i
3571 C     enddo   ! zshift
3572 C      enddo   ! yshift
3573 C      enddo   ! xshift
3574
3575 c      write (iout,*) "Number of loop steps in EELEC:",ind
3576 cd      do i=1,nres
3577 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3578 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3579 cd      enddo
3580 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3581 ccc      eel_loc=eel_loc+eello_turn3
3582 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3583       return
3584       end
3585 C-------------------------------------------------------------------------------
3586       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3587       implicit real*8 (a-h,o-z)
3588       include 'DIMENSIONS'
3589 #ifdef MPI
3590       include "mpif.h"
3591 #endif
3592       include 'COMMON.CONTROL'
3593       include 'COMMON.IOUNITS'
3594       include 'COMMON.GEO'
3595       include 'COMMON.VAR'
3596       include 'COMMON.LOCAL'
3597       include 'COMMON.CHAIN'
3598       include 'COMMON.DERIV'
3599       include 'COMMON.INTERACT'
3600       include 'COMMON.CONTACTS'
3601       include 'COMMON.TORSION'
3602       include 'COMMON.VECTORS'
3603       include 'COMMON.FFIELD'
3604       include 'COMMON.TIME1'
3605       include 'COMMON.SPLITELE'
3606       include 'COMMON.SHIELD'
3607       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3608      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3609       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3610      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3611      &    gmuij2(4),gmuji2(4)
3612       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3613      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3614      &    num_conti,j1,j2
3615 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3616 #ifdef MOMENT
3617       double precision scal_el /1.0d0/
3618 #else
3619       double precision scal_el /0.5d0/
3620 #endif
3621 C 12/13/98
3622 C 13-go grudnia roku pamietnego...
3623       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3624      &                   0.0d0,1.0d0,0.0d0,
3625      &                   0.0d0,0.0d0,1.0d0/
3626 c          time00=MPI_Wtime()
3627 cd      write (iout,*) "eelecij",i,j
3628 c          ind=ind+1
3629           iteli=itel(i)
3630           itelj=itel(j)
3631           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3632           aaa=app(iteli,itelj)
3633           bbb=bpp(iteli,itelj)
3634           ael6i=ael6(iteli,itelj)
3635           ael3i=ael3(iteli,itelj)
3636           dxj=dc(1,j)
3637           dyj=dc(2,j)
3638           dzj=dc(3,j)
3639           dx_normj=dc_norm(1,j)
3640           dy_normj=dc_norm(2,j)
3641           dz_normj=dc_norm(3,j)
3642 C          xj=c(1,j)+0.5D0*dxj-xmedi
3643 C          yj=c(2,j)+0.5D0*dyj-ymedi
3644 C          zj=c(3,j)+0.5D0*dzj-zmedi
3645           xj=c(1,j)+0.5D0*dxj
3646           yj=c(2,j)+0.5D0*dyj
3647           zj=c(3,j)+0.5D0*dzj
3648           xj=mod(xj,boxxsize)
3649           if (xj.lt.0) xj=xj+boxxsize
3650           yj=mod(yj,boxysize)
3651           if (yj.lt.0) yj=yj+boxysize
3652           zj=mod(zj,boxzsize)
3653           if (zj.lt.0) zj=zj+boxzsize
3654           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3655       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3656       xj_safe=xj
3657       yj_safe=yj
3658       zj_safe=zj
3659       isubchap=0
3660       do xshift=-1,1
3661       do yshift=-1,1
3662       do zshift=-1,1
3663           xj=xj_safe+xshift*boxxsize
3664           yj=yj_safe+yshift*boxysize
3665           zj=zj_safe+zshift*boxzsize
3666           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3667           if(dist_temp.lt.dist_init) then
3668             dist_init=dist_temp
3669             xj_temp=xj
3670             yj_temp=yj
3671             zj_temp=zj
3672             isubchap=1
3673           endif
3674        enddo
3675        enddo
3676        enddo
3677        if (isubchap.eq.1) then
3678           xj=xj_temp-xmedi
3679           yj=yj_temp-ymedi
3680           zj=zj_temp-zmedi
3681        else
3682           xj=xj_safe-xmedi
3683           yj=yj_safe-ymedi
3684           zj=zj_safe-zmedi
3685        endif
3686 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3687 c  174   continue
3688 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3689 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3690 C Condition for being inside the proper box
3691 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3692 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3693 c        go to 174
3694 c        endif
3695 c  175   continue
3696 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3697 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3698 C Condition for being inside the proper box
3699 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3700 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3701 c        go to 175
3702 c        endif
3703 c  176   continue
3704 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3705 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3706 C Condition for being inside the proper box
3707 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3708 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3709 c        go to 176
3710 c        endif
3711 C        endif !endPBC condintion
3712 C        xj=xj-xmedi
3713 C        yj=yj-ymedi
3714 C        zj=zj-zmedi
3715           rij=xj*xj+yj*yj+zj*zj
3716
3717             sss=sscale(sqrt(rij))
3718             sssgrad=sscagrad(sqrt(rij))
3719 c            if (sss.gt.0.0d0) then
3720           rrmij=1.0D0/rij
3721           rij=dsqrt(rij)
3722           rmij=1.0D0/rij
3723           r3ij=rrmij*rmij
3724           r6ij=r3ij*r3ij
3725           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3726           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3727           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3728           fac=cosa-3.0D0*cosb*cosg
3729           ev1=aaa*r6ij*r6ij
3730 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3731           if (j.eq.i+2) ev1=scal_el*ev1
3732           ev2=bbb*r6ij
3733           fac3=ael6i*r6ij
3734           fac4=ael3i*r3ij
3735           evdwij=(ev1+ev2)
3736           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3737           el2=fac4*fac
3738 C MARYSIA
3739 C          eesij=(el1+el2)
3740 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3741           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3742           if (shield_mode.gt.0) then
3743 C          fac_shield(i)=0.4
3744 C          fac_shield(j)=0.6
3745           el1=el1*fac_shield(i)*fac_shield(j)
3746           el2=el2*fac_shield(i)*fac_shield(j)
3747           eesij=(el1+el2)
3748           ees=ees+eesij
3749           else
3750           fac_shield(i)=1.0
3751           fac_shield(j)=1.0
3752           eesij=(el1+el2)
3753           ees=ees+eesij
3754           endif
3755           evdw1=evdw1+evdwij*sss
3756 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3757 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3758 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3759 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3760
3761           if (energy_dec) then
3762               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3763      &'evdw1',i,j,evdwij
3764      &,iteli,itelj,aaa,evdw1
3765               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3766           endif
3767
3768 C
3769 C Calculate contributions to the Cartesian gradient.
3770 C
3771 #ifdef SPLITELE
3772           facvdw=-6*rrmij*(ev1+evdwij)*sss
3773           facel=-3*rrmij*(el1+eesij)
3774           fac1=fac
3775           erij(1)=xj*rmij
3776           erij(2)=yj*rmij
3777           erij(3)=zj*rmij
3778
3779 *
3780 * Radial derivatives. First process both termini of the fragment (i,j)
3781 *
3782           ggg(1)=facel*xj
3783           ggg(2)=facel*yj
3784           ggg(3)=facel*zj
3785           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3786      &  (shield_mode.gt.0)) then
3787 C          print *,i,j
3788           do ilist=1,ishield_list(i)
3789            iresshield=shield_list(ilist,i)
3790            do k=1,3
3791            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3792            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3793      &              rlocshield
3794      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3795             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3796 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3797 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3798 C             if (iresshield.gt.i) then
3799 C               do ishi=i+1,iresshield-1
3800 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3801 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3802 C
3803 C              enddo
3804 C             else
3805 C               do ishi=iresshield,i
3806 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3807 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3808 C
3809 C               enddo
3810 C              endif
3811            enddo
3812           enddo
3813           do ilist=1,ishield_list(j)
3814            iresshield=shield_list(ilist,j)
3815            do k=1,3
3816            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3817            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3818      &              rlocshield
3819      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3820            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3821
3822 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3823 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3824 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3825 C             if (iresshield.gt.j) then
3826 C               do ishi=j+1,iresshield-1
3827 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3828 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3829 C
3830 C               enddo
3831 C            else
3832 C               do ishi=iresshield,j
3833 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3834 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3835 C               enddo
3836 C              endif
3837            enddo
3838           enddo
3839
3840           do k=1,3
3841             gshieldc(k,i)=gshieldc(k,i)+
3842      &              grad_shield(k,i)*eesij/fac_shield(i)
3843             gshieldc(k,j)=gshieldc(k,j)+
3844      &              grad_shield(k,j)*eesij/fac_shield(j)
3845             gshieldc(k,i-1)=gshieldc(k,i-1)+
3846      &              grad_shield(k,i)*eesij/fac_shield(i)
3847             gshieldc(k,j-1)=gshieldc(k,j-1)+
3848      &              grad_shield(k,j)*eesij/fac_shield(j)
3849
3850            enddo
3851            endif
3852 c          do k=1,3
3853 c            ghalf=0.5D0*ggg(k)
3854 c            gelc(k,i)=gelc(k,i)+ghalf
3855 c            gelc(k,j)=gelc(k,j)+ghalf
3856 c          enddo
3857 c 9/28/08 AL Gradient compotents will be summed only at the end
3858 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3859           do k=1,3
3860             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3861 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3862             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3863 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3864 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3865 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3866 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3867 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3868           enddo
3869 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3870
3871 *
3872 * Loop over residues i+1 thru j-1.
3873 *
3874 cgrad          do k=i+1,j-1
3875 cgrad            do l=1,3
3876 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3877 cgrad            enddo
3878 cgrad          enddo
3879           if (sss.gt.0.0) then
3880           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3881           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3882           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3883           else
3884           ggg(1)=0.0
3885           ggg(2)=0.0
3886           ggg(3)=0.0
3887           endif
3888 c          do k=1,3
3889 c            ghalf=0.5D0*ggg(k)
3890 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3891 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3892 c          enddo
3893 c 9/28/08 AL Gradient compotents will be summed only at the end
3894           do k=1,3
3895             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3896             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3897           enddo
3898 *
3899 * Loop over residues i+1 thru j-1.
3900 *
3901 cgrad          do k=i+1,j-1
3902 cgrad            do l=1,3
3903 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3904 cgrad            enddo
3905 cgrad          enddo
3906 #else
3907 C MARYSIA
3908           facvdw=(ev1+evdwij)*sss
3909           facel=(el1+eesij)
3910           fac1=fac
3911           fac=-3*rrmij*(facvdw+facvdw+facel)
3912           erij(1)=xj*rmij
3913           erij(2)=yj*rmij
3914           erij(3)=zj*rmij
3915 *
3916 * Radial derivatives. First process both termini of the fragment (i,j)
3917 *
3918           ggg(1)=fac*xj
3919 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3920           ggg(2)=fac*yj
3921 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3922           ggg(3)=fac*zj
3923 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3924 c          do k=1,3
3925 c            ghalf=0.5D0*ggg(k)
3926 c            gelc(k,i)=gelc(k,i)+ghalf
3927 c            gelc(k,j)=gelc(k,j)+ghalf
3928 c          enddo
3929 c 9/28/08 AL Gradient compotents will be summed only at the end
3930           do k=1,3
3931             gelc_long(k,j)=gelc(k,j)+ggg(k)
3932             gelc_long(k,i)=gelc(k,i)-ggg(k)
3933           enddo
3934 *
3935 * Loop over residues i+1 thru j-1.
3936 *
3937 cgrad          do k=i+1,j-1
3938 cgrad            do l=1,3
3939 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3940 cgrad            enddo
3941 cgrad          enddo
3942 c 9/28/08 AL Gradient compotents will be summed only at the end
3943           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3944           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3945           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3946           do k=1,3
3947             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3948             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3949           enddo
3950 #endif
3951 *
3952 * Angular part
3953 *
3954           ecosa=2.0D0*fac3*fac1+fac4
3955           fac4=-3.0D0*fac4
3956           fac3=-6.0D0*fac3
3957           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3958           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3959           do k=1,3
3960             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3961             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3962           enddo
3963 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3964 cd   &          (dcosg(k),k=1,3)
3965           do k=1,3
3966             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3967      &      fac_shield(i)*fac_shield(j)
3968           enddo
3969 c          do k=1,3
3970 c            ghalf=0.5D0*ggg(k)
3971 c            gelc(k,i)=gelc(k,i)+ghalf
3972 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3973 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3974 c            gelc(k,j)=gelc(k,j)+ghalf
3975 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3976 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3977 c          enddo
3978 cgrad          do k=i+1,j-1
3979 cgrad            do l=1,3
3980 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3981 cgrad            enddo
3982 cgrad          enddo
3983 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3984           do k=1,3
3985             gelc(k,i)=gelc(k,i)
3986      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3987      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3988      &           *fac_shield(i)*fac_shield(j)
3989             gelc(k,j)=gelc(k,j)
3990      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3991      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
3992      &           *fac_shield(i)*fac_shield(j)
3993             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3994             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3995           enddo
3996 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
3997
3998 C MARYSIA
3999 c          endif !sscale
4000           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4001      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4002      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4003 C
4004 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4005 C   energy of a peptide unit is assumed in the form of a second-order
4006 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4007 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4008 C   are computed for EVERY pair of non-contiguous peptide groups.
4009 C
4010
4011           if (j.lt.nres-1) then
4012             j1=j+1
4013             j2=j-1
4014           else
4015             j1=j-1
4016             j2=j-2
4017           endif
4018           kkk=0
4019           lll=0
4020           do k=1,2
4021             do l=1,2
4022               kkk=kkk+1
4023               muij(kkk)=mu(k,i)*mu(l,j)
4024 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4025 #ifdef NEWCORR
4026              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4027 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4028              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4029              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4030 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4031              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4032 #endif
4033             enddo
4034           enddo
4035 cd         write (iout,*) 'EELEC: i',i,' j',j
4036 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4037 cd          write(iout,*) 'muij',muij
4038           ury=scalar(uy(1,i),erij)
4039           urz=scalar(uz(1,i),erij)
4040           vry=scalar(uy(1,j),erij)
4041           vrz=scalar(uz(1,j),erij)
4042           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4043           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4044           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4045           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4046           fac=dsqrt(-ael6i)*r3ij
4047           a22=a22*fac
4048           a23=a23*fac
4049           a32=a32*fac
4050           a33=a33*fac
4051 cd          write (iout,'(4i5,4f10.5)')
4052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4055 cd     &      uy(:,j),uz(:,j)
4056 cd          write (iout,'(4f10.5)')
4057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4060 cd           write (iout,'(9f10.5/)')
4061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4062 C Derivatives of the elements of A in virtual-bond vectors
4063           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4064           do k=1,3
4065             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4066             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4067             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4068             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4069             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4070             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4071             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4072             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4073             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4074             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4075             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4076             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4077           enddo
4078 C Compute radial contributions to the gradient
4079           facr=-3.0d0*rrmij
4080           a22der=a22*facr
4081           a23der=a23*facr
4082           a32der=a32*facr
4083           a33der=a33*facr
4084           agg(1,1)=a22der*xj
4085           agg(2,1)=a22der*yj
4086           agg(3,1)=a22der*zj
4087           agg(1,2)=a23der*xj
4088           agg(2,2)=a23der*yj
4089           agg(3,2)=a23der*zj
4090           agg(1,3)=a32der*xj
4091           agg(2,3)=a32der*yj
4092           agg(3,3)=a32der*zj
4093           agg(1,4)=a33der*xj
4094           agg(2,4)=a33der*yj
4095           agg(3,4)=a33der*zj
4096 C Add the contributions coming from er
4097           fac3=-3.0d0*fac
4098           do k=1,3
4099             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4100             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4101             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4102             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4103           enddo
4104           do k=1,3
4105 C Derivatives in DC(i)
4106 cgrad            ghalf1=0.5d0*agg(k,1)
4107 cgrad            ghalf2=0.5d0*agg(k,2)
4108 cgrad            ghalf3=0.5d0*agg(k,3)
4109 cgrad            ghalf4=0.5d0*agg(k,4)
4110             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4111      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4112             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4113      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4114             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4115      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4116             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4117      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4118 C Derivatives in DC(i+1)
4119             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4120      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4121             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4122      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4123             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4124      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4125             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4126      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4127 C Derivatives in DC(j)
4128             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4129      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4130             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4131      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4132             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4133      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4134             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4135      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4136 C Derivatives in DC(j+1) or DC(nres-1)
4137             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4138      &      -3.0d0*vryg(k,3)*ury)
4139             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4140      &      -3.0d0*vrzg(k,3)*ury)
4141             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4142      &      -3.0d0*vryg(k,3)*urz)
4143             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4144      &      -3.0d0*vrzg(k,3)*urz)
4145 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4146 cgrad              do l=1,4
4147 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4148 cgrad              enddo
4149 cgrad            endif
4150           enddo
4151           acipa(1,1)=a22
4152           acipa(1,2)=a23
4153           acipa(2,1)=a32
4154           acipa(2,2)=a33
4155           a22=-a22
4156           a23=-a23
4157           do l=1,2
4158             do k=1,3
4159               agg(k,l)=-agg(k,l)
4160               aggi(k,l)=-aggi(k,l)
4161               aggi1(k,l)=-aggi1(k,l)
4162               aggj(k,l)=-aggj(k,l)
4163               aggj1(k,l)=-aggj1(k,l)
4164             enddo
4165           enddo
4166           if (j.lt.nres-1) then
4167             a22=-a22
4168             a32=-a32
4169             do l=1,3,2
4170               do k=1,3
4171                 agg(k,l)=-agg(k,l)
4172                 aggi(k,l)=-aggi(k,l)
4173                 aggi1(k,l)=-aggi1(k,l)
4174                 aggj(k,l)=-aggj(k,l)
4175                 aggj1(k,l)=-aggj1(k,l)
4176               enddo
4177             enddo
4178           else
4179             a22=-a22
4180             a23=-a23
4181             a32=-a32
4182             a33=-a33
4183             do l=1,4
4184               do k=1,3
4185                 agg(k,l)=-agg(k,l)
4186                 aggi(k,l)=-aggi(k,l)
4187                 aggi1(k,l)=-aggi1(k,l)
4188                 aggj(k,l)=-aggj(k,l)
4189                 aggj1(k,l)=-aggj1(k,l)
4190               enddo
4191             enddo
4192           endif
4193           ENDIF ! WCORR
4194           IF (wel_loc.gt.0.0d0) THEN
4195 C Contribution to the local-electrostatic energy coming from the i-j pair
4196           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4197      &     +a33*muij(4)
4198 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4199 c     &                     ' eel_loc_ij',eel_loc_ij
4200 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4201 C Calculate patrial derivative for theta angle
4202 #ifdef NEWCORR
4203          geel_loc_ij=a22*gmuij1(1)
4204      &     +a23*gmuij1(2)
4205      &     +a32*gmuij1(3)
4206      &     +a33*gmuij1(4)
4207 c         write(iout,*) "derivative over thatai"
4208 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4209 c     &   a33*gmuij1(4)
4210          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4211      &      geel_loc_ij*wel_loc
4212 c         write(iout,*) "derivative over thatai-1"
4213 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4214 c     &   a33*gmuij2(4)
4215          geel_loc_ij=
4216      &     a22*gmuij2(1)
4217      &     +a23*gmuij2(2)
4218      &     +a32*gmuij2(3)
4219      &     +a33*gmuij2(4)
4220          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4221      &      geel_loc_ij*wel_loc
4222 c  Derivative over j residue
4223          geel_loc_ji=a22*gmuji1(1)
4224      &     +a23*gmuji1(2)
4225      &     +a32*gmuji1(3)
4226      &     +a33*gmuji1(4)
4227 c         write(iout,*) "derivative over thataj"
4228 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4229 c     &   a33*gmuji1(4)
4230
4231         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4232      &      geel_loc_ji*wel_loc
4233          geel_loc_ji=
4234      &     +a22*gmuji2(1)
4235      &     +a23*gmuji2(2)
4236      &     +a32*gmuji2(3)
4237      &     +a33*gmuji2(4)
4238 c         write(iout,*) "derivative over thataj-1"
4239 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4240 c     &   a33*gmuji2(4)
4241          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4242      &      geel_loc_ji*wel_loc
4243 #endif
4244 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4245
4246           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4247      &            'eelloc',i,j,eel_loc_ij
4248 c           if (eel_loc_ij.ne.0)
4249 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4250 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4251
4252           eel_loc=eel_loc+eel_loc_ij
4253 C Partial derivatives in virtual-bond dihedral angles gamma
4254           if (i.gt.1)
4255      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4256      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4257      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4258           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4259      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4260      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4261 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4262           do l=1,3
4263             ggg(l)=agg(l,1)*muij(1)+
4264      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4265             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4266             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4267 cgrad            ghalf=0.5d0*ggg(l)
4268 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4269 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4270           enddo
4271 cgrad          do k=i+1,j2
4272 cgrad            do l=1,3
4273 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4274 cgrad            enddo
4275 cgrad          enddo
4276 C Remaining derivatives of eello
4277           do l=1,3
4278             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4279      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4280             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4281      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4282             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4283      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4284             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4285      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4286           enddo
4287           ENDIF
4288 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4289 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4290           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4291      &       .and. num_conti.le.maxconts) then
4292 c            write (iout,*) i,j," entered corr"
4293 C
4294 C Calculate the contact function. The ith column of the array JCONT will
4295 C contain the numbers of atoms that make contacts with the atom I (of numbers
4296 C greater than I). The arrays FACONT and GACONT will contain the values of
4297 C the contact function and its derivative.
4298 c           r0ij=1.02D0*rpp(iteli,itelj)
4299 c           r0ij=1.11D0*rpp(iteli,itelj)
4300             r0ij=2.20D0*rpp(iteli,itelj)
4301 c           r0ij=1.55D0*rpp(iteli,itelj)
4302             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4303             if (fcont.gt.0.0D0) then
4304               num_conti=num_conti+1
4305               if (num_conti.gt.maxconts) then
4306                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4307      &                         ' will skip next contacts for this conf.'
4308               else
4309                 jcont_hb(num_conti,i)=j
4310 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4311 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4312                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4313      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4314 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4315 C  terms.
4316                 d_cont(num_conti,i)=rij
4317 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4318 C     --- Electrostatic-interaction matrix ---
4319                 a_chuj(1,1,num_conti,i)=a22
4320                 a_chuj(1,2,num_conti,i)=a23
4321                 a_chuj(2,1,num_conti,i)=a32
4322                 a_chuj(2,2,num_conti,i)=a33
4323 C     --- Gradient of rij
4324                 do kkk=1,3
4325                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4326                 enddo
4327                 kkll=0
4328                 do k=1,2
4329                   do l=1,2
4330                     kkll=kkll+1
4331                     do m=1,3
4332                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4333                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4334                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4335                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4336                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4337                     enddo
4338                   enddo
4339                 enddo
4340                 ENDIF
4341                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4342 C Calculate contact energies
4343                 cosa4=4.0D0*cosa
4344                 wij=cosa-3.0D0*cosb*cosg
4345                 cosbg1=cosb+cosg
4346                 cosbg2=cosb-cosg
4347 c               fac3=dsqrt(-ael6i)/r0ij**3
4348                 fac3=dsqrt(-ael6i)*r3ij
4349 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4350                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4351                 if (ees0tmp.gt.0) then
4352                   ees0pij=dsqrt(ees0tmp)
4353                 else
4354                   ees0pij=0
4355                 endif
4356 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4357                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4358                 if (ees0tmp.gt.0) then
4359                   ees0mij=dsqrt(ees0tmp)
4360                 else
4361                   ees0mij=0
4362                 endif
4363 c               ees0mij=0.0D0
4364                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4365                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4366 C Diagnostics. Comment out or remove after debugging!
4367 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4368 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4369 c               ees0m(num_conti,i)=0.0D0
4370 C End diagnostics.
4371 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4372 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4373 C Angular derivatives of the contact function
4374                 ees0pij1=fac3/ees0pij
4375                 ees0mij1=fac3/ees0mij
4376                 fac3p=-3.0D0*fac3*rrmij
4377                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4378                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4379 c               ees0mij1=0.0D0
4380                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4381                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4382                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4383                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4384                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4385                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4386                 ecosap=ecosa1+ecosa2
4387                 ecosbp=ecosb1+ecosb2
4388                 ecosgp=ecosg1+ecosg2
4389                 ecosam=ecosa1-ecosa2
4390                 ecosbm=ecosb1-ecosb2
4391                 ecosgm=ecosg1-ecosg2
4392 C Diagnostics
4393 c               ecosap=ecosa1
4394 c               ecosbp=ecosb1
4395 c               ecosgp=ecosg1
4396 c               ecosam=0.0D0
4397 c               ecosbm=0.0D0
4398 c               ecosgm=0.0D0
4399 C End diagnostics
4400                 facont_hb(num_conti,i)=fcont
4401                 fprimcont=fprimcont/rij
4402 cd              facont_hb(num_conti,i)=1.0D0
4403 C Following line is for diagnostics.
4404 cd              fprimcont=0.0D0
4405                 do k=1,3
4406                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4407                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4408                 enddo
4409                 do k=1,3
4410                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4411                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4412                 enddo
4413                 gggp(1)=gggp(1)+ees0pijp*xj
4414                 gggp(2)=gggp(2)+ees0pijp*yj
4415                 gggp(3)=gggp(3)+ees0pijp*zj
4416                 gggm(1)=gggm(1)+ees0mijp*xj
4417                 gggm(2)=gggm(2)+ees0mijp*yj
4418                 gggm(3)=gggm(3)+ees0mijp*zj
4419 C Derivatives due to the contact function
4420                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4421                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4422                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4423                 do k=1,3
4424 c
4425 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4426 c          following the change of gradient-summation algorithm.
4427 c
4428 cgrad                  ghalfp=0.5D0*gggp(k)
4429 cgrad                  ghalfm=0.5D0*gggm(k)
4430                   gacontp_hb1(k,num_conti,i)=!ghalfp
4431      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4432      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4433                   gacontp_hb2(k,num_conti,i)=!ghalfp
4434      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4435      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4436                   gacontp_hb3(k,num_conti,i)=gggp(k)
4437                   gacontm_hb1(k,num_conti,i)=!ghalfm
4438      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4439      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4440                   gacontm_hb2(k,num_conti,i)=!ghalfm
4441      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4442      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4443                   gacontm_hb3(k,num_conti,i)=gggm(k)
4444                 enddo
4445 C Diagnostics. Comment out or remove after debugging!
4446 cdiag           do k=1,3
4447 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4448 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4449 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4450 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4451 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4452 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4453 cdiag           enddo
4454               ENDIF ! wcorr
4455               endif  ! num_conti.le.maxconts
4456             endif  ! fcont.gt.0
4457           endif    ! j.gt.i+1
4458           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4459             do k=1,4
4460               do l=1,3
4461                 ghalf=0.5d0*agg(l,k)
4462                 aggi(l,k)=aggi(l,k)+ghalf
4463                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4464                 aggj(l,k)=aggj(l,k)+ghalf
4465               enddo
4466             enddo
4467             if (j.eq.nres-1 .and. i.lt.j-2) then
4468               do k=1,4
4469                 do l=1,3
4470                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4471                 enddo
4472               enddo
4473             endif
4474           endif
4475 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4476       return
4477       end
4478 C-----------------------------------------------------------------------------
4479       subroutine eturn3(i,eello_turn3)
4480 C Third- and fourth-order contributions from turns
4481       implicit real*8 (a-h,o-z)
4482       include 'DIMENSIONS'
4483       include 'COMMON.IOUNITS'
4484       include 'COMMON.GEO'
4485       include 'COMMON.VAR'
4486       include 'COMMON.LOCAL'
4487       include 'COMMON.CHAIN'
4488       include 'COMMON.DERIV'
4489       include 'COMMON.INTERACT'
4490       include 'COMMON.CONTACTS'
4491       include 'COMMON.TORSION'
4492       include 'COMMON.VECTORS'
4493       include 'COMMON.FFIELD'
4494       include 'COMMON.CONTROL'
4495       dimension ggg(3)
4496       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4497      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4498      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4499      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4500      &  auxgmat2(2,2),auxgmatt2(2,2)
4501       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4502      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4503       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4504      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4505      &    num_conti,j1,j2
4506       j=i+2
4507 c      write (iout,*) "eturn3",i,j,j1,j2
4508       a_temp(1,1)=a22
4509       a_temp(1,2)=a23
4510       a_temp(2,1)=a32
4511       a_temp(2,2)=a33
4512 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4513 C
4514 C               Third-order contributions
4515 C
4516 C                 (i+2)o----(i+3)
4517 C                      | |
4518 C                      | |
4519 C                 (i+1)o----i
4520 C
4521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4522 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4523         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4524 c auxalary matices for theta gradient
4525 c auxalary matrix for i+1 and constant i+2
4526         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4527 c auxalary matrix for i+2 and constant i+1
4528         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4529         call transpose2(auxmat(1,1),auxmat1(1,1))
4530         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4531         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4532         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4533         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4534         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4535         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4536 C Derivatives in theta
4537         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4538      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4539         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4540      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4541
4542         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4543      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4544 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4545 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4546 cd     &    ' eello_turn3_num',4*eello_turn3_num
4547 C Derivatives in gamma(i)
4548         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4549         call transpose2(auxmat2(1,1),auxmat3(1,1))
4550         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4551         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4552 C Derivatives in gamma(i+1)
4553         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4554         call transpose2(auxmat2(1,1),auxmat3(1,1))
4555         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4556         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4557      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4558 C Cartesian derivatives
4559         do l=1,3
4560 c            ghalf1=0.5d0*agg(l,1)
4561 c            ghalf2=0.5d0*agg(l,2)
4562 c            ghalf3=0.5d0*agg(l,3)
4563 c            ghalf4=0.5d0*agg(l,4)
4564           a_temp(1,1)=aggi(l,1)!+ghalf1
4565           a_temp(1,2)=aggi(l,2)!+ghalf2
4566           a_temp(2,1)=aggi(l,3)!+ghalf3
4567           a_temp(2,2)=aggi(l,4)!+ghalf4
4568           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4569           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4570      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4571           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4572           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4573           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4574           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4575           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4576           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4577      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4578           a_temp(1,1)=aggj(l,1)!+ghalf1
4579           a_temp(1,2)=aggj(l,2)!+ghalf2
4580           a_temp(2,1)=aggj(l,3)!+ghalf3
4581           a_temp(2,2)=aggj(l,4)!+ghalf4
4582           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4583           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4584      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4585           a_temp(1,1)=aggj1(l,1)
4586           a_temp(1,2)=aggj1(l,2)
4587           a_temp(2,1)=aggj1(l,3)
4588           a_temp(2,2)=aggj1(l,4)
4589           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4590           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4591      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4592         enddo
4593       return
4594       end
4595 C-------------------------------------------------------------------------------
4596       subroutine eturn4(i,eello_turn4)
4597 C Third- and fourth-order contributions from turns
4598       implicit real*8 (a-h,o-z)
4599       include 'DIMENSIONS'
4600       include 'COMMON.IOUNITS'
4601       include 'COMMON.GEO'
4602       include 'COMMON.VAR'
4603       include 'COMMON.LOCAL'
4604       include 'COMMON.CHAIN'
4605       include 'COMMON.DERIV'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.CONTACTS'
4608       include 'COMMON.TORSION'
4609       include 'COMMON.VECTORS'
4610       include 'COMMON.FFIELD'
4611       include 'COMMON.CONTROL'
4612       dimension ggg(3)
4613       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4614      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4615      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4616      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4617      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4618      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4619      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4620       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4621      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4622       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4623      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4624      &    num_conti,j1,j2
4625       j=i+3
4626 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4627 C
4628 C               Fourth-order contributions
4629 C
4630 C                 (i+3)o----(i+4)
4631 C                     /  |
4632 C               (i+2)o   |
4633 C                     \  |
4634 C                 (i+1)o----i
4635 C
4636 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4637 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4638 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4639 c        write(iout,*)"WCHODZE W PROGRAM"
4640         a_temp(1,1)=a22
4641         a_temp(1,2)=a23
4642         a_temp(2,1)=a32
4643         a_temp(2,2)=a33
4644         iti1=itortyp(itype(i+1))
4645         iti2=itortyp(itype(i+2))
4646         iti3=itortyp(itype(i+3))
4647 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4648         call transpose2(EUg(1,1,i+1),e1t(1,1))
4649         call transpose2(Eug(1,1,i+2),e2t(1,1))
4650         call transpose2(Eug(1,1,i+3),e3t(1,1))
4651 C Ematrix derivative in theta
4652         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4653         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4654         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4655         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4656 c       eta1 in derivative theta
4657         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4658         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4659 c       auxgvec is derivative of Ub2 so i+3 theta
4660         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4661 c       auxalary matrix of E i+1
4662         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4663 c        s1=0.0
4664 c        gs1=0.0
4665         s1=scalar2(b1(1,i+2),auxvec(1))
4666 c derivative of theta i+2 with constant i+3
4667         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4668 c derivative of theta i+2 with constant i+2
4669         gs32=scalar2(b1(1,i+2),auxgvec(1))
4670 c derivative of E matix in theta of i+1
4671         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4672
4673         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4674 c       ea31 in derivative theta
4675         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4677 c auxilary matrix auxgvec of Ub2 with constant E matirx
4678         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4679 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4680         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4681
4682 c        s2=0.0
4683 c        gs2=0.0
4684         s2=scalar2(b1(1,i+1),auxvec(1))
4685 c derivative of theta i+1 with constant i+3
4686         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4687 c derivative of theta i+2 with constant i+1
4688         gs21=scalar2(b1(1,i+1),auxgvec(1))
4689 c derivative of theta i+3 with constant i+1
4690         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4691 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4692 c     &  gtb1(1,i+1)
4693         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4694 c two derivatives over diffetent matrices
4695 c gtae3e2 is derivative over i+3
4696         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4697 c ae3gte2 is derivative over i+2
4698         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4699         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4700 c three possible derivative over theta E matices
4701 c i+1
4702         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4703 c i+2
4704         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4705 c i+3
4706         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4707         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4708
4709         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4710         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4711         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4712
4713         eello_turn4=eello_turn4-(s1+s2+s3)
4714 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4715         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4716      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4717 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4718 cd     &    ' eello_turn4_num',8*eello_turn4_num
4719 #ifdef NEWCORR
4720         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4721      &                  -(gs13+gsE13+gsEE1)*wturn4
4722         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4723      &                    -(gs23+gs21+gsEE2)*wturn4
4724         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4725      &                    -(gs32+gsE31+gsEE3)*wturn4
4726 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4727 c     &   gs2
4728 #endif
4729         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4730      &      'eturn4',i,j,-(s1+s2+s3)
4731 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4732 c     &    ' eello_turn4_num',8*eello_turn4_num
4733 C Derivatives in gamma(i)
4734         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4735         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4736         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4737         s1=scalar2(b1(1,i+2),auxvec(1))
4738         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4739         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4740         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4741 C Derivatives in gamma(i+1)
4742         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4743         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4744         s2=scalar2(b1(1,i+1),auxvec(1))
4745         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4746         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4747         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4748         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4749 C Derivatives in gamma(i+2)
4750         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4751         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4752         s1=scalar2(b1(1,i+2),auxvec(1))
4753         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4754         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4755         s2=scalar2(b1(1,i+1),auxvec(1))
4756         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4757         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4758         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4759         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4760 C Cartesian derivatives
4761 C Derivatives of this turn contributions in DC(i+2)
4762         if (j.lt.nres-1) then
4763           do l=1,3
4764             a_temp(1,1)=agg(l,1)
4765             a_temp(1,2)=agg(l,2)
4766             a_temp(2,1)=agg(l,3)
4767             a_temp(2,2)=agg(l,4)
4768             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4769             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4770             s1=scalar2(b1(1,i+2),auxvec(1))
4771             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4772             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4773             s2=scalar2(b1(1,i+1),auxvec(1))
4774             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4775             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4776             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4777             ggg(l)=-(s1+s2+s3)
4778             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4779           enddo
4780         endif
4781 C Remaining derivatives of this turn contribution
4782         do l=1,3
4783           a_temp(1,1)=aggi(l,1)
4784           a_temp(1,2)=aggi(l,2)
4785           a_temp(2,1)=aggi(l,3)
4786           a_temp(2,2)=aggi(l,4)
4787           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4788           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4789           s1=scalar2(b1(1,i+2),auxvec(1))
4790           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4791           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4792           s2=scalar2(b1(1,i+1),auxvec(1))
4793           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4794           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4795           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4796           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4797           a_temp(1,1)=aggi1(l,1)
4798           a_temp(1,2)=aggi1(l,2)
4799           a_temp(2,1)=aggi1(l,3)
4800           a_temp(2,2)=aggi1(l,4)
4801           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4802           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4803           s1=scalar2(b1(1,i+2),auxvec(1))
4804           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4805           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4806           s2=scalar2(b1(1,i+1),auxvec(1))
4807           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4808           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4809           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4810           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4811           a_temp(1,1)=aggj(l,1)
4812           a_temp(1,2)=aggj(l,2)
4813           a_temp(2,1)=aggj(l,3)
4814           a_temp(2,2)=aggj(l,4)
4815           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4816           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4817           s1=scalar2(b1(1,i+2),auxvec(1))
4818           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4819           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4820           s2=scalar2(b1(1,i+1),auxvec(1))
4821           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4822           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4823           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4824           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4825           a_temp(1,1)=aggj1(l,1)
4826           a_temp(1,2)=aggj1(l,2)
4827           a_temp(2,1)=aggj1(l,3)
4828           a_temp(2,2)=aggj1(l,4)
4829           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4830           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4831           s1=scalar2(b1(1,i+2),auxvec(1))
4832           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4833           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4834           s2=scalar2(b1(1,i+1),auxvec(1))
4835           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4836           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4837           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4838 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4839           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4840         enddo
4841       return
4842       end
4843 C-----------------------------------------------------------------------------
4844       subroutine vecpr(u,v,w)
4845       implicit real*8(a-h,o-z)
4846       dimension u(3),v(3),w(3)
4847       w(1)=u(2)*v(3)-u(3)*v(2)
4848       w(2)=-u(1)*v(3)+u(3)*v(1)
4849       w(3)=u(1)*v(2)-u(2)*v(1)
4850       return
4851       end
4852 C-----------------------------------------------------------------------------
4853       subroutine unormderiv(u,ugrad,unorm,ungrad)
4854 C This subroutine computes the derivatives of a normalized vector u, given
4855 C the derivatives computed without normalization conditions, ugrad. Returns
4856 C ungrad.
4857       implicit none
4858       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4859       double precision vec(3)
4860       double precision scalar
4861       integer i,j
4862 c      write (2,*) 'ugrad',ugrad
4863 c      write (2,*) 'u',u
4864       do i=1,3
4865         vec(i)=scalar(ugrad(1,i),u(1))
4866       enddo
4867 c      write (2,*) 'vec',vec
4868       do i=1,3
4869         do j=1,3
4870           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4871         enddo
4872       enddo
4873 c      write (2,*) 'ungrad',ungrad
4874       return
4875       end
4876 C-----------------------------------------------------------------------------
4877       subroutine escp_soft_sphere(evdw2,evdw2_14)
4878 C
4879 C This subroutine calculates the excluded-volume interaction energy between
4880 C peptide-group centers and side chains and its gradient in virtual-bond and
4881 C side-chain vectors.
4882 C
4883       implicit real*8 (a-h,o-z)
4884       include 'DIMENSIONS'
4885       include 'COMMON.GEO'
4886       include 'COMMON.VAR'
4887       include 'COMMON.LOCAL'
4888       include 'COMMON.CHAIN'
4889       include 'COMMON.DERIV'
4890       include 'COMMON.INTERACT'
4891       include 'COMMON.FFIELD'
4892       include 'COMMON.IOUNITS'
4893       include 'COMMON.CONTROL'
4894       dimension ggg(3)
4895       evdw2=0.0D0
4896       evdw2_14=0.0d0
4897       r0_scp=4.5d0
4898 cd    print '(a)','Enter ESCP'
4899 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4900 C      do xshift=-1,1
4901 C      do yshift=-1,1
4902 C      do zshift=-1,1
4903       do i=iatscp_s,iatscp_e
4904         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4905         iteli=itel(i)
4906         xi=0.5D0*(c(1,i)+c(1,i+1))
4907         yi=0.5D0*(c(2,i)+c(2,i+1))
4908         zi=0.5D0*(c(3,i)+c(3,i+1))
4909 C Return atom into box, boxxsize is size of box in x dimension
4910 c  134   continue
4911 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4912 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4913 C Condition for being inside the proper box
4914 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4915 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4916 c        go to 134
4917 c        endif
4918 c  135   continue
4919 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4920 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4921 C Condition for being inside the proper box
4922 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4923 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4924 c        go to 135
4925 c c       endif
4926 c  136   continue
4927 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4928 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4929 cC Condition for being inside the proper box
4930 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4931 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4932 c        go to 136
4933 c        endif
4934           xi=mod(xi,boxxsize)
4935           if (xi.lt.0) xi=xi+boxxsize
4936           yi=mod(yi,boxysize)
4937           if (yi.lt.0) yi=yi+boxysize
4938           zi=mod(zi,boxzsize)
4939           if (zi.lt.0) zi=zi+boxzsize
4940 C          xi=xi+xshift*boxxsize
4941 C          yi=yi+yshift*boxysize
4942 C          zi=zi+zshift*boxzsize
4943         do iint=1,nscp_gr(i)
4944
4945         do j=iscpstart(i,iint),iscpend(i,iint)
4946           if (itype(j).eq.ntyp1) cycle
4947           itypj=iabs(itype(j))
4948 C Uncomment following three lines for SC-p interactions
4949 c         xj=c(1,nres+j)-xi
4950 c         yj=c(2,nres+j)-yi
4951 c         zj=c(3,nres+j)-zi
4952 C Uncomment following three lines for Ca-p interactions
4953           xj=c(1,j)
4954           yj=c(2,j)
4955           zj=c(3,j)
4956 c  174   continue
4957 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4958 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4959 C Condition for being inside the proper box
4960 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4961 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4962 c        go to 174
4963 c        endif
4964 c  175   continue
4965 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4966 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4967 cC Condition for being inside the proper box
4968 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4969 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4970 c        go to 175
4971 c        endif
4972 c  176   continue
4973 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4974 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4975 C Condition for being inside the proper box
4976 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4977 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4978 c        go to 176
4979           xj=mod(xj,boxxsize)
4980           if (xj.lt.0) xj=xj+boxxsize
4981           yj=mod(yj,boxysize)
4982           if (yj.lt.0) yj=yj+boxysize
4983           zj=mod(zj,boxzsize)
4984           if (zj.lt.0) zj=zj+boxzsize
4985       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4986       xj_safe=xj
4987       yj_safe=yj
4988       zj_safe=zj
4989       subchap=0
4990       do xshift=-1,1
4991       do yshift=-1,1
4992       do zshift=-1,1
4993           xj=xj_safe+xshift*boxxsize
4994           yj=yj_safe+yshift*boxysize
4995           zj=zj_safe+zshift*boxzsize
4996           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4997           if(dist_temp.lt.dist_init) then
4998             dist_init=dist_temp
4999             xj_temp=xj
5000             yj_temp=yj
5001             zj_temp=zj
5002             subchap=1
5003           endif
5004        enddo
5005        enddo
5006        enddo
5007        if (subchap.eq.1) then
5008           xj=xj_temp-xi
5009           yj=yj_temp-yi
5010           zj=zj_temp-zi
5011        else
5012           xj=xj_safe-xi
5013           yj=yj_safe-yi
5014           zj=zj_safe-zi
5015        endif
5016 c c       endif
5017 C          xj=xj-xi
5018 C          yj=yj-yi
5019 C          zj=zj-zi
5020           rij=xj*xj+yj*yj+zj*zj
5021
5022           r0ij=r0_scp
5023           r0ijsq=r0ij*r0ij
5024           if (rij.lt.r0ijsq) then
5025             evdwij=0.25d0*(rij-r0ijsq)**2
5026             fac=rij-r0ijsq
5027           else
5028             evdwij=0.0d0
5029             fac=0.0d0
5030           endif
5031           evdw2=evdw2+evdwij
5032 C
5033 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5034 C
5035           ggg(1)=xj*fac
5036           ggg(2)=yj*fac
5037           ggg(3)=zj*fac
5038 cgrad          if (j.lt.i) then
5039 cd          write (iout,*) 'j<i'
5040 C Uncomment following three lines for SC-p interactions
5041 c           do k=1,3
5042 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5043 c           enddo
5044 cgrad          else
5045 cd          write (iout,*) 'j>i'
5046 cgrad            do k=1,3
5047 cgrad              ggg(k)=-ggg(k)
5048 C Uncomment following line for SC-p interactions
5049 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5050 cgrad            enddo
5051 cgrad          endif
5052 cgrad          do k=1,3
5053 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5054 cgrad          enddo
5055 cgrad          kstart=min0(i+1,j)
5056 cgrad          kend=max0(i-1,j-1)
5057 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5058 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5059 cgrad          do k=kstart,kend
5060 cgrad            do l=1,3
5061 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5062 cgrad            enddo
5063 cgrad          enddo
5064           do k=1,3
5065             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5066             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5067           enddo
5068         enddo
5069
5070         enddo ! iint
5071       enddo ! i
5072 C      enddo !zshift
5073 C      enddo !yshift
5074 C      enddo !xshift
5075       return
5076       end
5077 C-----------------------------------------------------------------------------
5078       subroutine escp(evdw2,evdw2_14)
5079 C
5080 C This subroutine calculates the excluded-volume interaction energy between
5081 C peptide-group centers and side chains and its gradient in virtual-bond and
5082 C side-chain vectors.
5083 C
5084       implicit real*8 (a-h,o-z)
5085       include 'DIMENSIONS'
5086       include 'COMMON.GEO'
5087       include 'COMMON.VAR'
5088       include 'COMMON.LOCAL'
5089       include 'COMMON.CHAIN'
5090       include 'COMMON.DERIV'
5091       include 'COMMON.INTERACT'
5092       include 'COMMON.FFIELD'
5093       include 'COMMON.IOUNITS'
5094       include 'COMMON.CONTROL'
5095       include 'COMMON.SPLITELE'
5096       dimension ggg(3)
5097       evdw2=0.0D0
5098       evdw2_14=0.0d0
5099 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5100 cd    print '(a)','Enter ESCP'
5101 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5102 C      do xshift=-1,1
5103 C      do yshift=-1,1
5104 C      do zshift=-1,1
5105       do i=iatscp_s,iatscp_e
5106         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5107         iteli=itel(i)
5108         xi=0.5D0*(c(1,i)+c(1,i+1))
5109         yi=0.5D0*(c(2,i)+c(2,i+1))
5110         zi=0.5D0*(c(3,i)+c(3,i+1))
5111           xi=mod(xi,boxxsize)
5112           if (xi.lt.0) xi=xi+boxxsize
5113           yi=mod(yi,boxysize)
5114           if (yi.lt.0) yi=yi+boxysize
5115           zi=mod(zi,boxzsize)
5116           if (zi.lt.0) zi=zi+boxzsize
5117 c          xi=xi+xshift*boxxsize
5118 c          yi=yi+yshift*boxysize
5119 c          zi=zi+zshift*boxzsize
5120 c        print *,xi,yi,zi,'polozenie i'
5121 C Return atom into box, boxxsize is size of box in x dimension
5122 c  134   continue
5123 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5124 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5125 C Condition for being inside the proper box
5126 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5127 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5128 c        go to 134
5129 c        endif
5130 c  135   continue
5131 c          print *,xi,boxxsize,"pierwszy"
5132
5133 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5134 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5135 C Condition for being inside the proper box
5136 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5137 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5138 c        go to 135
5139 c        endif
5140 c  136   continue
5141 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5142 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5143 C Condition for being inside the proper box
5144 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5145 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5146 c        go to 136
5147 c        endif
5148         do iint=1,nscp_gr(i)
5149
5150         do j=iscpstart(i,iint),iscpend(i,iint)
5151           itypj=iabs(itype(j))
5152           if (itypj.eq.ntyp1) cycle
5153 C Uncomment following three lines for SC-p interactions
5154 c         xj=c(1,nres+j)-xi
5155 c         yj=c(2,nres+j)-yi
5156 c         zj=c(3,nres+j)-zi
5157 C Uncomment following three lines for Ca-p interactions
5158           xj=c(1,j)
5159           yj=c(2,j)
5160           zj=c(3,j)
5161           xj=mod(xj,boxxsize)
5162           if (xj.lt.0) xj=xj+boxxsize
5163           yj=mod(yj,boxysize)
5164           if (yj.lt.0) yj=yj+boxysize
5165           zj=mod(zj,boxzsize)
5166           if (zj.lt.0) zj=zj+boxzsize
5167 c  174   continue
5168 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5169 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5170 C Condition for being inside the proper box
5171 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5172 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5173 c        go to 174
5174 c        endif
5175 c  175   continue
5176 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5177 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5178 cC Condition for being inside the proper box
5179 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5180 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5181 c        go to 175
5182 c        endif
5183 c  176   continue
5184 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5185 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5186 C Condition for being inside the proper box
5187 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5188 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5189 c        go to 176
5190 c        endif
5191 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5192       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5193       xj_safe=xj
5194       yj_safe=yj
5195       zj_safe=zj
5196       subchap=0
5197       do xshift=-1,1
5198       do yshift=-1,1
5199       do zshift=-1,1
5200           xj=xj_safe+xshift*boxxsize
5201           yj=yj_safe+yshift*boxysize
5202           zj=zj_safe+zshift*boxzsize
5203           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5204           if(dist_temp.lt.dist_init) then
5205             dist_init=dist_temp
5206             xj_temp=xj
5207             yj_temp=yj
5208             zj_temp=zj
5209             subchap=1
5210           endif
5211        enddo
5212        enddo
5213        enddo
5214        if (subchap.eq.1) then
5215           xj=xj_temp-xi
5216           yj=yj_temp-yi
5217           zj=zj_temp-zi
5218        else
5219           xj=xj_safe-xi
5220           yj=yj_safe-yi
5221           zj=zj_safe-zi
5222        endif
5223 c          print *,xj,yj,zj,'polozenie j'
5224           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5225 c          print *,rrij
5226           sss=sscale(1.0d0/(dsqrt(rrij)))
5227 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5228 c          if (sss.eq.0) print *,'czasem jest OK'
5229           if (sss.le.0.0d0) cycle
5230           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5231           fac=rrij**expon2
5232           e1=fac*fac*aad(itypj,iteli)
5233           e2=fac*bad(itypj,iteli)
5234           if (iabs(j-i) .le. 2) then
5235             e1=scal14*e1
5236             e2=scal14*e2
5237             evdw2_14=evdw2_14+(e1+e2)*sss
5238           endif
5239           evdwij=e1+e2
5240           evdw2=evdw2+evdwij*sss
5241           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5242      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5243      &       bad(itypj,iteli)
5244 C
5245 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5246 C
5247           fac=-(evdwij+e1)*rrij*sss
5248           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5249           ggg(1)=xj*fac
5250           ggg(2)=yj*fac
5251           ggg(3)=zj*fac
5252 cgrad          if (j.lt.i) then
5253 cd          write (iout,*) 'j<i'
5254 C Uncomment following three lines for SC-p interactions
5255 c           do k=1,3
5256 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5257 c           enddo
5258 cgrad          else
5259 cd          write (iout,*) 'j>i'
5260 cgrad            do k=1,3
5261 cgrad              ggg(k)=-ggg(k)
5262 C Uncomment following line for SC-p interactions
5263 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5264 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5265 cgrad            enddo
5266 cgrad          endif
5267 cgrad          do k=1,3
5268 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5269 cgrad          enddo
5270 cgrad          kstart=min0(i+1,j)
5271 cgrad          kend=max0(i-1,j-1)
5272 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5273 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5274 cgrad          do k=kstart,kend
5275 cgrad            do l=1,3
5276 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5277 cgrad            enddo
5278 cgrad          enddo
5279           do k=1,3
5280             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5281             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5282           enddo
5283 c        endif !endif for sscale cutoff
5284         enddo ! j
5285
5286         enddo ! iint
5287       enddo ! i
5288 c      enddo !zshift
5289 c      enddo !yshift
5290 c      enddo !xshift
5291       do i=1,nct
5292         do j=1,3
5293           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5294           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5295           gradx_scp(j,i)=expon*gradx_scp(j,i)
5296         enddo
5297       enddo
5298 C******************************************************************************
5299 C
5300 C                              N O T E !!!
5301 C
5302 C To save time the factor EXPON has been extracted from ALL components
5303 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5304 C use!
5305 C
5306 C******************************************************************************
5307       return
5308       end
5309 C--------------------------------------------------------------------------
5310       subroutine edis(ehpb)
5311 C
5312 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5313 C
5314       implicit real*8 (a-h,o-z)
5315       include 'DIMENSIONS'
5316       include 'COMMON.SBRIDGE'
5317       include 'COMMON.CHAIN'
5318       include 'COMMON.DERIV'
5319       include 'COMMON.VAR'
5320       include 'COMMON.INTERACT'
5321       include 'COMMON.IOUNITS'
5322       include 'COMMON.CONTROL'
5323       dimension ggg(3)
5324       ehpb=0.0D0
5325       do i=1,3
5326        ggg(i)=0.0d0
5327       enddo
5328 C      write (iout,*) ,"link_end",link_end,constr_dist
5329 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5330 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5331       if (link_end.eq.0) return
5332       do i=link_start,link_end
5333 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5334 C CA-CA distance used in regularization of structure.
5335         ii=ihpb(i)
5336         jj=jhpb(i)
5337 C iii and jjj point to the residues for which the distance is assigned.
5338         if (ii.gt.nres) then
5339           iii=ii-nres
5340           jjj=jj-nres
5341         else
5342           iii=ii
5343           jjj=jj
5344         endif
5345 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5346 c     &    dhpb(i),dhpb1(i),forcon(i)
5347 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5348 C    distance and angle dependent SS bond potential.
5349 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5350 C     & iabs(itype(jjj)).eq.1) then
5351 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5352 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5353         if (.not.dyn_ss .and. i.le.nss) then
5354 C 15/02/13 CC dynamic SSbond - additional check
5355          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5356      & iabs(itype(jjj)).eq.1) then
5357           call ssbond_ene(iii,jjj,eij)
5358           ehpb=ehpb+2*eij
5359          endif
5360 cd          write (iout,*) "eij",eij
5361 cd   &   ' waga=',waga,' fac=',fac
5362         else if (ii.gt.nres .and. jj.gt.nres) then
5363 c Restraints from contact prediction
5364           dd=dist(ii,jj)
5365           if (constr_dist.eq.11) then
5366             ehpb=ehpb+fordepth(i)**4.0d0
5367      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5368             fac=fordepth(i)**4.0d0
5369      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5370           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5371      &    ehpb,fordepth(i),dd
5372            else
5373           if (dhpb1(i).gt.0.0d0) then
5374             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5375             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5376 c            write (iout,*) "beta nmr",
5377 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5378           else
5379             dd=dist(ii,jj)
5380             rdis=dd-dhpb(i)
5381 C Get the force constant corresponding to this distance.
5382             waga=forcon(i)
5383 C Calculate the contribution to energy.
5384             ehpb=ehpb+waga*rdis*rdis
5385 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5386 C
5387 C Evaluate gradient.
5388 C
5389             fac=waga*rdis/dd
5390           endif
5391           endif
5392           do j=1,3
5393             ggg(j)=fac*(c(j,jj)-c(j,ii))
5394           enddo
5395           do j=1,3
5396             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5397             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5398           enddo
5399           do k=1,3
5400             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5401             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5402           enddo
5403         else
5404 C Calculate the distance between the two points and its difference from the
5405 C target distance.
5406           dd=dist(ii,jj)
5407           if (constr_dist.eq.11) then
5408             ehpb=ehpb+fordepth(i)**4.0d0
5409      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5410             fac=fordepth(i)**4.0d0
5411      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5412           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5413      &    ehpb,fordepth(i),dd
5414            else
5415           if (dhpb1(i).gt.0.0d0) then
5416             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5417             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5418 c            write (iout,*) "alph nmr",
5419 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5420           else
5421             rdis=dd-dhpb(i)
5422 C Get the force constant corresponding to this distance.
5423             waga=forcon(i)
5424 C Calculate the contribution to energy.
5425             ehpb=ehpb+waga*rdis*rdis
5426 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5427 C
5428 C Evaluate gradient.
5429 C
5430             fac=waga*rdis/dd
5431           endif
5432           endif
5433             do j=1,3
5434               ggg(j)=fac*(c(j,jj)-c(j,ii))
5435             enddo
5436 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5437 C If this is a SC-SC distance, we need to calculate the contributions to the
5438 C Cartesian gradient in the SC vectors (ghpbx).
5439           if (iii.lt.ii) then
5440           do j=1,3
5441             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5442             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5443           enddo
5444           endif
5445 cgrad        do j=iii,jjj-1
5446 cgrad          do k=1,3
5447 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5448 cgrad          enddo
5449 cgrad        enddo
5450           do k=1,3
5451             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5452             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5453           enddo
5454         endif
5455       enddo
5456       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5457       return
5458       end
5459 C--------------------------------------------------------------------------
5460       subroutine ssbond_ene(i,j,eij)
5461 C
5462 C Calculate the distance and angle dependent SS-bond potential energy
5463 C using a free-energy function derived based on RHF/6-31G** ab initio
5464 C calculations of diethyl disulfide.
5465 C
5466 C A. Liwo and U. Kozlowska, 11/24/03
5467 C
5468       implicit real*8 (a-h,o-z)
5469       include 'DIMENSIONS'
5470       include 'COMMON.SBRIDGE'
5471       include 'COMMON.CHAIN'
5472       include 'COMMON.DERIV'
5473       include 'COMMON.LOCAL'
5474       include 'COMMON.INTERACT'
5475       include 'COMMON.VAR'
5476       include 'COMMON.IOUNITS'
5477       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5478       itypi=iabs(itype(i))
5479       xi=c(1,nres+i)
5480       yi=c(2,nres+i)
5481       zi=c(3,nres+i)
5482       dxi=dc_norm(1,nres+i)
5483       dyi=dc_norm(2,nres+i)
5484       dzi=dc_norm(3,nres+i)
5485 c      dsci_inv=dsc_inv(itypi)
5486       dsci_inv=vbld_inv(nres+i)
5487       itypj=iabs(itype(j))
5488 c      dscj_inv=dsc_inv(itypj)
5489       dscj_inv=vbld_inv(nres+j)
5490       xj=c(1,nres+j)-xi
5491       yj=c(2,nres+j)-yi
5492       zj=c(3,nres+j)-zi
5493       dxj=dc_norm(1,nres+j)
5494       dyj=dc_norm(2,nres+j)
5495       dzj=dc_norm(3,nres+j)
5496       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5497       rij=dsqrt(rrij)
5498       erij(1)=xj*rij
5499       erij(2)=yj*rij
5500       erij(3)=zj*rij
5501       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5502       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5503       om12=dxi*dxj+dyi*dyj+dzi*dzj
5504       do k=1,3
5505         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5506         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5507       enddo
5508       rij=1.0d0/rij
5509       deltad=rij-d0cm
5510       deltat1=1.0d0-om1
5511       deltat2=1.0d0+om2
5512       deltat12=om2-om1+2.0d0
5513       cosphi=om12-om1*om2
5514       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5515      &  +akct*deltad*deltat12
5516      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5517 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5518 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5519 c     &  " deltat12",deltat12," eij",eij
5520       ed=2*akcm*deltad+akct*deltat12
5521       pom1=akct*deltad
5522       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5523       eom1=-2*akth*deltat1-pom1-om2*pom2
5524       eom2= 2*akth*deltat2+pom1-om1*pom2
5525       eom12=pom2
5526       do k=1,3
5527         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5528         ghpbx(k,i)=ghpbx(k,i)-ggk
5529      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5530      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5531         ghpbx(k,j)=ghpbx(k,j)+ggk
5532      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5533      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5534         ghpbc(k,i)=ghpbc(k,i)-ggk
5535         ghpbc(k,j)=ghpbc(k,j)+ggk
5536       enddo
5537 C
5538 C Calculate the components of the gradient in DC and X
5539 C
5540 cgrad      do k=i,j-1
5541 cgrad        do l=1,3
5542 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5543 cgrad        enddo
5544 cgrad      enddo
5545       return
5546       end
5547 C--------------------------------------------------------------------------
5548       subroutine ebond(estr)
5549 c
5550 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5551 c
5552       implicit real*8 (a-h,o-z)
5553       include 'DIMENSIONS'
5554       include 'COMMON.LOCAL'
5555       include 'COMMON.GEO'
5556       include 'COMMON.INTERACT'
5557       include 'COMMON.DERIV'
5558       include 'COMMON.VAR'
5559       include 'COMMON.CHAIN'
5560       include 'COMMON.IOUNITS'
5561       include 'COMMON.NAMES'
5562       include 'COMMON.FFIELD'
5563       include 'COMMON.CONTROL'
5564       include 'COMMON.SETUP'
5565       double precision u(3),ud(3)
5566       estr=0.0d0
5567       estr1=0.0d0
5568       do i=ibondp_start,ibondp_end
5569         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5570 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5571 c          do j=1,3
5572 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5573 c     &      *dc(j,i-1)/vbld(i)
5574 c          enddo
5575 c          if (energy_dec) write(iout,*)
5576 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5577 c        else
5578 C       Checking if it involves dummy (NH3+ or COO-) group
5579          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5580 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5581         diff = vbld(i)-vbldpDUM
5582          else
5583 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5584         diff = vbld(i)-vbldp0
5585          endif
5586         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5587      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5588         estr=estr+diff*diff
5589         do j=1,3
5590           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5591         enddo
5592 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5593 c        endif
5594       enddo
5595       estr=0.5d0*AKP*estr+estr1
5596 c
5597 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5598 c
5599       do i=ibond_start,ibond_end
5600         iti=iabs(itype(i))
5601         if (iti.ne.10 .and. iti.ne.ntyp1) then
5602           nbi=nbondterm(iti)
5603           if (nbi.eq.1) then
5604             diff=vbld(i+nres)-vbldsc0(1,iti)
5605             if (energy_dec)  write (iout,*)
5606      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5607      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5608             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5609             do j=1,3
5610               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5611             enddo
5612           else
5613             do j=1,nbi
5614               diff=vbld(i+nres)-vbldsc0(j,iti)
5615               ud(j)=aksc(j,iti)*diff
5616               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5617             enddo
5618             uprod=u(1)
5619             do j=2,nbi
5620               uprod=uprod*u(j)
5621             enddo
5622             usum=0.0d0
5623             usumsqder=0.0d0
5624             do j=1,nbi
5625               uprod1=1.0d0
5626               uprod2=1.0d0
5627               do k=1,nbi
5628                 if (k.ne.j) then
5629                   uprod1=uprod1*u(k)
5630                   uprod2=uprod2*u(k)*u(k)
5631                 endif
5632               enddo
5633               usum=usum+uprod1
5634               usumsqder=usumsqder+ud(j)*uprod2
5635             enddo
5636             estr=estr+uprod/usum
5637             do j=1,3
5638              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5639             enddo
5640           endif
5641         endif
5642       enddo
5643       return
5644       end
5645 #ifdef CRYST_THETA
5646 C--------------------------------------------------------------------------
5647       subroutine ebend(etheta,ethetacnstr)
5648 C
5649 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5650 C angles gamma and its derivatives in consecutive thetas and gammas.
5651 C
5652       implicit real*8 (a-h,o-z)
5653       include 'DIMENSIONS'
5654       include 'COMMON.LOCAL'
5655       include 'COMMON.GEO'
5656       include 'COMMON.INTERACT'
5657       include 'COMMON.DERIV'
5658       include 'COMMON.VAR'
5659       include 'COMMON.CHAIN'
5660       include 'COMMON.IOUNITS'
5661       include 'COMMON.NAMES'
5662       include 'COMMON.FFIELD'
5663       include 'COMMON.CONTROL'
5664       include 'COMMON.TORCNSTR'
5665       common /calcthet/ term1,term2,termm,diffak,ratak,
5666      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5667      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5668       double precision y(2),z(2)
5669       delta=0.02d0*pi
5670 c      time11=dexp(-2*time)
5671 c      time12=1.0d0
5672       etheta=0.0D0
5673 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5674       do i=ithet_start,ithet_end
5675 c        write (iout,*) "ebend: i=",i
5676 c        call flush_(iout)
5677         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5678      &  .or.itype(i).eq.ntyp1) cycle
5679 C Zero the energy function and its derivative at 0 or pi.
5680         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5681         it=itype(i-1)
5682         ichir1=isign(1,itype(i-2))
5683         ichir2=isign(1,itype(i))
5684          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5685          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5686          if (itype(i-1).eq.10) then
5687           itype1=isign(10,itype(i-2))
5688           ichir11=isign(1,itype(i-2))
5689           ichir12=isign(1,itype(i-2))
5690           itype2=isign(10,itype(i))
5691           ichir21=isign(1,itype(i))
5692           ichir22=isign(1,itype(i))
5693          endif
5694
5695         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5696 #ifdef OSF
5697           phii=phi(i)
5698           if (phii.ne.phii) phii=150.0
5699 #else
5700           phii=phi(i)
5701 #endif
5702           y(1)=dcos(phii)
5703           y(2)=dsin(phii)
5704         else
5705           y(1)=0.0D0
5706           y(2)=0.0D0
5707         endif
5708         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5709 #ifdef OSF
5710           phii1=phi(i+1)
5711           if (phii1.ne.phii1) phii1=150.0
5712           phii1=pinorm(phii1)
5713           z(1)=cos(phii1)
5714 #else
5715           phii1=phi(i+1)
5716 #endif
5717           z(1)=dcos(phii1)
5718           z(2)=dsin(phii1)
5719         else
5720           z(1)=0.0D0
5721           z(2)=0.0D0
5722         endif
5723 C Calculate the "mean" value of theta from the part of the distribution
5724 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5725 C In following comments this theta will be referred to as t_c.
5726         thet_pred_mean=0.0d0
5727         do k=1,2
5728             athetk=athet(k,it,ichir1,ichir2)
5729             bthetk=bthet(k,it,ichir1,ichir2)
5730           if (it.eq.10) then
5731              athetk=athet(k,itype1,ichir11,ichir12)
5732              bthetk=bthet(k,itype2,ichir21,ichir22)
5733           endif
5734          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5735 c         write(iout,*) 'chuj tu', y(k),z(k)
5736         enddo
5737         dthett=thet_pred_mean*ssd
5738         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5739 C Derivatives of the "mean" values in gamma1 and gamma2.
5740         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5741      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5742          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5743      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5744          if (it.eq.10) then
5745       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5746      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5747         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5748      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5749          endif
5750         if (theta(i).gt.pi-delta) then
5751           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5752      &         E_tc0)
5753           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5754           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5755           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5756      &        E_theta)
5757           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5758      &        E_tc)
5759         else if (theta(i).lt.delta) then
5760           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5761           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5762           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5763      &        E_theta)
5764           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5765           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5766      &        E_tc)
5767         else
5768           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5769      &        E_theta,E_tc)
5770         endif
5771         etheta=etheta+ethetai
5772         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5773      &      'ebend',i,ethetai,theta(i),itype(i)
5774         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5775         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5776         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5777       enddo
5778 c      write (iout,*) "Exit loop"
5779 c      call flush_(iout)
5780       ethetacnstr=0.0d0
5781 c      write (iout,*) ithetaconstr_start,ithetaconstr_end,"TU"
5782 c      call flush_(iout)
5783       do i=max0(ithetaconstr_start,1),ithetaconstr_end
5784         itheta=itheta_constr(i)
5785         thetiii=theta(itheta)
5786         difi=pinorm(thetiii-theta_constr0(i))
5787         if (difi.gt.theta_drange(i)) then
5788           difi=difi-theta_drange(i)
5789           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5790           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5791      &    +for_thet_constr(i)*difi**3
5792         else if (difi.lt.-drange(i)) then
5793           difi=difi+drange(i)
5794           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5795           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5796      &    +for_thet_constr(i)*difi**3
5797         else
5798           difi=0.0
5799         endif
5800        if (energy_dec) then
5801         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5802      &    i,itheta,rad2deg*thetiii,
5803      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5804      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5805      &    gloc(itheta+nphi-2,icg)
5806         endif
5807       enddo
5808 c      write (iout,*) "Exit ebend"
5809 c      call flush_(iout)
5810
5811 C Ufff.... We've done all this!!!
5812       return
5813       end
5814 C---------------------------------------------------------------------------
5815       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5816      &     E_tc)
5817       implicit real*8 (a-h,o-z)
5818       include 'DIMENSIONS'
5819       include 'COMMON.LOCAL'
5820       include 'COMMON.IOUNITS'
5821       common /calcthet/ term1,term2,termm,diffak,ratak,
5822      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5823      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5824 C Calculate the contributions to both Gaussian lobes.
5825 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5826 C The "polynomial part" of the "standard deviation" of this part of
5827 C the distributioni.
5828 ccc        write (iout,*) thetai,thet_pred_mean
5829         sig=polthet(3,it)
5830         do j=2,0,-1
5831           sig=sig*thet_pred_mean+polthet(j,it)
5832         enddo
5833 C Derivative of the "interior part" of the "standard deviation of the"
5834 C gamma-dependent Gaussian lobe in t_c.
5835         sigtc=3*polthet(3,it)
5836         do j=2,1,-1
5837           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5838         enddo
5839         sigtc=sig*sigtc
5840 C Set the parameters of both Gaussian lobes of the distribution.
5841 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5842         fac=sig*sig+sigc0(it)
5843         sigcsq=fac+fac
5844         sigc=1.0D0/sigcsq
5845 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5846         sigsqtc=-4.0D0*sigcsq*sigtc
5847 c       print *,i,sig,sigtc,sigsqtc
5848 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5849         sigtc=-sigtc/(fac*fac)
5850 C Following variable is sigma(t_c)**(-2)
5851         sigcsq=sigcsq*sigcsq
5852         sig0i=sig0(it)
5853         sig0inv=1.0D0/sig0i**2
5854         delthec=thetai-thet_pred_mean
5855         delthe0=thetai-theta0i
5856         term1=-0.5D0*sigcsq*delthec*delthec
5857         term2=-0.5D0*sig0inv*delthe0*delthe0
5858 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5859 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5860 C NaNs in taking the logarithm. We extract the largest exponent which is added
5861 C to the energy (this being the log of the distribution) at the end of energy
5862 C term evaluation for this virtual-bond angle.
5863         if (term1.gt.term2) then
5864           termm=term1
5865           term2=dexp(term2-termm)
5866           term1=1.0d0
5867         else
5868           termm=term2
5869           term1=dexp(term1-termm)
5870           term2=1.0d0
5871         endif
5872 C The ratio between the gamma-independent and gamma-dependent lobes of
5873 C the distribution is a Gaussian function of thet_pred_mean too.
5874         diffak=gthet(2,it)-thet_pred_mean
5875         ratak=diffak/gthet(3,it)**2
5876         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5877 C Let's differentiate it in thet_pred_mean NOW.
5878         aktc=ak*ratak
5879 C Now put together the distribution terms to make complete distribution.
5880         termexp=term1+ak*term2
5881         termpre=sigc+ak*sig0i
5882 C Contribution of the bending energy from this theta is just the -log of
5883 C the sum of the contributions from the two lobes and the pre-exponential
5884 C factor. Simple enough, isn't it?
5885         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5886 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5887 C NOW the derivatives!!!
5888 C 6/6/97 Take into account the deformation.
5889         E_theta=(delthec*sigcsq*term1
5890      &       +ak*delthe0*sig0inv*term2)/termexp
5891         E_tc=((sigtc+aktc*sig0i)/termpre
5892      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5893      &       aktc*term2)/termexp)
5894       return
5895       end
5896 c-----------------------------------------------------------------------------
5897       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5898       implicit real*8 (a-h,o-z)
5899       include 'DIMENSIONS'
5900       include 'COMMON.LOCAL'
5901       include 'COMMON.IOUNITS'
5902       common /calcthet/ term1,term2,termm,diffak,ratak,
5903      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5904      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5905       delthec=thetai-thet_pred_mean
5906       delthe0=thetai-theta0i
5907 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5908       t3 = thetai-thet_pred_mean
5909       t6 = t3**2
5910       t9 = term1
5911       t12 = t3*sigcsq
5912       t14 = t12+t6*sigsqtc
5913       t16 = 1.0d0
5914       t21 = thetai-theta0i
5915       t23 = t21**2
5916       t26 = term2
5917       t27 = t21*t26
5918       t32 = termexp
5919       t40 = t32**2
5920       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5921      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5922      & *(-t12*t9-ak*sig0inv*t27)
5923       return
5924       end
5925 #else
5926 C--------------------------------------------------------------------------
5927       subroutine ebend(etheta,ethetacnstr)
5928 C
5929 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5930 C angles gamma and its derivatives in consecutive thetas and gammas.
5931 C ab initio-derived potentials from
5932 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5933 C
5934       implicit real*8 (a-h,o-z)
5935       include 'DIMENSIONS'
5936       include 'COMMON.LOCAL'
5937       include 'COMMON.GEO'
5938       include 'COMMON.INTERACT'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.VAR'
5941       include 'COMMON.CHAIN'
5942       include 'COMMON.IOUNITS'
5943       include 'COMMON.NAMES'
5944       include 'COMMON.FFIELD'
5945       include 'COMMON.CONTROL'
5946       include 'COMMON.TORCNSTR'
5947       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5948      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5949      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5950      & sinph1ph2(maxdouble,maxdouble)
5951       logical lprn /.false./, lprn1 /.false./
5952       etheta=0.0D0
5953       do i=ithet_start,ithet_end
5954         if (i.le.2) cycle
5955 c        print *,i,itype(i-1),itype(i),itype(i-2)
5956         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5957      &  .or.itype(i).eq.ntyp1) cycle
5958 C        print *,i,theta(i)
5959         if (iabs(itype(i+1)).eq.20) iblock=2
5960         if (iabs(itype(i+1)).ne.20) iblock=1
5961         dethetai=0.0d0
5962         dephii=0.0d0
5963         dephii1=0.0d0
5964         theti2=0.5d0*theta(i)
5965         ityp2=ithetyp((itype(i-1)))
5966         do k=1,nntheterm
5967           coskt(k)=dcos(k*theti2)
5968           sinkt(k)=dsin(k*theti2)
5969         enddo
5970 C        print *,ethetai
5971         if (i.eq.3) then
5972           phii=0.0d0
5973           ityp1=nthetyp+1
5974           do k=1,nsingle
5975             cosph1(k)=0.0d0
5976             sinph1(k)=0.0d0
5977           enddo
5978         else
5979
5980         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5981 #ifdef OSF
5982           phii=phi(i)
5983           if (phii.ne.phii) phii=150.0
5984 #else
5985           phii=phi(i)
5986 #endif
5987           ityp1=ithetyp((itype(i-2)))
5988 C propagation of chirality for glycine type
5989           do k=1,nsingle
5990             cosph1(k)=dcos(k*phii)
5991             sinph1(k)=dsin(k*phii)
5992           enddo
5993         else
5994           phii=0.0d0
5995           do k=1,nsingle
5996           ityp1=ithetyp((itype(i-2)))
5997             cosph1(k)=0.0d0
5998             sinph1(k)=0.0d0
5999           enddo
6000         endif
6001         endif
6002         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6003 #ifdef OSF
6004           phii1=phi(i+1)
6005           if (phii1.ne.phii1) phii1=150.0
6006           phii1=pinorm(phii1)
6007 #else
6008           phii1=phi(i+1)
6009 #endif
6010           ityp3=ithetyp((itype(i)))
6011           do k=1,nsingle
6012             cosph2(k)=dcos(k*phii1)
6013             sinph2(k)=dsin(k*phii1)
6014           enddo
6015         else
6016           phii1=0.0d0
6017           ityp3=ithetyp((itype(i)))
6018           do k=1,nsingle
6019             cosph2(k)=0.0d0
6020             sinph2(k)=0.0d0
6021           enddo
6022         endif
6023         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6024         do k=1,ndouble
6025           do l=1,k-1
6026             ccl=cosph1(l)*cosph2(k-l)
6027             ssl=sinph1(l)*sinph2(k-l)
6028             scl=sinph1(l)*cosph2(k-l)
6029             csl=cosph1(l)*sinph2(k-l)
6030             cosph1ph2(l,k)=ccl-ssl
6031             cosph1ph2(k,l)=ccl+ssl
6032             sinph1ph2(l,k)=scl+csl
6033             sinph1ph2(k,l)=scl-csl
6034           enddo
6035         enddo
6036         if (lprn) then
6037         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6038      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6039         write (iout,*) "coskt and sinkt"
6040         do k=1,nntheterm
6041           write (iout,*) k,coskt(k),sinkt(k)
6042         enddo
6043         endif
6044         do k=1,ntheterm
6045           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6046           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6047      &      *coskt(k)
6048           if (lprn)
6049      &    write (iout,*) "k",k,"
6050      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6051      &     " ethetai",ethetai
6052         enddo
6053         if (lprn) then
6054         write (iout,*) "cosph and sinph"
6055         do k=1,nsingle
6056           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6057         enddo
6058         write (iout,*) "cosph1ph2 and sinph2ph2"
6059         do k=2,ndouble
6060           do l=1,k-1
6061             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6062      &         sinph1ph2(l,k),sinph1ph2(k,l)
6063           enddo
6064         enddo
6065         write(iout,*) "ethetai",ethetai
6066         endif
6067 C       print *,ethetai
6068         do m=1,ntheterm2
6069           do k=1,nsingle
6070             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6071      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6072      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6073      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6074             ethetai=ethetai+sinkt(m)*aux
6075             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6076             dephii=dephii+k*sinkt(m)*(
6077      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6078      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6079             dephii1=dephii1+k*sinkt(m)*(
6080      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6081      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6082             if (lprn)
6083      &      write (iout,*) "m",m," k",k," bbthet",
6084      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6085      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6086      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6087      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6088 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6089           enddo
6090         enddo
6091 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6092 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6093 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6094 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6095         if (lprn)
6096      &  write(iout,*) "ethetai",ethetai
6097 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6098         do m=1,ntheterm3
6099           do k=2,ndouble
6100             do l=1,k-1
6101               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6102      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6103      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6104      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6105               ethetai=ethetai+sinkt(m)*aux
6106               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6107               dephii=dephii+l*sinkt(m)*(
6108      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6109      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6110      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6111      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6112               dephii1=dephii1+(k-l)*sinkt(m)*(
6113      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6114      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6115      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6116      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6117               if (lprn) then
6118               write (iout,*) "m",m," k",k," l",l," ffthet",
6119      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6120      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6121      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6122      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6123      &            " ethetai",ethetai
6124               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6125      &            cosph1ph2(k,l)*sinkt(m),
6126      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6127               endif
6128             enddo
6129           enddo
6130         enddo
6131 10      continue
6132 c        lprn1=.true.
6133 C        print *,ethetai
6134         if (lprn1)
6135      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6136      &   i,theta(i)*rad2deg,phii*rad2deg,
6137      &   phii1*rad2deg,ethetai
6138 c        lprn1=.false.
6139         etheta=etheta+ethetai
6140         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6141         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6142         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6143       enddo
6144 C now constrains
6145       ethetacnstr=0.0d0
6146 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6147       do i=max0(ithetaconstr_start,1),ithetaconstr_end
6148         itheta=itheta_constr(i)
6149         thetiii=theta(itheta)
6150         difi=pinorm(thetiii-theta_constr0(i))
6151         if (difi.gt.theta_drange(i)) then
6152           difi=difi-theta_drange(i)
6153           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6154           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6155      &    +for_thet_constr(i)*difi**3
6156         else if (difi.lt.-drange(i)) then
6157           difi=difi+drange(i)
6158           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6159           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6160      &    +for_thet_constr(i)*difi**3
6161         else
6162           difi=0.0
6163         endif
6164        if (energy_dec) then
6165         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6166      &    i,itheta,rad2deg*thetiii,
6167      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6168      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6169      &    gloc(itheta+nphi-2,icg)
6170         endif
6171       enddo
6172
6173       return
6174       end
6175 #endif
6176 #ifdef CRYST_SC
6177 c-----------------------------------------------------------------------------
6178       subroutine esc(escloc)
6179 C Calculate the local energy of a side chain and its derivatives in the
6180 C corresponding virtual-bond valence angles THETA and the spherical angles
6181 C ALPHA and OMEGA.
6182       implicit real*8 (a-h,o-z)
6183       include 'DIMENSIONS'
6184       include 'COMMON.GEO'
6185       include 'COMMON.LOCAL'
6186       include 'COMMON.VAR'
6187       include 'COMMON.INTERACT'
6188       include 'COMMON.DERIV'
6189       include 'COMMON.CHAIN'
6190       include 'COMMON.IOUNITS'
6191       include 'COMMON.NAMES'
6192       include 'COMMON.FFIELD'
6193       include 'COMMON.CONTROL'
6194       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6195      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6196       common /sccalc/ time11,time12,time112,theti,it,nlobit
6197       delta=0.02d0*pi
6198       escloc=0.0D0
6199 c     write (iout,'(a)') 'ESC'
6200       do i=loc_start,loc_end
6201         it=itype(i)
6202         if (it.eq.ntyp1) cycle
6203         if (it.eq.10) goto 1
6204         nlobit=nlob(iabs(it))
6205 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6206 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6207         theti=theta(i+1)-pipol
6208         x(1)=dtan(theti)
6209         x(2)=alph(i)
6210         x(3)=omeg(i)
6211
6212         if (x(2).gt.pi-delta) then
6213           xtemp(1)=x(1)
6214           xtemp(2)=pi-delta
6215           xtemp(3)=x(3)
6216           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6217           xtemp(2)=pi
6218           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6219           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6220      &        escloci,dersc(2))
6221           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6222      &        ddersc0(1),dersc(1))
6223           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6224      &        ddersc0(3),dersc(3))
6225           xtemp(2)=pi-delta
6226           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6227           xtemp(2)=pi
6228           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6229           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6230      &            dersc0(2),esclocbi,dersc02)
6231           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6232      &            dersc12,dersc01)
6233           call splinthet(x(2),0.5d0*delta,ss,ssd)
6234           dersc0(1)=dersc01
6235           dersc0(2)=dersc02
6236           dersc0(3)=0.0d0
6237           do k=1,3
6238             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6239           enddo
6240           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6241 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6242 c    &             esclocbi,ss,ssd
6243           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6244 c         escloci=esclocbi
6245 c         write (iout,*) escloci
6246         else if (x(2).lt.delta) then
6247           xtemp(1)=x(1)
6248           xtemp(2)=delta
6249           xtemp(3)=x(3)
6250           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6251           xtemp(2)=0.0d0
6252           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6253           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6254      &        escloci,dersc(2))
6255           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6256      &        ddersc0(1),dersc(1))
6257           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6258      &        ddersc0(3),dersc(3))
6259           xtemp(2)=delta
6260           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6261           xtemp(2)=0.0d0
6262           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6263           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6264      &            dersc0(2),esclocbi,dersc02)
6265           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6266      &            dersc12,dersc01)
6267           dersc0(1)=dersc01
6268           dersc0(2)=dersc02
6269           dersc0(3)=0.0d0
6270           call splinthet(x(2),0.5d0*delta,ss,ssd)
6271           do k=1,3
6272             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6273           enddo
6274           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6275 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6276 c    &             esclocbi,ss,ssd
6277           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6278 c         write (iout,*) escloci
6279         else
6280           call enesc(x,escloci,dersc,ddummy,.false.)
6281         endif
6282
6283         escloc=escloc+escloci
6284         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6285      &     'escloc',i,escloci
6286 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6287
6288         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6289      &   wscloc*dersc(1)
6290         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6291         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6292     1   continue
6293       enddo
6294       return
6295       end
6296 C---------------------------------------------------------------------------
6297       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6298       implicit real*8 (a-h,o-z)
6299       include 'DIMENSIONS'
6300       include 'COMMON.GEO'
6301       include 'COMMON.LOCAL'
6302       include 'COMMON.IOUNITS'
6303       common /sccalc/ time11,time12,time112,theti,it,nlobit
6304       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6305       double precision contr(maxlob,-1:1)
6306       logical mixed
6307 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6308         escloc_i=0.0D0
6309         do j=1,3
6310           dersc(j)=0.0D0
6311           if (mixed) ddersc(j)=0.0d0
6312         enddo
6313         x3=x(3)
6314
6315 C Because of periodicity of the dependence of the SC energy in omega we have
6316 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6317 C To avoid underflows, first compute & store the exponents.
6318
6319         do iii=-1,1
6320
6321           x(3)=x3+iii*dwapi
6322
6323           do j=1,nlobit
6324             do k=1,3
6325               z(k)=x(k)-censc(k,j,it)
6326             enddo
6327             do k=1,3
6328               Axk=0.0D0
6329               do l=1,3
6330                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6331               enddo
6332               Ax(k,j,iii)=Axk
6333             enddo
6334             expfac=0.0D0
6335             do k=1,3
6336               expfac=expfac+Ax(k,j,iii)*z(k)
6337             enddo
6338             contr(j,iii)=expfac
6339           enddo ! j
6340
6341         enddo ! iii
6342
6343         x(3)=x3
6344 C As in the case of ebend, we want to avoid underflows in exponentiation and
6345 C subsequent NaNs and INFs in energy calculation.
6346 C Find the largest exponent
6347         emin=contr(1,-1)
6348         do iii=-1,1
6349           do j=1,nlobit
6350             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6351           enddo
6352         enddo
6353         emin=0.5D0*emin
6354 cd      print *,'it=',it,' emin=',emin
6355
6356 C Compute the contribution to SC energy and derivatives
6357         do iii=-1,1
6358
6359           do j=1,nlobit
6360 #ifdef OSF
6361             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6362             if(adexp.ne.adexp) adexp=1.0
6363             expfac=dexp(adexp)
6364 #else
6365             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6366 #endif
6367 cd          print *,'j=',j,' expfac=',expfac
6368             escloc_i=escloc_i+expfac
6369             do k=1,3
6370               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6371             enddo
6372             if (mixed) then
6373               do k=1,3,2
6374                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6375      &            +gaussc(k,2,j,it))*expfac
6376               enddo
6377             endif
6378           enddo
6379
6380         enddo ! iii
6381
6382         dersc(1)=dersc(1)/cos(theti)**2
6383         ddersc(1)=ddersc(1)/cos(theti)**2
6384         ddersc(3)=ddersc(3)
6385
6386         escloci=-(dlog(escloc_i)-emin)
6387         do j=1,3
6388           dersc(j)=dersc(j)/escloc_i
6389         enddo
6390         if (mixed) then
6391           do j=1,3,2
6392             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6393           enddo
6394         endif
6395       return
6396       end
6397 C------------------------------------------------------------------------------
6398       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6399       implicit real*8 (a-h,o-z)
6400       include 'DIMENSIONS'
6401       include 'COMMON.GEO'
6402       include 'COMMON.LOCAL'
6403       include 'COMMON.IOUNITS'
6404       common /sccalc/ time11,time12,time112,theti,it,nlobit
6405       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6406       double precision contr(maxlob)
6407       logical mixed
6408
6409       escloc_i=0.0D0
6410
6411       do j=1,3
6412         dersc(j)=0.0D0
6413       enddo
6414
6415       do j=1,nlobit
6416         do k=1,2
6417           z(k)=x(k)-censc(k,j,it)
6418         enddo
6419         z(3)=dwapi
6420         do k=1,3
6421           Axk=0.0D0
6422           do l=1,3
6423             Axk=Axk+gaussc(l,k,j,it)*z(l)
6424           enddo
6425           Ax(k,j)=Axk
6426         enddo
6427         expfac=0.0D0
6428         do k=1,3
6429           expfac=expfac+Ax(k,j)*z(k)
6430         enddo
6431         contr(j)=expfac
6432       enddo ! j
6433
6434 C As in the case of ebend, we want to avoid underflows in exponentiation and
6435 C subsequent NaNs and INFs in energy calculation.
6436 C Find the largest exponent
6437       emin=contr(1)
6438       do j=1,nlobit
6439         if (emin.gt.contr(j)) emin=contr(j)
6440       enddo
6441       emin=0.5D0*emin
6442
6443 C Compute the contribution to SC energy and derivatives
6444
6445       dersc12=0.0d0
6446       do j=1,nlobit
6447         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6448         escloc_i=escloc_i+expfac
6449         do k=1,2
6450           dersc(k)=dersc(k)+Ax(k,j)*expfac
6451         enddo
6452         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6453      &            +gaussc(1,2,j,it))*expfac
6454         dersc(3)=0.0d0
6455       enddo
6456
6457       dersc(1)=dersc(1)/cos(theti)**2
6458       dersc12=dersc12/cos(theti)**2
6459       escloci=-(dlog(escloc_i)-emin)
6460       do j=1,2
6461         dersc(j)=dersc(j)/escloc_i
6462       enddo
6463       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6464       return
6465       end
6466 #else
6467 c----------------------------------------------------------------------------------
6468       subroutine esc(escloc)
6469 C Calculate the local energy of a side chain and its derivatives in the
6470 C corresponding virtual-bond valence angles THETA and the spherical angles
6471 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6472 C added by Urszula Kozlowska. 07/11/2007
6473 C
6474       implicit real*8 (a-h,o-z)
6475       include 'DIMENSIONS'
6476       include 'COMMON.GEO'
6477       include 'COMMON.LOCAL'
6478       include 'COMMON.VAR'
6479       include 'COMMON.SCROT'
6480       include 'COMMON.INTERACT'
6481       include 'COMMON.DERIV'
6482       include 'COMMON.CHAIN'
6483       include 'COMMON.IOUNITS'
6484       include 'COMMON.NAMES'
6485       include 'COMMON.FFIELD'
6486       include 'COMMON.CONTROL'
6487       include 'COMMON.VECTORS'
6488       double precision x_prime(3),y_prime(3),z_prime(3)
6489      &    , sumene,dsc_i,dp2_i,x(65),
6490      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6491      &    de_dxx,de_dyy,de_dzz,de_dt
6492       double precision s1_t,s1_6_t,s2_t,s2_6_t
6493       double precision
6494      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6495      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6496      & dt_dCi(3),dt_dCi1(3)
6497       common /sccalc/ time11,time12,time112,theti,it,nlobit
6498       delta=0.02d0*pi
6499       escloc=0.0D0
6500       do i=loc_start,loc_end
6501         if (itype(i).eq.ntyp1) cycle
6502         costtab(i+1) =dcos(theta(i+1))
6503         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6504         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6505         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6506         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6507         cosfac=dsqrt(cosfac2)
6508         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6509         sinfac=dsqrt(sinfac2)
6510         it=iabs(itype(i))
6511         if (it.eq.10) goto 1
6512 c
6513 C  Compute the axes of tghe local cartesian coordinates system; store in
6514 c   x_prime, y_prime and z_prime
6515 c
6516         do j=1,3
6517           x_prime(j) = 0.00
6518           y_prime(j) = 0.00
6519           z_prime(j) = 0.00
6520         enddo
6521 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6522 C     &   dc_norm(3,i+nres)
6523         do j = 1,3
6524           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6525           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6526         enddo
6527         do j = 1,3
6528           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6529         enddo
6530 c       write (2,*) "i",i
6531 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6532 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6533 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6534 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6535 c      & " xy",scalar(x_prime(1),y_prime(1)),
6536 c      & " xz",scalar(x_prime(1),z_prime(1)),
6537 c      & " yy",scalar(y_prime(1),y_prime(1)),
6538 c      & " yz",scalar(y_prime(1),z_prime(1)),
6539 c      & " zz",scalar(z_prime(1),z_prime(1))
6540 c
6541 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6542 C to local coordinate system. Store in xx, yy, zz.
6543 c
6544         xx=0.0d0
6545         yy=0.0d0
6546         zz=0.0d0
6547         do j = 1,3
6548           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6549           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6550           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6551         enddo
6552
6553         xxtab(i)=xx
6554         yytab(i)=yy
6555         zztab(i)=zz
6556 C
6557 C Compute the energy of the ith side cbain
6558 C
6559 c        write (2,*) "xx",xx," yy",yy," zz",zz
6560         it=iabs(itype(i))
6561         do j = 1,65
6562           x(j) = sc_parmin(j,it)
6563         enddo
6564 #ifdef CHECK_COORD
6565 Cc diagnostics - remove later
6566         xx1 = dcos(alph(2))
6567         yy1 = dsin(alph(2))*dcos(omeg(2))
6568         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6569         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6570      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6571      &    xx1,yy1,zz1
6572 C,"  --- ", xx_w,yy_w,zz_w
6573 c end diagnostics
6574 #endif
6575         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6576      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6577      &   + x(10)*yy*zz
6578         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6579      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6580      & + x(20)*yy*zz
6581         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6582      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6583      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6584      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6585      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6586      &  +x(40)*xx*yy*zz
6587         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6588      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6589      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6590      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6591      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6592      &  +x(60)*xx*yy*zz
6593         dsc_i   = 0.743d0+x(61)
6594         dp2_i   = 1.9d0+x(62)
6595         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6596      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6597         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6598      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6599         s1=(1+x(63))/(0.1d0 + dscp1)
6600         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6601         s2=(1+x(65))/(0.1d0 + dscp2)
6602         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6603         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6604      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6605 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6606 c     &   sumene4,
6607 c     &   dscp1,dscp2,sumene
6608 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6609         escloc = escloc + sumene
6610 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6611 c     & ,zz,xx,yy
6612 c#define DEBUG
6613 #ifdef DEBUG
6614 C
6615 C This section to check the numerical derivatives of the energy of ith side
6616 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6617 C #define DEBUG in the code to turn it on.
6618 C
6619         write (2,*) "sumene               =",sumene
6620         aincr=1.0d-7
6621         xxsave=xx
6622         xx=xx+aincr
6623         write (2,*) xx,yy,zz
6624         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6625         de_dxx_num=(sumenep-sumene)/aincr
6626         xx=xxsave
6627         write (2,*) "xx+ sumene from enesc=",sumenep
6628         yysave=yy
6629         yy=yy+aincr
6630         write (2,*) xx,yy,zz
6631         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6632         de_dyy_num=(sumenep-sumene)/aincr
6633         yy=yysave
6634         write (2,*) "yy+ sumene from enesc=",sumenep
6635         zzsave=zz
6636         zz=zz+aincr
6637         write (2,*) xx,yy,zz
6638         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6639         de_dzz_num=(sumenep-sumene)/aincr
6640         zz=zzsave
6641         write (2,*) "zz+ sumene from enesc=",sumenep
6642         costsave=cost2tab(i+1)
6643         sintsave=sint2tab(i+1)
6644         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6645         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6646         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6647         de_dt_num=(sumenep-sumene)/aincr
6648         write (2,*) " t+ sumene from enesc=",sumenep
6649         cost2tab(i+1)=costsave
6650         sint2tab(i+1)=sintsave
6651 C End of diagnostics section.
6652 #endif
6653 C
6654 C Compute the gradient of esc
6655 C
6656 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6657         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6658         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6659         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6660         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6661         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6662         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6663         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6664         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6665         pom1=(sumene3*sint2tab(i+1)+sumene1)
6666      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6667         pom2=(sumene4*cost2tab(i+1)+sumene2)
6668      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6669         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6670         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6671      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6672      &  +x(40)*yy*zz
6673         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6674         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6675      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6676      &  +x(60)*yy*zz
6677         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6678      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6679      &        +(pom1+pom2)*pom_dx
6680 #ifdef DEBUG
6681         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6682 #endif
6683 C
6684         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6685         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6686      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6687      &  +x(40)*xx*zz
6688         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6689         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6690      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6691      &  +x(59)*zz**2 +x(60)*xx*zz
6692         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6693      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6694      &        +(pom1-pom2)*pom_dy
6695 #ifdef DEBUG
6696         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6697 #endif
6698 C
6699         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6700      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6701      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6702      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6703      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6704      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6705      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6706      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6707 #ifdef DEBUG
6708         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6709 #endif
6710 C
6711         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6712      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6713      &  +pom1*pom_dt1+pom2*pom_dt2
6714 #ifdef DEBUG
6715         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6716 #endif
6717 c#undef DEBUG
6718 c
6719 C
6720        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6721        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6722        cosfac2xx=cosfac2*xx
6723        sinfac2yy=sinfac2*yy
6724        do k = 1,3
6725          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6726      &      vbld_inv(i+1)
6727          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6728      &      vbld_inv(i)
6729          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6730          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6731 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6732 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6733 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6734 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6735          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6736          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6737          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6738          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6739          dZZ_Ci1(k)=0.0d0
6740          dZZ_Ci(k)=0.0d0
6741          do j=1,3
6742            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6743      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6744            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6745      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6746          enddo
6747
6748          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6749          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6750          dZZ_XYZ(k)=vbld_inv(i+nres)*
6751      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6752 c
6753          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6754          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6755        enddo
6756
6757        do k=1,3
6758          dXX_Ctab(k,i)=dXX_Ci(k)
6759          dXX_C1tab(k,i)=dXX_Ci1(k)
6760          dYY_Ctab(k,i)=dYY_Ci(k)
6761          dYY_C1tab(k,i)=dYY_Ci1(k)
6762          dZZ_Ctab(k,i)=dZZ_Ci(k)
6763          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6764          dXX_XYZtab(k,i)=dXX_XYZ(k)
6765          dYY_XYZtab(k,i)=dYY_XYZ(k)
6766          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6767        enddo
6768
6769        do k = 1,3
6770 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6771 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6772 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6773 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6774 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6775 c     &    dt_dci(k)
6776 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6777 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6778          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6779      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6780          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6781      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6782          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6783      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6784        enddo
6785 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6786 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6787
6788 C to check gradient call subroutine check_grad
6789
6790     1 continue
6791       enddo
6792       return
6793       end
6794 c------------------------------------------------------------------------------
6795       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6796       implicit none
6797       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6798      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6799       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6800      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6801      &   + x(10)*yy*zz
6802       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6803      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6804      & + x(20)*yy*zz
6805       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6806      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6807      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6808      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6809      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6810      &  +x(40)*xx*yy*zz
6811       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6812      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6813      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6814      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6815      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6816      &  +x(60)*xx*yy*zz
6817       dsc_i   = 0.743d0+x(61)
6818       dp2_i   = 1.9d0+x(62)
6819       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6820      &          *(xx*cost2+yy*sint2))
6821       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6822      &          *(xx*cost2-yy*sint2))
6823       s1=(1+x(63))/(0.1d0 + dscp1)
6824       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6825       s2=(1+x(65))/(0.1d0 + dscp2)
6826       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6827       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6828      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6829       enesc=sumene
6830       return
6831       end
6832 #endif
6833 c------------------------------------------------------------------------------
6834       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6835 C
6836 C This procedure calculates two-body contact function g(rij) and its derivative:
6837 C
6838 C           eps0ij                                     !       x < -1
6839 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6840 C            0                                         !       x > 1
6841 C
6842 C where x=(rij-r0ij)/delta
6843 C
6844 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6845 C
6846       implicit none
6847       double precision rij,r0ij,eps0ij,fcont,fprimcont
6848       double precision x,x2,x4,delta
6849 c     delta=0.02D0*r0ij
6850 c      delta=0.2D0*r0ij
6851       x=(rij-r0ij)/delta
6852       if (x.lt.-1.0D0) then
6853         fcont=eps0ij
6854         fprimcont=0.0D0
6855       else if (x.le.1.0D0) then
6856         x2=x*x
6857         x4=x2*x2
6858         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6859         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6860       else
6861         fcont=0.0D0
6862         fprimcont=0.0D0
6863       endif
6864       return
6865       end
6866 c------------------------------------------------------------------------------
6867       subroutine splinthet(theti,delta,ss,ssder)
6868       implicit real*8 (a-h,o-z)
6869       include 'DIMENSIONS'
6870       include 'COMMON.VAR'
6871       include 'COMMON.GEO'
6872       thetup=pi-delta
6873       thetlow=delta
6874       if (theti.gt.pipol) then
6875         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6876       else
6877         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6878         ssder=-ssder
6879       endif
6880       return
6881       end
6882 c------------------------------------------------------------------------------
6883       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6884       implicit none
6885       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6886       double precision ksi,ksi2,ksi3,a1,a2,a3
6887       a1=fprim0*delta/(f1-f0)
6888       a2=3.0d0-2.0d0*a1
6889       a3=a1-2.0d0
6890       ksi=(x-x0)/delta
6891       ksi2=ksi*ksi
6892       ksi3=ksi2*ksi
6893       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6894       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6895       return
6896       end
6897 c------------------------------------------------------------------------------
6898       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6899       implicit none
6900       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6901       double precision ksi,ksi2,ksi3,a1,a2,a3
6902       ksi=(x-x0)/delta
6903       ksi2=ksi*ksi
6904       ksi3=ksi2*ksi
6905       a1=fprim0x*delta
6906       a2=3*(f1x-f0x)-2*fprim0x*delta
6907       a3=fprim0x*delta-2*(f1x-f0x)
6908       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6909       return
6910       end
6911 C-----------------------------------------------------------------------------
6912 #ifdef CRYST_TOR
6913 C-----------------------------------------------------------------------------
6914       subroutine etor(etors,edihcnstr)
6915       implicit real*8 (a-h,o-z)
6916       include 'DIMENSIONS'
6917       include 'COMMON.VAR'
6918       include 'COMMON.GEO'
6919       include 'COMMON.LOCAL'
6920       include 'COMMON.TORSION'
6921       include 'COMMON.INTERACT'
6922       include 'COMMON.DERIV'
6923       include 'COMMON.CHAIN'
6924       include 'COMMON.NAMES'
6925       include 'COMMON.IOUNITS'
6926       include 'COMMON.FFIELD'
6927       include 'COMMON.TORCNSTR'
6928       include 'COMMON.CONTROL'
6929       logical lprn
6930 C Set lprn=.true. for debugging
6931       lprn=.false.
6932 c      lprn=.true.
6933       etors=0.0D0
6934       do i=iphi_start,iphi_end
6935       etors_ii=0.0D0
6936         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6937      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6938         itori=itortyp(itype(i-2))
6939         itori1=itortyp(itype(i-1))
6940         phii=phi(i)
6941         gloci=0.0D0
6942 C Proline-Proline pair is a special case...
6943         if (itori.eq.3 .and. itori1.eq.3) then
6944           if (phii.gt.-dwapi3) then
6945             cosphi=dcos(3*phii)
6946             fac=1.0D0/(1.0D0-cosphi)
6947             etorsi=v1(1,3,3)*fac
6948             etorsi=etorsi+etorsi
6949             etors=etors+etorsi-v1(1,3,3)
6950             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6951             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6952           endif
6953           do j=1,3
6954             v1ij=v1(j+1,itori,itori1)
6955             v2ij=v2(j+1,itori,itori1)
6956             cosphi=dcos(j*phii)
6957             sinphi=dsin(j*phii)
6958             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6959             if (energy_dec) etors_ii=etors_ii+
6960      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6961             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6962           enddo
6963         else
6964           do j=1,nterm_old
6965             v1ij=v1(j,itori,itori1)
6966             v2ij=v2(j,itori,itori1)
6967             cosphi=dcos(j*phii)
6968             sinphi=dsin(j*phii)
6969             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6970             if (energy_dec) etors_ii=etors_ii+
6971      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6972             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6973           enddo
6974         endif
6975         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6976              'etor',i,etors_ii
6977         if (lprn)
6978      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6979      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6980      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6981         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6982 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6983       enddo
6984 ! 6/20/98 - dihedral angle constraints
6985       edihcnstr=0.0d0
6986       do i=1,ndih_constr
6987         itori=idih_constr(i)
6988         phii=phi(itori)
6989         difi=phii-phi0(i)
6990         if (difi.gt.drange(i)) then
6991           difi=difi-drange(i)
6992           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6993           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6994         else if (difi.lt.-drange(i)) then
6995           difi=difi+drange(i)
6996           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6997           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6998         endif
6999 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7000 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7001       enddo
7002 !      write (iout,*) 'edihcnstr',edihcnstr
7003       return
7004       end
7005 c------------------------------------------------------------------------------
7006       subroutine etor_d(etors_d)
7007       etors_d=0.0d0
7008       return
7009       end
7010 c----------------------------------------------------------------------------
7011 #else
7012       subroutine etor(etors,edihcnstr)
7013       implicit real*8 (a-h,o-z)
7014       include 'DIMENSIONS'
7015       include 'COMMON.VAR'
7016       include 'COMMON.GEO'
7017       include 'COMMON.LOCAL'
7018       include 'COMMON.TORSION'
7019       include 'COMMON.INTERACT'
7020       include 'COMMON.DERIV'
7021       include 'COMMON.CHAIN'
7022       include 'COMMON.NAMES'
7023       include 'COMMON.IOUNITS'
7024       include 'COMMON.FFIELD'
7025       include 'COMMON.TORCNSTR'
7026       include 'COMMON.CONTROL'
7027       logical lprn
7028 C Set lprn=.true. for debugging
7029       lprn=.false.
7030 c      lprn=.true.
7031       etors=0.0D0
7032       do i=iphi_start,iphi_end
7033 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7034 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7035 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7036 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7037         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7038      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7039 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7040 C For introducing the NH3+ and COO- group please check the etor_d for reference
7041 C and guidance
7042         etors_ii=0.0D0
7043          if (iabs(itype(i)).eq.20) then
7044          iblock=2
7045          else
7046          iblock=1
7047          endif
7048         itori=itortyp(itype(i-2))
7049         itori1=itortyp(itype(i-1))
7050         phii=phi(i)
7051         gloci=0.0D0
7052 C Regular cosine and sine terms
7053         do j=1,nterm(itori,itori1,iblock)
7054           v1ij=v1(j,itori,itori1,iblock)
7055           v2ij=v2(j,itori,itori1,iblock)
7056           cosphi=dcos(j*phii)
7057           sinphi=dsin(j*phii)
7058           etors=etors+v1ij*cosphi+v2ij*sinphi
7059           if (energy_dec) etors_ii=etors_ii+
7060      &                v1ij*cosphi+v2ij*sinphi
7061           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7062         enddo
7063 C Lorentz terms
7064 C                         v1
7065 C  E = SUM ----------------------------------- - v1
7066 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7067 C
7068         cosphi=dcos(0.5d0*phii)
7069         sinphi=dsin(0.5d0*phii)
7070         do j=1,nlor(itori,itori1,iblock)
7071           vl1ij=vlor1(j,itori,itori1)
7072           vl2ij=vlor2(j,itori,itori1)
7073           vl3ij=vlor3(j,itori,itori1)
7074           pom=vl2ij*cosphi+vl3ij*sinphi
7075           pom1=1.0d0/(pom*pom+1.0d0)
7076           etors=etors+vl1ij*pom1
7077           if (energy_dec) etors_ii=etors_ii+
7078      &                vl1ij*pom1
7079           pom=-pom*pom1*pom1
7080           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7081         enddo
7082 C Subtract the constant term
7083         etors=etors-v0(itori,itori1,iblock)
7084           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7085      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7086         if (lprn)
7087      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7088      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7089      &  (v1(j,itori,itori1,iblock),j=1,6),
7090      &  (v2(j,itori,itori1,iblock),j=1,6)
7091         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7092 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7093       enddo
7094 ! 6/20/98 - dihedral angle constraints
7095       edihcnstr=0.0d0
7096 c      do i=1,ndih_constr
7097       do i=idihconstr_start,idihconstr_end
7098         itori=idih_constr(i)
7099         phii=phi(itori)
7100         difi=pinorm(phii-phi0(i))
7101         if (difi.gt.drange(i)) then
7102           difi=difi-drange(i)
7103           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7104           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7105         else if (difi.lt.-drange(i)) then
7106           difi=difi+drange(i)
7107           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7108           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7109         else
7110           difi=0.0
7111         endif
7112        if (energy_dec) then
7113         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7114      &    i,itori,rad2deg*phii,
7115      &    rad2deg*phi0(i),  rad2deg*drange(i),
7116      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7117         endif
7118       enddo
7119 cd       write (iout,*) 'edihcnstr',edihcnstr
7120       return
7121       end
7122 c----------------------------------------------------------------------------
7123       subroutine etor_d(etors_d)
7124 C 6/23/01 Compute double torsional energy
7125       implicit real*8 (a-h,o-z)
7126       include 'DIMENSIONS'
7127       include 'COMMON.VAR'
7128       include 'COMMON.GEO'
7129       include 'COMMON.LOCAL'
7130       include 'COMMON.TORSION'
7131       include 'COMMON.INTERACT'
7132       include 'COMMON.DERIV'
7133       include 'COMMON.CHAIN'
7134       include 'COMMON.NAMES'
7135       include 'COMMON.IOUNITS'
7136       include 'COMMON.FFIELD'
7137       include 'COMMON.TORCNSTR'
7138       logical lprn
7139 C Set lprn=.true. for debugging
7140       lprn=.false.
7141 c     lprn=.true.
7142       etors_d=0.0D0
7143 c      write(iout,*) "a tu??"
7144       do i=iphid_start,iphid_end
7145 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7146 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7147 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7148 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7149 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7150          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7151      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7152      &  (itype(i+1).eq.ntyp1)) cycle
7153 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7154         itori=itortyp(itype(i-2))
7155         itori1=itortyp(itype(i-1))
7156         itori2=itortyp(itype(i))
7157         phii=phi(i)
7158         phii1=phi(i+1)
7159         gloci1=0.0D0
7160         gloci2=0.0D0
7161         iblock=1
7162         if (iabs(itype(i+1)).eq.20) iblock=2
7163 C Iblock=2 Proline type
7164 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7165 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7166 C        if (itype(i+1).eq.ntyp1) iblock=3
7167 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7168 C IS or IS NOT need for this
7169 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7170 C        is (itype(i-3).eq.ntyp1) ntblock=2
7171 C        ntblock is N-terminal blocking group
7172
7173 C Regular cosine and sine terms
7174         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7175 C Example of changes for NH3+ blocking group
7176 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7177 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7178           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7179           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7180           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7181           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7182           cosphi1=dcos(j*phii)
7183           sinphi1=dsin(j*phii)
7184           cosphi2=dcos(j*phii1)
7185           sinphi2=dsin(j*phii1)
7186           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7187      &     v2cij*cosphi2+v2sij*sinphi2
7188           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7189           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7190         enddo
7191         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7192           do l=1,k-1
7193             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7194             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7195             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7196             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7197             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7198             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7199             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7200             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7201             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7202      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7203             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7204      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7205             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7206      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7207           enddo
7208         enddo
7209         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7210         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7211       enddo
7212       return
7213       end
7214 #endif
7215 c------------------------------------------------------------------------------
7216       subroutine eback_sc_corr(esccor)
7217 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7218 c        conformational states; temporarily implemented as differences
7219 c        between UNRES torsional potentials (dependent on three types of
7220 c        residues) and the torsional potentials dependent on all 20 types
7221 c        of residues computed from AM1  energy surfaces of terminally-blocked
7222 c        amino-acid residues.
7223       implicit real*8 (a-h,o-z)
7224       include 'DIMENSIONS'
7225       include 'COMMON.VAR'
7226       include 'COMMON.GEO'
7227       include 'COMMON.LOCAL'
7228       include 'COMMON.TORSION'
7229       include 'COMMON.SCCOR'
7230       include 'COMMON.INTERACT'
7231       include 'COMMON.DERIV'
7232       include 'COMMON.CHAIN'
7233       include 'COMMON.NAMES'
7234       include 'COMMON.IOUNITS'
7235       include 'COMMON.FFIELD'
7236       include 'COMMON.CONTROL'
7237       logical lprn
7238 C Set lprn=.true. for debugging
7239       lprn=.false.
7240 c      lprn=.true.
7241 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7242       esccor=0.0D0
7243       do i=itau_start,itau_end
7244         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7245         esccor_ii=0.0D0
7246         isccori=isccortyp(itype(i-2))
7247         isccori1=isccortyp(itype(i-1))
7248 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7249         phii=phi(i)
7250         do intertyp=1,3 !intertyp
7251 cc Added 09 May 2012 (Adasko)
7252 cc  Intertyp means interaction type of backbone mainchain correlation:
7253 c   1 = SC...Ca...Ca...Ca
7254 c   2 = Ca...Ca...Ca...SC
7255 c   3 = SC...Ca...Ca...SCi
7256         gloci=0.0D0
7257         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7258      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7259      &      (itype(i-1).eq.ntyp1)))
7260      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7261      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7262      &     .or.(itype(i).eq.ntyp1)))
7263      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7264      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7265      &      (itype(i-3).eq.ntyp1)))) cycle
7266         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7267         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7268      & cycle
7269        do j=1,nterm_sccor(isccori,isccori1)
7270           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7271           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7272           cosphi=dcos(j*tauangle(intertyp,i))
7273           sinphi=dsin(j*tauangle(intertyp,i))
7274           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7275           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7276         enddo
7277 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7278         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7279         if (lprn)
7280      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7281      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7282      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7283      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7284         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7285        enddo !intertyp
7286       enddo
7287
7288       return
7289       end
7290 c----------------------------------------------------------------------------
7291       subroutine multibody(ecorr)
7292 C This subroutine calculates multi-body contributions to energy following
7293 C the idea of Skolnick et al. If side chains I and J make a contact and
7294 C at the same time side chains I+1 and J+1 make a contact, an extra
7295 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7296       implicit real*8 (a-h,o-z)
7297       include 'DIMENSIONS'
7298       include 'COMMON.IOUNITS'
7299       include 'COMMON.DERIV'
7300       include 'COMMON.INTERACT'
7301       include 'COMMON.CONTACTS'
7302       double precision gx(3),gx1(3)
7303       logical lprn
7304
7305 C Set lprn=.true. for debugging
7306       lprn=.false.
7307
7308       if (lprn) then
7309         write (iout,'(a)') 'Contact function values:'
7310         do i=nnt,nct-2
7311           write (iout,'(i2,20(1x,i2,f10.5))')
7312      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7313         enddo
7314       endif
7315       ecorr=0.0D0
7316       do i=nnt,nct
7317         do j=1,3
7318           gradcorr(j,i)=0.0D0
7319           gradxorr(j,i)=0.0D0
7320         enddo
7321       enddo
7322       do i=nnt,nct-2
7323
7324         DO ISHIFT = 3,4
7325
7326         i1=i+ishift
7327         num_conti=num_cont(i)
7328         num_conti1=num_cont(i1)
7329         do jj=1,num_conti
7330           j=jcont(jj,i)
7331           do kk=1,num_conti1
7332             j1=jcont(kk,i1)
7333             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7334 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7335 cd   &                   ' ishift=',ishift
7336 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7337 C The system gains extra energy.
7338               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7339             endif   ! j1==j+-ishift
7340           enddo     ! kk
7341         enddo       ! jj
7342
7343         ENDDO ! ISHIFT
7344
7345       enddo         ! i
7346       return
7347       end
7348 c------------------------------------------------------------------------------
7349       double precision function esccorr(i,j,k,l,jj,kk)
7350       implicit real*8 (a-h,o-z)
7351       include 'DIMENSIONS'
7352       include 'COMMON.IOUNITS'
7353       include 'COMMON.DERIV'
7354       include 'COMMON.INTERACT'
7355       include 'COMMON.CONTACTS'
7356       double precision gx(3),gx1(3)
7357       logical lprn
7358       lprn=.false.
7359       eij=facont(jj,i)
7360       ekl=facont(kk,k)
7361 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7362 C Calculate the multi-body contribution to energy.
7363 C Calculate multi-body contributions to the gradient.
7364 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7365 cd   & k,l,(gacont(m,kk,k),m=1,3)
7366       do m=1,3
7367         gx(m) =ekl*gacont(m,jj,i)
7368         gx1(m)=eij*gacont(m,kk,k)
7369         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7370         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7371         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7372         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7373       enddo
7374       do m=i,j-1
7375         do ll=1,3
7376           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7377         enddo
7378       enddo
7379       do m=k,l-1
7380         do ll=1,3
7381           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7382         enddo
7383       enddo
7384       esccorr=-eij*ekl
7385       return
7386       end
7387 c------------------------------------------------------------------------------
7388       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7389 C This subroutine calculates multi-body contributions to hydrogen-bonding
7390       implicit real*8 (a-h,o-z)
7391       include 'DIMENSIONS'
7392       include 'COMMON.IOUNITS'
7393 #ifdef MPI
7394       include "mpif.h"
7395       parameter (max_cont=maxconts)
7396       parameter (max_dim=26)
7397       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7398       double precision zapas(max_dim,maxconts,max_fg_procs),
7399      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7400       common /przechowalnia/ zapas
7401       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7402      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7403 #endif
7404       include 'COMMON.SETUP'
7405       include 'COMMON.FFIELD'
7406       include 'COMMON.DERIV'
7407       include 'COMMON.INTERACT'
7408       include 'COMMON.CONTACTS'
7409       include 'COMMON.CONTROL'
7410       include 'COMMON.LOCAL'
7411       double precision gx(3),gx1(3),time00
7412       logical lprn,ldone
7413
7414 C Set lprn=.true. for debugging
7415       lprn=.false.
7416 #ifdef MPI
7417       n_corr=0
7418       n_corr1=0
7419       if (nfgtasks.le.1) goto 30
7420       if (lprn) then
7421         write (iout,'(a)') 'Contact function values before RECEIVE:'
7422         do i=nnt,nct-2
7423           write (iout,'(2i3,50(1x,i3,f5.2))')
7424      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7425      &    j=1,num_cont_hb(i))
7426         enddo
7427       endif
7428       call flush(iout)
7429       do i=1,ntask_cont_from
7430         ncont_recv(i)=0
7431       enddo
7432       do i=1,ntask_cont_to
7433         ncont_sent(i)=0
7434       enddo
7435 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7436 c     & ntask_cont_to
7437 C Make the list of contacts to send to send to other procesors
7438 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7439 c      call flush(iout)
7440       do i=iturn3_start,iturn3_end
7441 c        write (iout,*) "make contact list turn3",i," num_cont",
7442 c     &    num_cont_hb(i)
7443         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7444       enddo
7445       do i=iturn4_start,iturn4_end
7446 c        write (iout,*) "make contact list turn4",i," num_cont",
7447 c     &   num_cont_hb(i)
7448         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7449       enddo
7450       do ii=1,nat_sent
7451         i=iat_sent(ii)
7452 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7453 c     &    num_cont_hb(i)
7454         do j=1,num_cont_hb(i)
7455         do k=1,4
7456           jjc=jcont_hb(j,i)
7457           iproc=iint_sent_local(k,jjc,ii)
7458 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7459           if (iproc.gt.0) then
7460             ncont_sent(iproc)=ncont_sent(iproc)+1
7461             nn=ncont_sent(iproc)
7462             zapas(1,nn,iproc)=i
7463             zapas(2,nn,iproc)=jjc
7464             zapas(3,nn,iproc)=facont_hb(j,i)
7465             zapas(4,nn,iproc)=ees0p(j,i)
7466             zapas(5,nn,iproc)=ees0m(j,i)
7467             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7468             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7469             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7470             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7471             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7472             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7473             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7474             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7475             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7476             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7477             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7478             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7479             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7480             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7481             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7482             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7483             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7484             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7485             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7486             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7487             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7488           endif
7489         enddo
7490         enddo
7491       enddo
7492       if (lprn) then
7493       write (iout,*)
7494      &  "Numbers of contacts to be sent to other processors",
7495      &  (ncont_sent(i),i=1,ntask_cont_to)
7496       write (iout,*) "Contacts sent"
7497       do ii=1,ntask_cont_to
7498         nn=ncont_sent(ii)
7499         iproc=itask_cont_to(ii)
7500         write (iout,*) nn," contacts to processor",iproc,
7501      &   " of CONT_TO_COMM group"
7502         do i=1,nn
7503           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7504         enddo
7505       enddo
7506       call flush(iout)
7507       endif
7508       CorrelType=477
7509       CorrelID=fg_rank+1
7510       CorrelType1=478
7511       CorrelID1=nfgtasks+fg_rank+1
7512       ireq=0
7513 C Receive the numbers of needed contacts from other processors
7514       do ii=1,ntask_cont_from
7515         iproc=itask_cont_from(ii)
7516         ireq=ireq+1
7517         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7518      &    FG_COMM,req(ireq),IERR)
7519       enddo
7520 c      write (iout,*) "IRECV ended"
7521 c      call flush(iout)
7522 C Send the number of contacts needed by other processors
7523       do ii=1,ntask_cont_to
7524         iproc=itask_cont_to(ii)
7525         ireq=ireq+1
7526         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7527      &    FG_COMM,req(ireq),IERR)
7528       enddo
7529 c      write (iout,*) "ISEND ended"
7530 c      write (iout,*) "number of requests (nn)",ireq
7531       call flush(iout)
7532       if (ireq.gt.0)
7533      &  call MPI_Waitall(ireq,req,status_array,ierr)
7534 c      write (iout,*)
7535 c     &  "Numbers of contacts to be received from other processors",
7536 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7537 c      call flush(iout)
7538 C Receive contacts
7539       ireq=0
7540       do ii=1,ntask_cont_from
7541         iproc=itask_cont_from(ii)
7542         nn=ncont_recv(ii)
7543 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7544 c     &   " of CONT_TO_COMM group"
7545         call flush(iout)
7546         if (nn.gt.0) then
7547           ireq=ireq+1
7548           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7549      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7550 c          write (iout,*) "ireq,req",ireq,req(ireq)
7551         endif
7552       enddo
7553 C Send the contacts to processors that need them
7554       do ii=1,ntask_cont_to
7555         iproc=itask_cont_to(ii)
7556         nn=ncont_sent(ii)
7557 c        write (iout,*) nn," contacts to processor",iproc,
7558 c     &   " of CONT_TO_COMM group"
7559         if (nn.gt.0) then
7560           ireq=ireq+1
7561           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7562      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7563 c          write (iout,*) "ireq,req",ireq,req(ireq)
7564 c          do i=1,nn
7565 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7566 c          enddo
7567         endif
7568       enddo
7569 c      write (iout,*) "number of requests (contacts)",ireq
7570 c      write (iout,*) "req",(req(i),i=1,4)
7571 c      call flush(iout)
7572       if (ireq.gt.0)
7573      & call MPI_Waitall(ireq,req,status_array,ierr)
7574       do iii=1,ntask_cont_from
7575         iproc=itask_cont_from(iii)
7576         nn=ncont_recv(iii)
7577         if (lprn) then
7578         write (iout,*) "Received",nn," contacts from processor",iproc,
7579      &   " of CONT_FROM_COMM group"
7580         call flush(iout)
7581         do i=1,nn
7582           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7583         enddo
7584         call flush(iout)
7585         endif
7586         do i=1,nn
7587           ii=zapas_recv(1,i,iii)
7588 c Flag the received contacts to prevent double-counting
7589           jj=-zapas_recv(2,i,iii)
7590 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7591 c          call flush(iout)
7592           nnn=num_cont_hb(ii)+1
7593           num_cont_hb(ii)=nnn
7594           jcont_hb(nnn,ii)=jj
7595           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7596           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7597           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7598           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7599           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7600           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7601           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7602           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7603           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7604           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7605           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7606           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7607           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7608           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7609           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7610           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7611           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7612           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7613           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7614           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7615           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7616           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7617           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7618           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7619         enddo
7620       enddo
7621       call flush(iout)
7622       if (lprn) then
7623         write (iout,'(a)') 'Contact function values after receive:'
7624         do i=nnt,nct-2
7625           write (iout,'(2i3,50(1x,i3,f5.2))')
7626      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7627      &    j=1,num_cont_hb(i))
7628         enddo
7629         call flush(iout)
7630       endif
7631    30 continue
7632 #endif
7633       if (lprn) then
7634         write (iout,'(a)') 'Contact function values:'
7635         do i=nnt,nct-2
7636           write (iout,'(2i3,50(1x,i3,f5.2))')
7637      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7638      &    j=1,num_cont_hb(i))
7639         enddo
7640       endif
7641       ecorr=0.0D0
7642 C Remove the loop below after debugging !!!
7643       do i=nnt,nct
7644         do j=1,3
7645           gradcorr(j,i)=0.0D0
7646           gradxorr(j,i)=0.0D0
7647         enddo
7648       enddo
7649 C Calculate the local-electrostatic correlation terms
7650       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7651         i1=i+1
7652         num_conti=num_cont_hb(i)
7653         num_conti1=num_cont_hb(i+1)
7654         do jj=1,num_conti
7655           j=jcont_hb(jj,i)
7656           jp=iabs(j)
7657           do kk=1,num_conti1
7658             j1=jcont_hb(kk,i1)
7659             jp1=iabs(j1)
7660 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7661 c     &         ' jj=',jj,' kk=',kk
7662 c            call flush(iout)
7663             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7664      &          .or. j.lt.0 .and. j1.gt.0) .and.
7665      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7666 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7667 C The system gains extra energy.
7668               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7669               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7670      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7671               n_corr=n_corr+1
7672             else if (j1.eq.j) then
7673 C Contacts I-J and I-(J+1) occur simultaneously.
7674 C The system loses extra energy.
7675 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7676             endif
7677           enddo ! kk
7678           do kk=1,num_conti
7679             j1=jcont_hb(kk,i)
7680 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7681 c     &         ' jj=',jj,' kk=',kk
7682 c            call flush(iout)
7683             if (j1.eq.j+1) then
7684 C Contacts I-J and (I+1)-J occur simultaneously.
7685 C The system loses extra energy.
7686 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7687             endif ! j1==j+1
7688           enddo ! kk
7689         enddo ! jj
7690       enddo ! i
7691       return
7692       end
7693 c------------------------------------------------------------------------------
7694       subroutine add_hb_contact(ii,jj,itask)
7695       implicit real*8 (a-h,o-z)
7696       include "DIMENSIONS"
7697       include "COMMON.IOUNITS"
7698       integer max_cont
7699       integer max_dim
7700       parameter (max_cont=maxconts)
7701       parameter (max_dim=26)
7702       include "COMMON.CONTACTS"
7703       double precision zapas(max_dim,maxconts,max_fg_procs),
7704      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7705       common /przechowalnia/ zapas
7706       integer i,j,ii,jj,iproc,itask(4),nn
7707 c      write (iout,*) "itask",itask
7708       do i=1,2
7709         iproc=itask(i)
7710         if (iproc.gt.0) then
7711           do j=1,num_cont_hb(ii)
7712             jjc=jcont_hb(j,ii)
7713 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7714             if (jjc.eq.jj) then
7715               ncont_sent(iproc)=ncont_sent(iproc)+1
7716               nn=ncont_sent(iproc)
7717               zapas(1,nn,iproc)=ii
7718               zapas(2,nn,iproc)=jjc
7719               zapas(3,nn,iproc)=facont_hb(j,ii)
7720               zapas(4,nn,iproc)=ees0p(j,ii)
7721               zapas(5,nn,iproc)=ees0m(j,ii)
7722               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7723               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7724               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7725               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7726               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7727               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7728               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7729               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7730               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7731               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7732               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7733               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7734               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7735               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7736               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7737               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7738               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7739               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7740               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7741               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7742               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7743               exit
7744             endif
7745           enddo
7746         endif
7747       enddo
7748       return
7749       end
7750 c------------------------------------------------------------------------------
7751       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7752      &  n_corr1)
7753 C This subroutine calculates multi-body contributions to hydrogen-bonding
7754       implicit real*8 (a-h,o-z)
7755       include 'DIMENSIONS'
7756       include 'COMMON.IOUNITS'
7757 #ifdef MPI
7758       include "mpif.h"
7759       parameter (max_cont=maxconts)
7760       parameter (max_dim=70)
7761       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7762       double precision zapas(max_dim,maxconts,max_fg_procs),
7763      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7764       common /przechowalnia/ zapas
7765       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7766      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7767 #endif
7768       include 'COMMON.SETUP'
7769       include 'COMMON.FFIELD'
7770       include 'COMMON.DERIV'
7771       include 'COMMON.LOCAL'
7772       include 'COMMON.INTERACT'
7773       include 'COMMON.CONTACTS'
7774       include 'COMMON.CHAIN'
7775       include 'COMMON.CONTROL'
7776       include 'COMMON.TORSION'
7777       double precision gx(3),gx1(3)
7778       integer num_cont_hb_old(maxres)
7779       logical lprn,ldone
7780       double precision eello4,eello5,eelo6,eello_turn6
7781       external eello4,eello5,eello6,eello_turn6
7782 C Set lprn=.true. for debugging
7783       lprn=.false.
7784       eturn6=0.0d0
7785 c      write (iout,*) "MULTIBODY_EELLO"
7786 c      call flush(iout)
7787 #ifdef MPI
7788       do i=1,nres
7789         num_cont_hb_old(i)=num_cont_hb(i)
7790       enddo
7791       n_corr=0
7792       n_corr1=0
7793       if (nfgtasks.le.1) goto 30
7794       if (lprn) then
7795         write (iout,'(a)') 'Contact function values before RECEIVE:'
7796         do i=nnt,nct-2
7797           write (iout,'(2i3,50(1x,i3,f5.2))')
7798      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7799      &    j=1,num_cont_hb(i))
7800         enddo
7801         call flush(iout)
7802       endif
7803       do i=1,ntask_cont_from
7804         ncont_recv(i)=0
7805       enddo
7806       do i=1,ntask_cont_to
7807         ncont_sent(i)=0
7808       enddo
7809 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7810 c     & ntask_cont_to
7811 C Make the list of contacts to send to send to other procesors
7812       do i=iturn3_start,iturn3_end
7813 c        write (iout,*) "make contact list turn3",i," num_cont",
7814 c     &    num_cont_hb(i)
7815         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7816       enddo
7817       do i=iturn4_start,iturn4_end
7818 c        write (iout,*) "make contact list turn4",i," num_cont",
7819 c     &   num_cont_hb(i)
7820         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7821       enddo
7822       do ii=1,nat_sent
7823         i=iat_sent(ii)
7824 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7825 c     &    num_cont_hb(i)
7826         do j=1,num_cont_hb(i)
7827         do k=1,4
7828           jjc=jcont_hb(j,i)
7829           iproc=iint_sent_local(k,jjc,ii)
7830 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7831           if (iproc.ne.0) then
7832             ncont_sent(iproc)=ncont_sent(iproc)+1
7833             nn=ncont_sent(iproc)
7834             zapas(1,nn,iproc)=i
7835             zapas(2,nn,iproc)=jjc
7836             zapas(3,nn,iproc)=d_cont(j,i)
7837             ind=3
7838             do kk=1,3
7839               ind=ind+1
7840               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7841             enddo
7842             do kk=1,2
7843               do ll=1,2
7844                 ind=ind+1
7845                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7846               enddo
7847             enddo
7848             do jj=1,5
7849               do kk=1,3
7850                 do ll=1,2
7851                   do mm=1,2
7852                     ind=ind+1
7853                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7854                   enddo
7855                 enddo
7856               enddo
7857             enddo
7858           endif
7859         enddo
7860         enddo
7861       enddo
7862       if (lprn) then
7863       write (iout,*)
7864      &  "Numbers of contacts to be sent to other processors",
7865      &  (ncont_sent(i),i=1,ntask_cont_to)
7866       write (iout,*) "Contacts sent"
7867       do ii=1,ntask_cont_to
7868         nn=ncont_sent(ii)
7869         iproc=itask_cont_to(ii)
7870         write (iout,*) nn," contacts to processor",iproc,
7871      &   " of CONT_TO_COMM group"
7872         do i=1,nn
7873           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7874         enddo
7875       enddo
7876       call flush(iout)
7877       endif
7878       CorrelType=477
7879       CorrelID=fg_rank+1
7880       CorrelType1=478
7881       CorrelID1=nfgtasks+fg_rank+1
7882       ireq=0
7883 C Receive the numbers of needed contacts from other processors
7884       do ii=1,ntask_cont_from
7885         iproc=itask_cont_from(ii)
7886         ireq=ireq+1
7887         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7888      &    FG_COMM,req(ireq),IERR)
7889       enddo
7890 c      write (iout,*) "IRECV ended"
7891 c      call flush(iout)
7892 C Send the number of contacts needed by other processors
7893       do ii=1,ntask_cont_to
7894         iproc=itask_cont_to(ii)
7895         ireq=ireq+1
7896         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7897      &    FG_COMM,req(ireq),IERR)
7898       enddo
7899 c      write (iout,*) "ISEND ended"
7900 c      write (iout,*) "number of requests (nn)",ireq
7901       call flush(iout)
7902       if (ireq.gt.0)
7903      &  call MPI_Waitall(ireq,req,status_array,ierr)
7904 c      write (iout,*)
7905 c     &  "Numbers of contacts to be received from other processors",
7906 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7907 c      call flush(iout)
7908 C Receive contacts
7909       ireq=0
7910       do ii=1,ntask_cont_from
7911         iproc=itask_cont_from(ii)
7912         nn=ncont_recv(ii)
7913 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7914 c     &   " of CONT_TO_COMM group"
7915         call flush(iout)
7916         if (nn.gt.0) then
7917           ireq=ireq+1
7918           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7919      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7920 c          write (iout,*) "ireq,req",ireq,req(ireq)
7921         endif
7922       enddo
7923 C Send the contacts to processors that need them
7924       do ii=1,ntask_cont_to
7925         iproc=itask_cont_to(ii)
7926         nn=ncont_sent(ii)
7927 c        write (iout,*) nn," contacts to processor",iproc,
7928 c     &   " of CONT_TO_COMM group"
7929         if (nn.gt.0) then
7930           ireq=ireq+1
7931           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7932      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7933 c          write (iout,*) "ireq,req",ireq,req(ireq)
7934 c          do i=1,nn
7935 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7936 c          enddo
7937         endif
7938       enddo
7939 c      write (iout,*) "number of requests (contacts)",ireq
7940 c      write (iout,*) "req",(req(i),i=1,4)
7941 c      call flush(iout)
7942       if (ireq.gt.0)
7943      & call MPI_Waitall(ireq,req,status_array,ierr)
7944       do iii=1,ntask_cont_from
7945         iproc=itask_cont_from(iii)
7946         nn=ncont_recv(iii)
7947         if (lprn) then
7948         write (iout,*) "Received",nn," contacts from processor",iproc,
7949      &   " of CONT_FROM_COMM group"
7950         call flush(iout)
7951         do i=1,nn
7952           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7953         enddo
7954         call flush(iout)
7955         endif
7956         do i=1,nn
7957           ii=zapas_recv(1,i,iii)
7958 c Flag the received contacts to prevent double-counting
7959           jj=-zapas_recv(2,i,iii)
7960 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7961 c          call flush(iout)
7962           nnn=num_cont_hb(ii)+1
7963           num_cont_hb(ii)=nnn
7964           jcont_hb(nnn,ii)=jj
7965           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7966           ind=3
7967           do kk=1,3
7968             ind=ind+1
7969             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7970           enddo
7971           do kk=1,2
7972             do ll=1,2
7973               ind=ind+1
7974               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7975             enddo
7976           enddo
7977           do jj=1,5
7978             do kk=1,3
7979               do ll=1,2
7980                 do mm=1,2
7981                   ind=ind+1
7982                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7983                 enddo
7984               enddo
7985             enddo
7986           enddo
7987         enddo
7988       enddo
7989       call flush(iout)
7990       if (lprn) then
7991         write (iout,'(a)') 'Contact function values after receive:'
7992         do i=nnt,nct-2
7993           write (iout,'(2i3,50(1x,i3,5f6.3))')
7994      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7995      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7996         enddo
7997         call flush(iout)
7998       endif
7999    30 continue
8000 #endif
8001       if (lprn) then
8002         write (iout,'(a)') 'Contact function values:'
8003         do i=nnt,nct-2
8004           write (iout,'(2i3,50(1x,i3,5f6.3))')
8005      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8006      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8007         enddo
8008         write (iout,*) "itortyp"
8009         do i=1,nres
8010           write (iout,*) i,itype(i),itortyp(itype(i))
8011         enddo
8012         call flush(iout)
8013       endif
8014       ecorr=0.0D0
8015       ecorr5=0.0d0
8016       ecorr6=0.0d0
8017 C Remove the loop below after debugging !!!
8018       do i=nnt,nct
8019         do j=1,3
8020           gradcorr(j,i)=0.0D0
8021           gradxorr(j,i)=0.0D0
8022         enddo
8023       enddo
8024 C Calculate the dipole-dipole interaction energies
8025       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8026       do i=iatel_s,iatel_e+1
8027         num_conti=num_cont_hb(i)
8028         do jj=1,num_conti
8029           j=jcont_hb(jj,i)
8030 #ifdef MOMENT
8031           call dipole(i,j,jj)
8032 #endif
8033         enddo
8034       enddo
8035       endif
8036 C Calculate the local-electrostatic correlation terms
8037 c                write (iout,*) "gradcorr5 in eello5 before loop"
8038 c                do iii=1,nres
8039 c                  write (iout,'(i5,3f10.5)')
8040 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8041 c                enddo
8042       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8043 c        write (iout,*) "corr loop i",i
8044         i1=i+1
8045         num_conti=num_cont_hb(i)
8046         num_conti1=num_cont_hb(i+1)
8047         do jj=1,num_conti
8048           j=jcont_hb(jj,i)
8049           jp=iabs(j)
8050           do kk=1,num_conti1
8051             j1=jcont_hb(kk,i1)
8052             jp1=iabs(j1)
8053             if (lprn) then
8054               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8055      &         ' jj=',jj,' kk=',kk
8056               call flush(iout)
8057             endif
8058 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8059             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8060      &          .or. j.lt.0 .and. j1.gt.0) .and.
8061      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8062 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8063 C The system gains extra energy.
8064               n_corr=n_corr+1
8065               sqd1=dsqrt(d_cont(jj,i))
8066               sqd2=dsqrt(d_cont(kk,i1))
8067               sred_geom = sqd1*sqd2
8068               IF (sred_geom.lt.cutoff_corr) THEN
8069                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8070      &            ekont,fprimcont)
8071 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8072 cd     &         ' jj=',jj,' kk=',kk
8073                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8074                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8075                 do l=1,3
8076                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8077                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8078                 enddo
8079                 n_corr1=n_corr1+1
8080 cd               write (iout,*) 'sred_geom=',sred_geom,
8081 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8082 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8083 cd               write (iout,*) "g_contij",g_contij
8084 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8085 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8086                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8087                 if (wcorr4.gt.0.0d0)
8088      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8089                   if (energy_dec.and.wcorr4.gt.0.0d0)
8090      1                 write (iout,'(a6,4i5,0pf7.3)')
8091      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8092 c                write (iout,*) "gradcorr5 before eello5"
8093 c                do iii=1,nres
8094 c                  write (iout,'(i5,3f10.5)')
8095 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8096 c                enddo
8097 c                write (iout,*) "ecorr4"
8098 c                call flush(iout)
8099 c                write (iout,*) "eello5:",i,jp,i+1,jp1,jj,kk,
8100 c     &        itype(jp),itype(i+1),itype(jp1),
8101 c     &        itortyp(itype(jp)),itortyp(itype(i+1)),itortyp(itype(jp1))
8102 c                call flush(iout)
8103                 if (wcorr5.gt.0.0d0)
8104      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8105 c                write (iout,*) "gradcorr5 after eello5"
8106 c                do iii=1,nres
8107 c                  write (iout,'(i5,3f10.5)')
8108 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8109 c                enddo
8110                   if (energy_dec.and.wcorr5.gt.0.0d0)
8111      1                 write (iout,'(a6,4i5,0pf7.3)')
8112      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8113 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8114 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8115 c                write (iout,*) "ecorr5"
8116 c                call flush(iout)
8117                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8118      &               .or. wturn6.eq.0.0d0))then
8119 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8120                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8121                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8122      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8123 c                write (iout,*) "ecorr6"
8124 c                call flush(iout)
8125 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8126 cd     &            'ecorr6=',ecorr6
8127 cd                write (iout,'(4e15.5)') sred_geom,
8128 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8129 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8130 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8131                 else if (wturn6.gt.0.0d0
8132      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8133 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8134                   eturn6=eturn6+eello_turn6(i,jj,kk)
8135                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8136      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8137 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8138 c                write (iout,*) "ecorr4"
8139 c                call flush(iout)
8140                 endif
8141               ENDIF
8142 1111          continue
8143             endif
8144                   if (energy_dec) call flush(iout)
8145           enddo ! kk
8146         enddo ! jj
8147       enddo ! i
8148       do i=1,nres
8149         num_cont_hb(i)=num_cont_hb_old(i)
8150       enddo
8151 c                write (iout,*) "gradcorr5 in eello5"
8152 c                do iii=1,nres
8153 c                  write (iout,'(i5,3f10.5)')
8154 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8155 c                enddo
8156       return
8157       end
8158 c------------------------------------------------------------------------------
8159       subroutine add_hb_contact_eello(ii,jj,itask)
8160       implicit real*8 (a-h,o-z)
8161       include "DIMENSIONS"
8162       include "COMMON.IOUNITS"
8163       integer max_cont
8164       integer max_dim
8165       parameter (max_cont=maxconts)
8166       parameter (max_dim=70)
8167       include "COMMON.CONTACTS"
8168       double precision zapas(max_dim,maxconts,max_fg_procs),
8169      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8170       common /przechowalnia/ zapas
8171       integer i,j,ii,jj,iproc,itask(4),nn
8172 c      write (iout,*) "itask",itask
8173       do i=1,2
8174         iproc=itask(i)
8175         if (iproc.gt.0) then
8176           do j=1,num_cont_hb(ii)
8177             jjc=jcont_hb(j,ii)
8178 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8179             if (jjc.eq.jj) then
8180               ncont_sent(iproc)=ncont_sent(iproc)+1
8181               nn=ncont_sent(iproc)
8182               zapas(1,nn,iproc)=ii
8183               zapas(2,nn,iproc)=jjc
8184               zapas(3,nn,iproc)=d_cont(j,ii)
8185               ind=3
8186               do kk=1,3
8187                 ind=ind+1
8188                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8189               enddo
8190               do kk=1,2
8191                 do ll=1,2
8192                   ind=ind+1
8193                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8194                 enddo
8195               enddo
8196               do jj=1,5
8197                 do kk=1,3
8198                   do ll=1,2
8199                     do mm=1,2
8200                       ind=ind+1
8201                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8202                     enddo
8203                   enddo
8204                 enddo
8205               enddo
8206               exit
8207             endif
8208           enddo
8209         endif
8210       enddo
8211       return
8212       end
8213 c------------------------------------------------------------------------------
8214       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8215       implicit real*8 (a-h,o-z)
8216       include 'DIMENSIONS'
8217       include 'COMMON.IOUNITS'
8218       include 'COMMON.DERIV'
8219       include 'COMMON.INTERACT'
8220       include 'COMMON.CONTACTS'
8221       double precision gx(3),gx1(3)
8222       logical lprn
8223       lprn=.false.
8224       eij=facont_hb(jj,i)
8225       ekl=facont_hb(kk,k)
8226       ees0pij=ees0p(jj,i)
8227       ees0pkl=ees0p(kk,k)
8228       ees0mij=ees0m(jj,i)
8229       ees0mkl=ees0m(kk,k)
8230       ekont=eij*ekl
8231       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8232 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8233 C Following 4 lines for diagnostics.
8234 cd    ees0pkl=0.0D0
8235 cd    ees0pij=1.0D0
8236 cd    ees0mkl=0.0D0
8237 cd    ees0mij=1.0D0
8238 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8239 c     & 'Contacts ',i,j,
8240 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8241 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8242 c     & 'gradcorr_long'
8243 C Calculate the multi-body contribution to energy.
8244 c      ecorr=ecorr+ekont*ees
8245 C Calculate multi-body contributions to the gradient.
8246       coeffpees0pij=coeffp*ees0pij
8247       coeffmees0mij=coeffm*ees0mij
8248       coeffpees0pkl=coeffp*ees0pkl
8249       coeffmees0mkl=coeffm*ees0mkl
8250       do ll=1,3
8251 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8252         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8253      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8254      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8255         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8256      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8257      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8258 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8259         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8260      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8261      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8262         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8263      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8264      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8265         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8266      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8267      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8268         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8269         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8270         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8271      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8272      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8273         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8274         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8275 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8276       enddo
8277 c      write (iout,*)
8278 cgrad      do m=i+1,j-1
8279 cgrad        do ll=1,3
8280 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8281 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8282 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8283 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8284 cgrad        enddo
8285 cgrad      enddo
8286 cgrad      do m=k+1,l-1
8287 cgrad        do ll=1,3
8288 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8289 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8290 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8291 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8292 cgrad        enddo
8293 cgrad      enddo
8294 c      write (iout,*) "ehbcorr",ekont*ees
8295       ehbcorr=ekont*ees
8296       return
8297       end
8298 #ifdef MOMENT
8299 C---------------------------------------------------------------------------
8300       subroutine dipole(i,j,jj)
8301       implicit real*8 (a-h,o-z)
8302       include 'DIMENSIONS'
8303       include 'COMMON.IOUNITS'
8304       include 'COMMON.CHAIN'
8305       include 'COMMON.FFIELD'
8306       include 'COMMON.DERIV'
8307       include 'COMMON.INTERACT'
8308       include 'COMMON.CONTACTS'
8309       include 'COMMON.TORSION'
8310       include 'COMMON.VAR'
8311       include 'COMMON.GEO'
8312       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8313      &  auxmat(2,2)
8314       iti1 = itortyp(itype(i+1))
8315       if (j.lt.nres-1) then
8316         itj1 = itortyp(itype(j+1))
8317       else
8318         itj1=ntortyp
8319       endif
8320       do iii=1,2
8321         dipi(iii,1)=Ub2(iii,i)
8322         dipderi(iii)=Ub2der(iii,i)
8323         dipi(iii,2)=b1(iii,i+1)
8324         dipj(iii,1)=Ub2(iii,j)
8325         dipderj(iii)=Ub2der(iii,j)
8326         dipj(iii,2)=b1(iii,j+1)
8327       enddo
8328       kkk=0
8329       do iii=1,2
8330         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8331         do jjj=1,2
8332           kkk=kkk+1
8333           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8334         enddo
8335       enddo
8336       do kkk=1,5
8337         do lll=1,3
8338           mmm=0
8339           do iii=1,2
8340             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8341      &        auxvec(1))
8342             do jjj=1,2
8343               mmm=mmm+1
8344               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8345             enddo
8346           enddo
8347         enddo
8348       enddo
8349       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8350       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8351       do iii=1,2
8352         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8353       enddo
8354       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8355       do iii=1,2
8356         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8357       enddo
8358       return
8359       end
8360 #endif
8361 C---------------------------------------------------------------------------
8362       subroutine calc_eello(i,j,k,l,jj,kk)
8363 C
8364 C This subroutine computes matrices and vectors needed to calculate
8365 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8366 C
8367       implicit real*8 (a-h,o-z)
8368       include 'DIMENSIONS'
8369       include 'COMMON.IOUNITS'
8370       include 'COMMON.CHAIN'
8371       include 'COMMON.DERIV'
8372       include 'COMMON.INTERACT'
8373       include 'COMMON.CONTACTS'
8374       include 'COMMON.TORSION'
8375       include 'COMMON.VAR'
8376       include 'COMMON.GEO'
8377       include 'COMMON.FFIELD'
8378       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8379      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8380       logical lprn
8381       common /kutas/ lprn
8382 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8383 cd     & ' jj=',jj,' kk=',kk
8384 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8385 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8386 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8387       do iii=1,2
8388         do jjj=1,2
8389           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8390           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8391         enddo
8392       enddo
8393       call transpose2(aa1(1,1),aa1t(1,1))
8394       call transpose2(aa2(1,1),aa2t(1,1))
8395       do kkk=1,5
8396         do lll=1,3
8397           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8398      &      aa1tder(1,1,lll,kkk))
8399           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8400      &      aa2tder(1,1,lll,kkk))
8401         enddo
8402       enddo
8403       if (l.eq.j+1) then
8404 C parallel orientation of the two CA-CA-CA frames.
8405         if (i.gt.1) then
8406           iti=itortyp(itype(i))
8407         else
8408           iti=ntortyp
8409         endif
8410         itk1=itortyp(itype(k+1))
8411         itj=itortyp(itype(j))
8412         if (l.lt.nres-1) then
8413           itl1=itortyp(itype(l+1))
8414         else
8415           itl1=ntortyp
8416         endif
8417 C A1 kernel(j+1) A2T
8418 cd        do iii=1,2
8419 cd          write (iout,'(3f10.5,5x,3f10.5)')
8420 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8421 cd        enddo
8422         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8423      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8424      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8425 C Following matrices are needed only for 6-th order cumulants
8426         IF (wcorr6.gt.0.0d0) THEN
8427         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8428      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8429      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8430         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8431      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8432      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8433      &   ADtEAderx(1,1,1,1,1,1))
8434         lprn=.false.
8435         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8436      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8437      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8438      &   ADtEA1derx(1,1,1,1,1,1))
8439         ENDIF
8440 C End 6-th order cumulants
8441 cd        lprn=.false.
8442 cd        if (lprn) then
8443 cd        write (2,*) 'In calc_eello6'
8444 cd        do iii=1,2
8445 cd          write (2,*) 'iii=',iii
8446 cd          do kkk=1,5
8447 cd            write (2,*) 'kkk=',kkk
8448 cd            do jjj=1,2
8449 cd              write (2,'(3(2f10.5),5x)')
8450 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8451 cd            enddo
8452 cd          enddo
8453 cd        enddo
8454 cd        endif
8455         call transpose2(EUgder(1,1,k),auxmat(1,1))
8456         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8457         call transpose2(EUg(1,1,k),auxmat(1,1))
8458         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8459         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8460         do iii=1,2
8461           do kkk=1,5
8462             do lll=1,3
8463               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8464      &          EAEAderx(1,1,lll,kkk,iii,1))
8465             enddo
8466           enddo
8467         enddo
8468 C A1T kernel(i+1) A2
8469         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8470      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8471      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8472 C Following matrices are needed only for 6-th order cumulants
8473         IF (wcorr6.gt.0.0d0) THEN
8474         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8475      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8476      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8477         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8478      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8479      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8480      &   ADtEAderx(1,1,1,1,1,2))
8481         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8482      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8483      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8484      &   ADtEA1derx(1,1,1,1,1,2))
8485         ENDIF
8486 C End 6-th order cumulants
8487         call transpose2(EUgder(1,1,l),auxmat(1,1))
8488         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8489         call transpose2(EUg(1,1,l),auxmat(1,1))
8490         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8491         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8492         do iii=1,2
8493           do kkk=1,5
8494             do lll=1,3
8495               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8496      &          EAEAderx(1,1,lll,kkk,iii,2))
8497             enddo
8498           enddo
8499         enddo
8500 C AEAb1 and AEAb2
8501 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8502 C They are needed only when the fifth- or the sixth-order cumulants are
8503 C indluded.
8504         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8505         call transpose2(AEA(1,1,1),auxmat(1,1))
8506         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8507         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8508         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8509         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8510         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8511         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8512         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8513         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8514         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8515         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8516         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8517         call transpose2(AEA(1,1,2),auxmat(1,1))
8518         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8519         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8520         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8521         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8522         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8523         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8524         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8525         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8526         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8527         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8528         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8529 C Calculate the Cartesian derivatives of the vectors.
8530         do iii=1,2
8531           do kkk=1,5
8532             do lll=1,3
8533               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8534               call matvec2(auxmat(1,1),b1(1,i),
8535      &          AEAb1derx(1,lll,kkk,iii,1,1))
8536               call matvec2(auxmat(1,1),Ub2(1,i),
8537      &          AEAb2derx(1,lll,kkk,iii,1,1))
8538               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8539      &          AEAb1derx(1,lll,kkk,iii,2,1))
8540               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8541      &          AEAb2derx(1,lll,kkk,iii,2,1))
8542               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8543               call matvec2(auxmat(1,1),b1(1,j),
8544      &          AEAb1derx(1,lll,kkk,iii,1,2))
8545               call matvec2(auxmat(1,1),Ub2(1,j),
8546      &          AEAb2derx(1,lll,kkk,iii,1,2))
8547               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8548      &          AEAb1derx(1,lll,kkk,iii,2,2))
8549               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8550      &          AEAb2derx(1,lll,kkk,iii,2,2))
8551             enddo
8552           enddo
8553         enddo
8554         ENDIF
8555 C End vectors
8556       else
8557 C Antiparallel orientation of the two CA-CA-CA frames.
8558         if (i.gt.1) then
8559           iti=itortyp(itype(i))
8560         else
8561           iti=ntortyp
8562         endif
8563         itk1=itortyp(itype(k+1))
8564         itl=itortyp(itype(l))
8565         itj=itortyp(itype(j))
8566         if (j.lt.nres-1) then
8567           itj1=itortyp(itype(j+1))
8568         else
8569           itj1=ntortyp
8570         endif
8571 C A2 kernel(j-1)T A1T
8572         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8573      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8574      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8575 C Following matrices are needed only for 6-th order cumulants
8576         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8577      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8578         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8579      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8580      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8581         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8582      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8583      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8584      &   ADtEAderx(1,1,1,1,1,1))
8585         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8586      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8587      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8588      &   ADtEA1derx(1,1,1,1,1,1))
8589         ENDIF
8590 C End 6-th order cumulants
8591         call transpose2(EUgder(1,1,k),auxmat(1,1))
8592         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8593         call transpose2(EUg(1,1,k),auxmat(1,1))
8594         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8595         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8596         do iii=1,2
8597           do kkk=1,5
8598             do lll=1,3
8599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8600      &          EAEAderx(1,1,lll,kkk,iii,1))
8601             enddo
8602           enddo
8603         enddo
8604 C A2T kernel(i+1)T A1
8605         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8606      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8607      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8608 C Following matrices are needed only for 6-th order cumulants
8609         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8610      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8611         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8612      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8613      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8614         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8615      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8616      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8617      &   ADtEAderx(1,1,1,1,1,2))
8618         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8619      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8620      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8621      &   ADtEA1derx(1,1,1,1,1,2))
8622         ENDIF
8623 C End 6-th order cumulants
8624         call transpose2(EUgder(1,1,j),auxmat(1,1))
8625         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8626         call transpose2(EUg(1,1,j),auxmat(1,1))
8627         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8628         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8629         do iii=1,2
8630           do kkk=1,5
8631             do lll=1,3
8632               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8633      &          EAEAderx(1,1,lll,kkk,iii,2))
8634             enddo
8635           enddo
8636         enddo
8637 C AEAb1 and AEAb2
8638 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8639 C They are needed only when the fifth- or the sixth-order cumulants are
8640 C indluded.
8641         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8642      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8643         call transpose2(AEA(1,1,1),auxmat(1,1))
8644         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8645         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8646         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8647         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8648         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8649         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8650         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8651         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8652         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8653         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8654         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8655         call transpose2(AEA(1,1,2),auxmat(1,1))
8656         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8657         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8658         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8659         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8660         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8661         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8662         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8663         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8664         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8665         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8666         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8667 C Calculate the Cartesian derivatives of the vectors.
8668         do iii=1,2
8669           do kkk=1,5
8670             do lll=1,3
8671               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8672               call matvec2(auxmat(1,1),b1(1,i),
8673      &          AEAb1derx(1,lll,kkk,iii,1,1))
8674               call matvec2(auxmat(1,1),Ub2(1,i),
8675      &          AEAb2derx(1,lll,kkk,iii,1,1))
8676               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8677      &          AEAb1derx(1,lll,kkk,iii,2,1))
8678               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8679      &          AEAb2derx(1,lll,kkk,iii,2,1))
8680               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8681               call matvec2(auxmat(1,1),b1(1,l),
8682      &          AEAb1derx(1,lll,kkk,iii,1,2))
8683               call matvec2(auxmat(1,1),Ub2(1,l),
8684      &          AEAb2derx(1,lll,kkk,iii,1,2))
8685               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8686      &          AEAb1derx(1,lll,kkk,iii,2,2))
8687               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8688      &          AEAb2derx(1,lll,kkk,iii,2,2))
8689             enddo
8690           enddo
8691         enddo
8692         ENDIF
8693 C End vectors
8694       endif
8695       return
8696       end
8697 C---------------------------------------------------------------------------
8698       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8699      &  KK,KKderg,AKA,AKAderg,AKAderx)
8700       implicit none
8701       integer nderg
8702       logical transp
8703       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8704      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8705      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8706       integer iii,kkk,lll
8707       integer jjj,mmm
8708       logical lprn
8709       common /kutas/ lprn
8710       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8711       do iii=1,nderg
8712         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8713      &    AKAderg(1,1,iii))
8714       enddo
8715 cd      if (lprn) write (2,*) 'In kernel'
8716       do kkk=1,5
8717 cd        if (lprn) write (2,*) 'kkk=',kkk
8718         do lll=1,3
8719           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8720      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8721 cd          if (lprn) then
8722 cd            write (2,*) 'lll=',lll
8723 cd            write (2,*) 'iii=1'
8724 cd            do jjj=1,2
8725 cd              write (2,'(3(2f10.5),5x)')
8726 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8727 cd            enddo
8728 cd          endif
8729           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8730      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8731 cd          if (lprn) then
8732 cd            write (2,*) 'lll=',lll
8733 cd            write (2,*) 'iii=2'
8734 cd            do jjj=1,2
8735 cd              write (2,'(3(2f10.5),5x)')
8736 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8737 cd            enddo
8738 cd          endif
8739         enddo
8740       enddo
8741       return
8742       end
8743 C---------------------------------------------------------------------------
8744       double precision function eello4(i,j,k,l,jj,kk)
8745       implicit real*8 (a-h,o-z)
8746       include 'DIMENSIONS'
8747       include 'COMMON.IOUNITS'
8748       include 'COMMON.CHAIN'
8749       include 'COMMON.DERIV'
8750       include 'COMMON.INTERACT'
8751       include 'COMMON.CONTACTS'
8752       include 'COMMON.TORSION'
8753       include 'COMMON.VAR'
8754       include 'COMMON.GEO'
8755       double precision pizda(2,2),ggg1(3),ggg2(3)
8756 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8757 cd        eello4=0.0d0
8758 cd        return
8759 cd      endif
8760 cd      print *,'eello4:',i,j,k,l,jj,kk
8761 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8762 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8763 cold      eij=facont_hb(jj,i)
8764 cold      ekl=facont_hb(kk,k)
8765 cold      ekont=eij*ekl
8766       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8767 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8768       gcorr_loc(k-1)=gcorr_loc(k-1)
8769      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8770       if (l.eq.j+1) then
8771         gcorr_loc(l-1)=gcorr_loc(l-1)
8772      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8773       else
8774         gcorr_loc(j-1)=gcorr_loc(j-1)
8775      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8776       endif
8777       do iii=1,2
8778         do kkk=1,5
8779           do lll=1,3
8780             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8781      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8782 cd            derx(lll,kkk,iii)=0.0d0
8783           enddo
8784         enddo
8785       enddo
8786 cd      gcorr_loc(l-1)=0.0d0
8787 cd      gcorr_loc(j-1)=0.0d0
8788 cd      gcorr_loc(k-1)=0.0d0
8789 cd      eel4=1.0d0
8790 cd      write (iout,*)'Contacts have occurred for peptide groups',
8791 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8792 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8793       if (j.lt.nres-1) then
8794         j1=j+1
8795         j2=j-1
8796       else
8797         j1=j-1
8798         j2=j-2
8799       endif
8800       if (l.lt.nres-1) then
8801         l1=l+1
8802         l2=l-1
8803       else
8804         l1=l-1
8805         l2=l-2
8806       endif
8807       do ll=1,3
8808 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8809 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8810         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8811         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8812 cgrad        ghalf=0.5d0*ggg1(ll)
8813         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8814         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8815         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8816         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8817         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8818         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8819 cgrad        ghalf=0.5d0*ggg2(ll)
8820         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8821         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8822         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8823         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8824         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8825         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8826       enddo
8827 cgrad      do m=i+1,j-1
8828 cgrad        do ll=1,3
8829 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8830 cgrad        enddo
8831 cgrad      enddo
8832 cgrad      do m=k+1,l-1
8833 cgrad        do ll=1,3
8834 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8835 cgrad        enddo
8836 cgrad      enddo
8837 cgrad      do m=i+2,j2
8838 cgrad        do ll=1,3
8839 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8840 cgrad        enddo
8841 cgrad      enddo
8842 cgrad      do m=k+2,l2
8843 cgrad        do ll=1,3
8844 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8845 cgrad        enddo
8846 cgrad      enddo
8847 cd      do iii=1,nres-3
8848 cd        write (2,*) iii,gcorr_loc(iii)
8849 cd      enddo
8850       eello4=ekont*eel4
8851 cd      write (2,*) 'ekont',ekont
8852 cd      write (iout,*) 'eello4',ekont*eel4
8853       return
8854       end
8855 C---------------------------------------------------------------------------
8856       double precision function eello5(i,j,k,l,jj,kk)
8857       implicit real*8 (a-h,o-z)
8858       include 'DIMENSIONS'
8859       include 'COMMON.IOUNITS'
8860       include 'COMMON.CHAIN'
8861       include 'COMMON.DERIV'
8862       include 'COMMON.INTERACT'
8863       include 'COMMON.CONTACTS'
8864       include 'COMMON.TORSION'
8865       include 'COMMON.VAR'
8866       include 'COMMON.GEO'
8867       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8868       double precision ggg1(3),ggg2(3)
8869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8870 C                                                                              C
8871 C                            Parallel chains                                   C
8872 C                                                                              C
8873 C          o             o                   o             o                   C
8874 C         /l\           / \             \   / \           / \   /              C
8875 C        /   \         /   \             \ /   \         /   \ /               C
8876 C       j| o |l1       | o |              o| o |         | o |o                C
8877 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8878 C      \i/   \         /   \ /             /   \         /   \                 C
8879 C       o    k1             o                                                  C
8880 C         (I)          (II)                (III)          (IV)                 C
8881 C                                                                              C
8882 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8883 C                                                                              C
8884 C                            Antiparallel chains                               C
8885 C                                                                              C
8886 C          o             o                   o             o                   C
8887 C         /j\           / \             \   / \           / \   /              C
8888 C        /   \         /   \             \ /   \         /   \ /               C
8889 C      j1| o |l        | o |              o| o |         | o |o                C
8890 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8891 C      \i/   \         /   \ /             /   \         /   \                 C
8892 C       o     k1            o                                                  C
8893 C         (I)          (II)                (III)          (IV)                 C
8894 C                                                                              C
8895 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8896 C                                                                              C
8897 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8898 C                                                                              C
8899 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8900 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8901 cd        eello5=0.0d0
8902 cd        return
8903 cd      endif
8904 cd      write (iout,*)
8905 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8906 cd     &   ' and',k,l
8907 c      itk=itortyp(itype(k))
8908 c      itl=itortyp(itype(l))
8909 c      itj=itortyp(itype(j))
8910       eello5_1=0.0d0
8911       eello5_2=0.0d0
8912       eello5_3=0.0d0
8913       eello5_4=0.0d0
8914 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8915 cd     &   eel5_3_num,eel5_4_num)
8916       do iii=1,2
8917         do kkk=1,5
8918           do lll=1,3
8919             derx(lll,kkk,iii)=0.0d0
8920           enddo
8921         enddo
8922       enddo
8923 cd      eij=facont_hb(jj,i)
8924 cd      ekl=facont_hb(kk,k)
8925 cd      ekont=eij*ekl
8926 cd      write (iout,*)'Contacts have occurred for peptide groups',
8927 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8928 cd      goto 1111
8929 C Contribution from the graph I.
8930 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8931 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8932       call transpose2(EUg(1,1,k),auxmat(1,1))
8933       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8934       vv(1)=pizda(1,1)-pizda(2,2)
8935       vv(2)=pizda(1,2)+pizda(2,1)
8936       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8937      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8938 C Explicit gradient in virtual-dihedral angles.
8939       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8940      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8941      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8942       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8943       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8944       vv(1)=pizda(1,1)-pizda(2,2)
8945       vv(2)=pizda(1,2)+pizda(2,1)
8946       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8947      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8948      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8949       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8950       vv(1)=pizda(1,1)-pizda(2,2)
8951       vv(2)=pizda(1,2)+pizda(2,1)
8952       if (l.eq.j+1) then
8953         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8954      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8955      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8956       else
8957         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8958      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8959      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8960       endif
8961 C Cartesian gradient
8962       do iii=1,2
8963         do kkk=1,5
8964           do lll=1,3
8965             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8966      &        pizda(1,1))
8967             vv(1)=pizda(1,1)-pizda(2,2)
8968             vv(2)=pizda(1,2)+pizda(2,1)
8969             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8970      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8971      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8972           enddo
8973         enddo
8974       enddo
8975 c      goto 1112
8976 c1111  continue
8977 C Contribution from graph II
8978       call transpose2(EE(1,1,k),auxmat(1,1))
8979       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8980       vv(1)=pizda(1,1)+pizda(2,2)
8981       vv(2)=pizda(2,1)-pizda(1,2)
8982       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8983      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8984 C Explicit gradient in virtual-dihedral angles.
8985       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8986      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8987       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8988       vv(1)=pizda(1,1)+pizda(2,2)
8989       vv(2)=pizda(2,1)-pizda(1,2)
8990       if (l.eq.j+1) then
8991         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8992      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8993      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8994       else
8995         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8996      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8997      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8998       endif
8999 C Cartesian gradient
9000       do iii=1,2
9001         do kkk=1,5
9002           do lll=1,3
9003             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9004      &        pizda(1,1))
9005             vv(1)=pizda(1,1)+pizda(2,2)
9006             vv(2)=pizda(2,1)-pizda(1,2)
9007             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9008      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9009      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9010           enddo
9011         enddo
9012       enddo
9013 cd      goto 1112
9014 cd1111  continue
9015       if (l.eq.j+1) then
9016 cd        goto 1110
9017 C Parallel orientation
9018 C Contribution from graph III
9019         call transpose2(EUg(1,1,l),auxmat(1,1))
9020         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9021         vv(1)=pizda(1,1)-pizda(2,2)
9022         vv(2)=pizda(1,2)+pizda(2,1)
9023         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9024      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9025 C Explicit gradient in virtual-dihedral angles.
9026         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9027      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9028      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9029         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9030         vv(1)=pizda(1,1)-pizda(2,2)
9031         vv(2)=pizda(1,2)+pizda(2,1)
9032         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9033      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9034      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9035         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9036         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9037         vv(1)=pizda(1,1)-pizda(2,2)
9038         vv(2)=pizda(1,2)+pizda(2,1)
9039         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9040      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9041      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9042 C Cartesian gradient
9043         do iii=1,2
9044           do kkk=1,5
9045             do lll=1,3
9046               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9047      &          pizda(1,1))
9048               vv(1)=pizda(1,1)-pizda(2,2)
9049               vv(2)=pizda(1,2)+pizda(2,1)
9050               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9051      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9052      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9053             enddo
9054           enddo
9055         enddo
9056 cd        goto 1112
9057 C Contribution from graph IV
9058 cd1110    continue
9059         call transpose2(EE(1,1,l),auxmat(1,1))
9060         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9061         vv(1)=pizda(1,1)+pizda(2,2)
9062         vv(2)=pizda(2,1)-pizda(1,2)
9063         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9064      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9065 C Explicit gradient in virtual-dihedral angles.
9066         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9067      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9068         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9069         vv(1)=pizda(1,1)+pizda(2,2)
9070         vv(2)=pizda(2,1)-pizda(1,2)
9071         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9072      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9073      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9074 C Cartesian gradient
9075         do iii=1,2
9076           do kkk=1,5
9077             do lll=1,3
9078               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9079      &          pizda(1,1))
9080               vv(1)=pizda(1,1)+pizda(2,2)
9081               vv(2)=pizda(2,1)-pizda(1,2)
9082               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9083      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9084      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9085             enddo
9086           enddo
9087         enddo
9088       else
9089 C Antiparallel orientation
9090 C Contribution from graph III
9091 c        goto 1110
9092         call transpose2(EUg(1,1,j),auxmat(1,1))
9093         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9094         vv(1)=pizda(1,1)-pizda(2,2)
9095         vv(2)=pizda(1,2)+pizda(2,1)
9096         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9097      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9098 C Explicit gradient in virtual-dihedral angles.
9099         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9100      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9101      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9102         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9103         vv(1)=pizda(1,1)-pizda(2,2)
9104         vv(2)=pizda(1,2)+pizda(2,1)
9105         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9106      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9107      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9108         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9109         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9110         vv(1)=pizda(1,1)-pizda(2,2)
9111         vv(2)=pizda(1,2)+pizda(2,1)
9112         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9113      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9114      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9115 C Cartesian gradient
9116         do iii=1,2
9117           do kkk=1,5
9118             do lll=1,3
9119               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9120      &          pizda(1,1))
9121               vv(1)=pizda(1,1)-pizda(2,2)
9122               vv(2)=pizda(1,2)+pizda(2,1)
9123               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9124      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9125      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9126             enddo
9127           enddo
9128         enddo
9129 cd        goto 1112
9130 C Contribution from graph IV
9131 1110    continue
9132         call transpose2(EE(1,1,j),auxmat(1,1))
9133         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9134         vv(1)=pizda(1,1)+pizda(2,2)
9135         vv(2)=pizda(2,1)-pizda(1,2)
9136         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9137      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9138 C Explicit gradient in virtual-dihedral angles.
9139         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9140      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9141         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9142         vv(1)=pizda(1,1)+pizda(2,2)
9143         vv(2)=pizda(2,1)-pizda(1,2)
9144         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9145      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9146      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9147 C Cartesian gradient
9148         do iii=1,2
9149           do kkk=1,5
9150             do lll=1,3
9151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9152      &          pizda(1,1))
9153               vv(1)=pizda(1,1)+pizda(2,2)
9154               vv(2)=pizda(2,1)-pizda(1,2)
9155               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9156      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9157      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9158             enddo
9159           enddo
9160         enddo
9161       endif
9162 1112  continue
9163       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9164 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9165 cd        write (2,*) 'ijkl',i,j,k,l
9166 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9167 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9168 cd      endif
9169 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9170 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9171 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9172 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9173       if (j.lt.nres-1) then
9174         j1=j+1
9175         j2=j-1
9176       else
9177         j1=j-1
9178         j2=j-2
9179       endif
9180       if (l.lt.nres-1) then
9181         l1=l+1
9182         l2=l-1
9183       else
9184         l1=l-1
9185         l2=l-2
9186       endif
9187 cd      eij=1.0d0
9188 cd      ekl=1.0d0
9189 cd      ekont=1.0d0
9190 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9191 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9192 C        summed up outside the subrouine as for the other subroutines
9193 C        handling long-range interactions. The old code is commented out
9194 C        with "cgrad" to keep track of changes.
9195       do ll=1,3
9196 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9197 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9198         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9199         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9200 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9201 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9202 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9203 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9204 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9205 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9206 c     &   gradcorr5ij,
9207 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9208 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9209 cgrad        ghalf=0.5d0*ggg1(ll)
9210 cd        ghalf=0.0d0
9211         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9212         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9213         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9214         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9215         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9216         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9217 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9218 cgrad        ghalf=0.5d0*ggg2(ll)
9219 cd        ghalf=0.0d0
9220         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9221         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9222         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9223         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9224         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9225         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9226       enddo
9227 cd      goto 1112
9228 cgrad      do m=i+1,j-1
9229 cgrad        do ll=1,3
9230 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9231 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9232 cgrad        enddo
9233 cgrad      enddo
9234 cgrad      do m=k+1,l-1
9235 cgrad        do ll=1,3
9236 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9237 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9238 cgrad        enddo
9239 cgrad      enddo
9240 c1112  continue
9241 cgrad      do m=i+2,j2
9242 cgrad        do ll=1,3
9243 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9244 cgrad        enddo
9245 cgrad      enddo
9246 cgrad      do m=k+2,l2
9247 cgrad        do ll=1,3
9248 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9249 cgrad        enddo
9250 cgrad      enddo
9251 cd      do iii=1,nres-3
9252 cd        write (2,*) iii,g_corr5_loc(iii)
9253 cd      enddo
9254       eello5=ekont*eel5
9255 cd      write (2,*) 'ekont',ekont
9256 cd      write (iout,*) 'eello5',ekont*eel5
9257       return
9258       end
9259 c--------------------------------------------------------------------------
9260       double precision function eello6(i,j,k,l,jj,kk)
9261       implicit real*8 (a-h,o-z)
9262       include 'DIMENSIONS'
9263       include 'COMMON.IOUNITS'
9264       include 'COMMON.CHAIN'
9265       include 'COMMON.DERIV'
9266       include 'COMMON.INTERACT'
9267       include 'COMMON.CONTACTS'
9268       include 'COMMON.TORSION'
9269       include 'COMMON.VAR'
9270       include 'COMMON.GEO'
9271       include 'COMMON.FFIELD'
9272       double precision ggg1(3),ggg2(3)
9273 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9274 cd        eello6=0.0d0
9275 cd        return
9276 cd      endif
9277 cd      write (iout,*)
9278 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9279 cd     &   ' and',k,l
9280       eello6_1=0.0d0
9281       eello6_2=0.0d0
9282       eello6_3=0.0d0
9283       eello6_4=0.0d0
9284       eello6_5=0.0d0
9285       eello6_6=0.0d0
9286 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9287 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9288       do iii=1,2
9289         do kkk=1,5
9290           do lll=1,3
9291             derx(lll,kkk,iii)=0.0d0
9292           enddo
9293         enddo
9294       enddo
9295 cd      eij=facont_hb(jj,i)
9296 cd      ekl=facont_hb(kk,k)
9297 cd      ekont=eij*ekl
9298 cd      eij=1.0d0
9299 cd      ekl=1.0d0
9300 cd      ekont=1.0d0
9301       if (l.eq.j+1) then
9302         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9303         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9304         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9305         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9306         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9307         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9308       else
9309         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9310         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9311         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9312         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9313         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9314           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9315         else
9316           eello6_5=0.0d0
9317         endif
9318         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9319       endif
9320 C If turn contributions are considered, they will be handled separately.
9321       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9322 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9323 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9324 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9325 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9326 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9327 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9328 cd      goto 1112
9329       if (j.lt.nres-1) then
9330         j1=j+1
9331         j2=j-1
9332       else
9333         j1=j-1
9334         j2=j-2
9335       endif
9336       if (l.lt.nres-1) then
9337         l1=l+1
9338         l2=l-1
9339       else
9340         l1=l-1
9341         l2=l-2
9342       endif
9343       do ll=1,3
9344 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9345 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9346 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9347 cgrad        ghalf=0.5d0*ggg1(ll)
9348 cd        ghalf=0.0d0
9349         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9350         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9351         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9352         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9353         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9354         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9355         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9356         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9357 cgrad        ghalf=0.5d0*ggg2(ll)
9358 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9359 cd        ghalf=0.0d0
9360         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9361         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9362         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9363         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9364         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9365         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9366       enddo
9367 cd      goto 1112
9368 cgrad      do m=i+1,j-1
9369 cgrad        do ll=1,3
9370 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9371 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9372 cgrad        enddo
9373 cgrad      enddo
9374 cgrad      do m=k+1,l-1
9375 cgrad        do ll=1,3
9376 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9377 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9378 cgrad        enddo
9379 cgrad      enddo
9380 cgrad1112  continue
9381 cgrad      do m=i+2,j2
9382 cgrad        do ll=1,3
9383 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9384 cgrad        enddo
9385 cgrad      enddo
9386 cgrad      do m=k+2,l2
9387 cgrad        do ll=1,3
9388 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9389 cgrad        enddo
9390 cgrad      enddo
9391 cd      do iii=1,nres-3
9392 cd        write (2,*) iii,g_corr6_loc(iii)
9393 cd      enddo
9394       eello6=ekont*eel6
9395 cd      write (2,*) 'ekont',ekont
9396 cd      write (iout,*) 'eello6',ekont*eel6
9397       return
9398       end
9399 c--------------------------------------------------------------------------
9400       double precision function eello6_graph1(i,j,k,l,imat,swap)
9401       implicit real*8 (a-h,o-z)
9402       include 'DIMENSIONS'
9403       include 'COMMON.IOUNITS'
9404       include 'COMMON.CHAIN'
9405       include 'COMMON.DERIV'
9406       include 'COMMON.INTERACT'
9407       include 'COMMON.CONTACTS'
9408       include 'COMMON.TORSION'
9409       include 'COMMON.VAR'
9410       include 'COMMON.GEO'
9411       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9412       logical swap
9413       logical lprn
9414       common /kutas/ lprn
9415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9416 C                                                                              C
9417 C      Parallel       Antiparallel                                             C
9418 C                                                                              C
9419 C          o             o                                                     C
9420 C         /l\           /j\                                                    C
9421 C        /   \         /   \                                                   C
9422 C       /| o |         | o |\                                                  C
9423 C     \ j|/k\|  /   \  |/k\|l /                                                C
9424 C      \ /   \ /     \ /   \ /                                                 C
9425 C       o     o       o     o                                                  C
9426 C       i             i                                                        C
9427 C                                                                              C
9428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9429 c      itk=itortyp(itype(k))
9430       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9431       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9432       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9433       call transpose2(EUgC(1,1,k),auxmat(1,1))
9434       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9435       vv1(1)=pizda1(1,1)-pizda1(2,2)
9436       vv1(2)=pizda1(1,2)+pizda1(2,1)
9437       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9438       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9439       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9440       s5=scalar2(vv(1),Dtobr2(1,i))
9441 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9442       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9443       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9444      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9445      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9446      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9447      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9448      & +scalar2(vv(1),Dtobr2der(1,i)))
9449       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9450       vv1(1)=pizda1(1,1)-pizda1(2,2)
9451       vv1(2)=pizda1(1,2)+pizda1(2,1)
9452       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9453       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9454       if (l.eq.j+1) then
9455         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9456      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9457      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9458      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9459      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9460       else
9461         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9462      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9463      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9464      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9465      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9466       endif
9467       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9468       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9469       vv1(1)=pizda1(1,1)-pizda1(2,2)
9470       vv1(2)=pizda1(1,2)+pizda1(2,1)
9471       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9472      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9473      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9474      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9475       do iii=1,2
9476         if (swap) then
9477           ind=3-iii
9478         else
9479           ind=iii
9480         endif
9481         do kkk=1,5
9482           do lll=1,3
9483             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9484             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9485             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9486             call transpose2(EUgC(1,1,k),auxmat(1,1))
9487             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9488      &        pizda1(1,1))
9489             vv1(1)=pizda1(1,1)-pizda1(2,2)
9490             vv1(2)=pizda1(1,2)+pizda1(2,1)
9491             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9492             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9493      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9494             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9495      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9496             s5=scalar2(vv(1),Dtobr2(1,i))
9497             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9498           enddo
9499         enddo
9500       enddo
9501       return
9502       end
9503 c----------------------------------------------------------------------------
9504       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9505       implicit real*8 (a-h,o-z)
9506       include 'DIMENSIONS'
9507       include 'COMMON.IOUNITS'
9508       include 'COMMON.CHAIN'
9509       include 'COMMON.DERIV'
9510       include 'COMMON.INTERACT'
9511       include 'COMMON.CONTACTS'
9512       include 'COMMON.TORSION'
9513       include 'COMMON.VAR'
9514       include 'COMMON.GEO'
9515       logical swap
9516       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9517      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9518       logical lprn
9519       common /kutas/ lprn
9520 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9521 C                                                                              C
9522 C      Parallel       Antiparallel                                             C
9523 C                                                                              C
9524 C          o             o                                                     C
9525 C     \   /l\           /j\   /                                                C
9526 C      \ /   \         /   \ /                                                 C
9527 C       o| o |         | o |o                                                  C
9528 C     \ j|/k\|      \  |/k\|l                                                  C
9529 C      \ /   \       \ /   \                                                   C
9530 C       o             o                                                        C
9531 C       i             i                                                        C
9532 C                                                                              C
9533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9534 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9535 C AL 7/4/01 s1 would occur in the sixth-order moment,
9536 C           but not in a cluster cumulant
9537 #ifdef MOMENT
9538       s1=dip(1,jj,i)*dip(1,kk,k)
9539 #endif
9540       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9541       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9542       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9543       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9544       call transpose2(EUg(1,1,k),auxmat(1,1))
9545       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9546       vv(1)=pizda(1,1)-pizda(2,2)
9547       vv(2)=pizda(1,2)+pizda(2,1)
9548       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9549 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9550 #ifdef MOMENT
9551       eello6_graph2=-(s1+s2+s3+s4)
9552 #else
9553       eello6_graph2=-(s2+s3+s4)
9554 #endif
9555 c      eello6_graph2=-s3
9556 C Derivatives in gamma(i-1)
9557       if (i.gt.1) then
9558 #ifdef MOMENT
9559         s1=dipderg(1,jj,i)*dip(1,kk,k)
9560 #endif
9561         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9562         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9563         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9564         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9565 #ifdef MOMENT
9566         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9567 #else
9568         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9569 #endif
9570 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9571       endif
9572 C Derivatives in gamma(k-1)
9573 #ifdef MOMENT
9574       s1=dip(1,jj,i)*dipderg(1,kk,k)
9575 #endif
9576       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9577       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9578       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9579       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9580       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9581       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9582       vv(1)=pizda(1,1)-pizda(2,2)
9583       vv(2)=pizda(1,2)+pizda(2,1)
9584       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9585 #ifdef MOMENT
9586       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9587 #else
9588       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9589 #endif
9590 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9591 C Derivatives in gamma(j-1) or gamma(l-1)
9592       if (j.gt.1) then
9593 #ifdef MOMENT
9594         s1=dipderg(3,jj,i)*dip(1,kk,k)
9595 #endif
9596         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9597         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9598         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9599         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9600         vv(1)=pizda(1,1)-pizda(2,2)
9601         vv(2)=pizda(1,2)+pizda(2,1)
9602         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9603 #ifdef MOMENT
9604         if (swap) then
9605           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9606         else
9607           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9608         endif
9609 #endif
9610         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9611 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9612       endif
9613 C Derivatives in gamma(l-1) or gamma(j-1)
9614       if (l.gt.1) then
9615 #ifdef MOMENT
9616         s1=dip(1,jj,i)*dipderg(3,kk,k)
9617 #endif
9618         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9619         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9620         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9621         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9622         call matmat2(ADtEA1derg(1,1,2,1),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         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9626 #ifdef MOMENT
9627         if (swap) then
9628           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9629         else
9630           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9631         endif
9632 #endif
9633         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9634 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9635       endif
9636 C Cartesian derivatives.
9637       if (lprn) then
9638         write (2,*) 'In eello6_graph2'
9639         do iii=1,2
9640           write (2,*) 'iii=',iii
9641           do kkk=1,5
9642             write (2,*) 'kkk=',kkk
9643             do jjj=1,2
9644               write (2,'(3(2f10.5),5x)')
9645      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9646             enddo
9647           enddo
9648         enddo
9649       endif
9650       do iii=1,2
9651         do kkk=1,5
9652           do lll=1,3
9653 #ifdef MOMENT
9654             if (iii.eq.1) then
9655               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9656             else
9657               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9658             endif
9659 #endif
9660             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9661      &        auxvec(1))
9662             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9663             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9664      &        auxvec(1))
9665             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9666             call transpose2(EUg(1,1,k),auxmat(1,1))
9667             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9668      &        pizda(1,1))
9669             vv(1)=pizda(1,1)-pizda(2,2)
9670             vv(2)=pizda(1,2)+pizda(2,1)
9671             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9672 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9673 #ifdef MOMENT
9674             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9675 #else
9676             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9677 #endif
9678             if (swap) then
9679               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9680             else
9681               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9682             endif
9683           enddo
9684         enddo
9685       enddo
9686       return
9687       end
9688 c----------------------------------------------------------------------------
9689       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9690       implicit real*8 (a-h,o-z)
9691       include 'DIMENSIONS'
9692       include 'COMMON.IOUNITS'
9693       include 'COMMON.CHAIN'
9694       include 'COMMON.DERIV'
9695       include 'COMMON.INTERACT'
9696       include 'COMMON.CONTACTS'
9697       include 'COMMON.TORSION'
9698       include 'COMMON.VAR'
9699       include 'COMMON.GEO'
9700       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9701       logical swap
9702 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9703 C                                                                              C
9704 C      Parallel       Antiparallel                                             C
9705 C                                                                              C
9706 C          o             o                                                     C
9707 C         /l\   /   \   /j\                                                    C
9708 C        /   \ /     \ /   \                                                   C
9709 C       /| o |o       o| o |\                                                  C
9710 C       j|/k\|  /      |/k\|l /                                                C
9711 C        /   \ /       /   \ /                                                 C
9712 C       /     o       /     o                                                  C
9713 C       i             i                                                        C
9714 C                                                                              C
9715 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9716 C
9717 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9718 C           energy moment and not to the cluster cumulant.
9719 c      iti=itortyp(itype(i))
9720 c      if (j.lt.nres-1) then
9721 c        itj1=itortyp(itype(j+1))
9722 c      else
9723 c        itj1=ntortyp
9724 c      endif
9725 c      itk=itortyp(itype(k))
9726 c      itk1=itortyp(itype(k+1))
9727 c      if (l.lt.nres-1) then
9728 c        itl1=itortyp(itype(l+1))
9729 c      else
9730 c        itl1=ntortyp
9731 c      endif
9732 #ifdef MOMENT
9733       s1=dip(4,jj,i)*dip(4,kk,k)
9734 #endif
9735       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9736       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9737       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9738       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9739       call transpose2(EE(1,1,k),auxmat(1,1))
9740       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9741       vv(1)=pizda(1,1)+pizda(2,2)
9742       vv(2)=pizda(2,1)-pizda(1,2)
9743       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9744 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9745 cd     & "sum",-(s2+s3+s4)
9746 #ifdef MOMENT
9747       eello6_graph3=-(s1+s2+s3+s4)
9748 #else
9749       eello6_graph3=-(s2+s3+s4)
9750 #endif
9751 c      eello6_graph3=-s4
9752 C Derivatives in gamma(k-1)
9753       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9754       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9755       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9756       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9757 C Derivatives in gamma(l-1)
9758       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9759       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9760       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9761       vv(1)=pizda(1,1)+pizda(2,2)
9762       vv(2)=pizda(2,1)-pizda(1,2)
9763       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9764       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9765 C Cartesian derivatives.
9766       do iii=1,2
9767         do kkk=1,5
9768           do lll=1,3
9769 #ifdef MOMENT
9770             if (iii.eq.1) then
9771               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9772             else
9773               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9774             endif
9775 #endif
9776             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9777      &        auxvec(1))
9778             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9779             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9780      &        auxvec(1))
9781             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9782             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9783      &        pizda(1,1))
9784             vv(1)=pizda(1,1)+pizda(2,2)
9785             vv(2)=pizda(2,1)-pizda(1,2)
9786             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9787 #ifdef MOMENT
9788             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9789 #else
9790             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9791 #endif
9792             if (swap) then
9793               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9794             else
9795               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9796             endif
9797 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9798           enddo
9799         enddo
9800       enddo
9801       return
9802       end
9803 c----------------------------------------------------------------------------
9804       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9805       implicit real*8 (a-h,o-z)
9806       include 'DIMENSIONS'
9807       include 'COMMON.IOUNITS'
9808       include 'COMMON.CHAIN'
9809       include 'COMMON.DERIV'
9810       include 'COMMON.INTERACT'
9811       include 'COMMON.CONTACTS'
9812       include 'COMMON.TORSION'
9813       include 'COMMON.VAR'
9814       include 'COMMON.GEO'
9815       include 'COMMON.FFIELD'
9816       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9817      & auxvec1(2),auxmat1(2,2)
9818       logical swap
9819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9820 C                                                                              C
9821 C      Parallel       Antiparallel                                             C
9822 C                                                                              C
9823 C          o             o                                                     C
9824 C         /l\   /   \   /j\                                                    C
9825 C        /   \ /     \ /   \                                                   C
9826 C       /| o |o       o| o |\                                                  C
9827 C     \ j|/k\|      \  |/k\|l                                                  C
9828 C      \ /   \       \ /   \                                                   C
9829 C       o     \       o     \                                                  C
9830 C       i             i                                                        C
9831 C                                                                              C
9832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9833 C
9834 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9835 C           energy moment and not to the cluster cumulant.
9836 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9837 c      iti=itortyp(itype(i))
9838 c      itj=itortyp(itype(j))
9839 c      if (j.lt.nres-1) then
9840 c        itj1=itortyp(itype(j+1))
9841 c      else
9842 c        itj1=ntortyp
9843 c      endif
9844 c      itk=itortyp(itype(k))
9845 c      if (k.lt.nres-1) then
9846 c        itk1=itortyp(itype(k+1))
9847 c      else
9848 c        itk1=ntortyp
9849 c      endif
9850 c      itl=itortyp(itype(l))
9851 c      if (l.lt.nres-1) then
9852 c        itl1=itortyp(itype(l+1))
9853 c      else
9854 c        itl1=ntortyp
9855 c      endif
9856 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9857 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9858 cd     & ' itl',itl,' itl1',itl1
9859 #ifdef MOMENT
9860       if (imat.eq.1) then
9861         s1=dip(3,jj,i)*dip(3,kk,k)
9862       else
9863         s1=dip(2,jj,j)*dip(2,kk,l)
9864       endif
9865 #endif
9866       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9867       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9868       if (j.eq.l+1) then
9869         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9870         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9871       else
9872         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9873         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9874       endif
9875       call transpose2(EUg(1,1,k),auxmat(1,1))
9876       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9877       vv(1)=pizda(1,1)-pizda(2,2)
9878       vv(2)=pizda(2,1)+pizda(1,2)
9879       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9880 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9881 #ifdef MOMENT
9882       eello6_graph4=-(s1+s2+s3+s4)
9883 #else
9884       eello6_graph4=-(s2+s3+s4)
9885 #endif
9886 C Derivatives in gamma(i-1)
9887       if (i.gt.1) then
9888 #ifdef MOMENT
9889         if (imat.eq.1) then
9890           s1=dipderg(2,jj,i)*dip(3,kk,k)
9891         else
9892           s1=dipderg(4,jj,j)*dip(2,kk,l)
9893         endif
9894 #endif
9895         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9896         if (j.eq.l+1) then
9897           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9898           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9899         else
9900           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9901           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9902         endif
9903         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9904         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9905 cd          write (2,*) 'turn6 derivatives'
9906 #ifdef MOMENT
9907           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9908 #else
9909           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9910 #endif
9911         else
9912 #ifdef MOMENT
9913           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9914 #else
9915           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9916 #endif
9917         endif
9918       endif
9919 C Derivatives in gamma(k-1)
9920 #ifdef MOMENT
9921       if (imat.eq.1) then
9922         s1=dip(3,jj,i)*dipderg(2,kk,k)
9923       else
9924         s1=dip(2,jj,j)*dipderg(4,kk,l)
9925       endif
9926 #endif
9927       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9928       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9929       if (j.eq.l+1) then
9930         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9931         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9932       else
9933         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9934         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9935       endif
9936       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9937       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9938       vv(1)=pizda(1,1)-pizda(2,2)
9939       vv(2)=pizda(2,1)+pizda(1,2)
9940       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9941       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9942 #ifdef MOMENT
9943         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9944 #else
9945         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9946 #endif
9947       else
9948 #ifdef MOMENT
9949         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9950 #else
9951         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9952 #endif
9953       endif
9954 C Derivatives in gamma(j-1) or gamma(l-1)
9955       if (l.eq.j+1 .and. l.gt.1) then
9956         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9957         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9958         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9959         vv(1)=pizda(1,1)-pizda(2,2)
9960         vv(2)=pizda(2,1)+pizda(1,2)
9961         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9962         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9963       else if (j.gt.1) then
9964         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9965         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9966         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9967         vv(1)=pizda(1,1)-pizda(2,2)
9968         vv(2)=pizda(2,1)+pizda(1,2)
9969         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9970         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9971           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9972         else
9973           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9974         endif
9975       endif
9976 C Cartesian derivatives.
9977       do iii=1,2
9978         do kkk=1,5
9979           do lll=1,3
9980 #ifdef MOMENT
9981             if (iii.eq.1) then
9982               if (imat.eq.1) then
9983                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9984               else
9985                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9986               endif
9987             else
9988               if (imat.eq.1) then
9989                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9990               else
9991                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9992               endif
9993             endif
9994 #endif
9995             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9996      &        auxvec(1))
9997             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9998             if (j.eq.l+1) then
9999               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10000      &          b1(1,j+1),auxvec(1))
10001               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10002             else
10003               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10004      &          b1(1,l+1),auxvec(1))
10005               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10006             endif
10007             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10008      &        pizda(1,1))
10009             vv(1)=pizda(1,1)-pizda(2,2)
10010             vv(2)=pizda(2,1)+pizda(1,2)
10011             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10012             if (swap) then
10013               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10014 #ifdef MOMENT
10015                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10016      &             -(s1+s2+s4)
10017 #else
10018                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10019      &             -(s2+s4)
10020 #endif
10021                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10022               else
10023 #ifdef MOMENT
10024                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10025 #else
10026                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10027 #endif
10028                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10029               endif
10030             else
10031 #ifdef MOMENT
10032               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10033 #else
10034               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10035 #endif
10036               if (l.eq.j+1) then
10037                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10038               else
10039                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10040               endif
10041             endif
10042           enddo
10043         enddo
10044       enddo
10045       return
10046       end
10047 c----------------------------------------------------------------------------
10048       double precision function eello_turn6(i,jj,kk)
10049       implicit real*8 (a-h,o-z)
10050       include 'DIMENSIONS'
10051       include 'COMMON.IOUNITS'
10052       include 'COMMON.CHAIN'
10053       include 'COMMON.DERIV'
10054       include 'COMMON.INTERACT'
10055       include 'COMMON.CONTACTS'
10056       include 'COMMON.TORSION'
10057       include 'COMMON.VAR'
10058       include 'COMMON.GEO'
10059       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10060      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10061      &  ggg1(3),ggg2(3)
10062       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10063      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10064 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10065 C           the respective energy moment and not to the cluster cumulant.
10066       s1=0.0d0
10067       s8=0.0d0
10068       s13=0.0d0
10069 c
10070       eello_turn6=0.0d0
10071       j=i+4
10072       k=i+1
10073       l=i+3
10074       iti=itortyp(itype(i))
10075       itk=itortyp(itype(k))
10076       itk1=itortyp(itype(k+1))
10077       itl=itortyp(itype(l))
10078       itj=itortyp(itype(j))
10079 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10080 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10081 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10082 cd        eello6=0.0d0
10083 cd        return
10084 cd      endif
10085 cd      write (iout,*)
10086 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10087 cd     &   ' and',k,l
10088 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10089       do iii=1,2
10090         do kkk=1,5
10091           do lll=1,3
10092             derx_turn(lll,kkk,iii)=0.0d0
10093           enddo
10094         enddo
10095       enddo
10096 cd      eij=1.0d0
10097 cd      ekl=1.0d0
10098 cd      ekont=1.0d0
10099       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10100 cd      eello6_5=0.0d0
10101 cd      write (2,*) 'eello6_5',eello6_5
10102 #ifdef MOMENT
10103       call transpose2(AEA(1,1,1),auxmat(1,1))
10104       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10105       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10106       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10107 #endif
10108       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10109       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10110       s2 = scalar2(b1(1,k),vtemp1(1))
10111 #ifdef MOMENT
10112       call transpose2(AEA(1,1,2),atemp(1,1))
10113       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10114       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10115       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10116 #endif
10117       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10118       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10119       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10120 #ifdef MOMENT
10121       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10122       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10123       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10124       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10125       ss13 = scalar2(b1(1,k),vtemp4(1))
10126       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10127 #endif
10128 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10129 c      s1=0.0d0
10130 c      s2=0.0d0
10131 c      s8=0.0d0
10132 c      s12=0.0d0
10133 c      s13=0.0d0
10134       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10135 C Derivatives in gamma(i+2)
10136       s1d =0.0d0
10137       s8d =0.0d0
10138 #ifdef MOMENT
10139       call transpose2(AEA(1,1,1),auxmatd(1,1))
10140       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10141       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10142       call transpose2(AEAderg(1,1,2),atempd(1,1))
10143       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10144       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10145 #endif
10146       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10147       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10148       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10149 c      s1d=0.0d0
10150 c      s2d=0.0d0
10151 c      s8d=0.0d0
10152 c      s12d=0.0d0
10153 c      s13d=0.0d0
10154       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10155 C Derivatives in gamma(i+3)
10156 #ifdef MOMENT
10157       call transpose2(AEA(1,1,1),auxmatd(1,1))
10158       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10159       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10160       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10161 #endif
10162       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10163       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10164       s2d = scalar2(b1(1,k),vtemp1d(1))
10165 #ifdef MOMENT
10166       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10167       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10168 #endif
10169       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10170 #ifdef MOMENT
10171       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10172       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10173       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10174 #endif
10175 c      s1d=0.0d0
10176 c      s2d=0.0d0
10177 c      s8d=0.0d0
10178 c      s12d=0.0d0
10179 c      s13d=0.0d0
10180 #ifdef MOMENT
10181       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10182      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10183 #else
10184       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10185      &               -0.5d0*ekont*(s2d+s12d)
10186 #endif
10187 C Derivatives in gamma(i+4)
10188       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10189       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10190       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10191 #ifdef MOMENT
10192       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10193       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10194       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10195 #endif
10196 c      s1d=0.0d0
10197 c      s2d=0.0d0
10198 c      s8d=0.0d0
10199 C      s12d=0.0d0
10200 c      s13d=0.0d0
10201 #ifdef MOMENT
10202       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10203 #else
10204       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10205 #endif
10206 C Derivatives in gamma(i+5)
10207 #ifdef MOMENT
10208       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10209       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10210       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10211 #endif
10212       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10213       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10214       s2d = scalar2(b1(1,k),vtemp1d(1))
10215 #ifdef MOMENT
10216       call transpose2(AEA(1,1,2),atempd(1,1))
10217       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10218       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10219 #endif
10220       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10221       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10222 #ifdef MOMENT
10223       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10224       ss13d = scalar2(b1(1,k),vtemp4d(1))
10225       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10226 #endif
10227 c      s1d=0.0d0
10228 c      s2d=0.0d0
10229 c      s8d=0.0d0
10230 c      s12d=0.0d0
10231 c      s13d=0.0d0
10232 #ifdef MOMENT
10233       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10234      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10235 #else
10236       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10237      &               -0.5d0*ekont*(s2d+s12d)
10238 #endif
10239 C Cartesian derivatives
10240       do iii=1,2
10241         do kkk=1,5
10242           do lll=1,3
10243 #ifdef MOMENT
10244             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10245             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10246             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10247 #endif
10248             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10249             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10250      &          vtemp1d(1))
10251             s2d = scalar2(b1(1,k),vtemp1d(1))
10252 #ifdef MOMENT
10253             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10254             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10255             s8d = -(atempd(1,1)+atempd(2,2))*
10256      &           scalar2(cc(1,1,itl),vtemp2(1))
10257 #endif
10258             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10259      &           auxmatd(1,1))
10260             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10261             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10262 c      s1d=0.0d0
10263 c      s2d=0.0d0
10264 c      s8d=0.0d0
10265 c      s12d=0.0d0
10266 c      s13d=0.0d0
10267 #ifdef MOMENT
10268             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10269      &        - 0.5d0*(s1d+s2d)
10270 #else
10271             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10272      &        - 0.5d0*s2d
10273 #endif
10274 #ifdef MOMENT
10275             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10276      &        - 0.5d0*(s8d+s12d)
10277 #else
10278             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10279      &        - 0.5d0*s12d
10280 #endif
10281           enddo
10282         enddo
10283       enddo
10284 #ifdef MOMENT
10285       do kkk=1,5
10286         do lll=1,3
10287           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10288      &      achuj_tempd(1,1))
10289           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10290           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10291           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10292           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10293           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10294      &      vtemp4d(1))
10295           ss13d = scalar2(b1(1,k),vtemp4d(1))
10296           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10297           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10298         enddo
10299       enddo
10300 #endif
10301 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10302 cd     &  16*eel_turn6_num
10303 cd      goto 1112
10304       if (j.lt.nres-1) then
10305         j1=j+1
10306         j2=j-1
10307       else
10308         j1=j-1
10309         j2=j-2
10310       endif
10311       if (l.lt.nres-1) then
10312         l1=l+1
10313         l2=l-1
10314       else
10315         l1=l-1
10316         l2=l-2
10317       endif
10318       do ll=1,3
10319 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10320 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10321 cgrad        ghalf=0.5d0*ggg1(ll)
10322 cd        ghalf=0.0d0
10323         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10324         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10325         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10326      &    +ekont*derx_turn(ll,2,1)
10327         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10328         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10329      &    +ekont*derx_turn(ll,4,1)
10330         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10331         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10332         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10333 cgrad        ghalf=0.5d0*ggg2(ll)
10334 cd        ghalf=0.0d0
10335         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10336      &    +ekont*derx_turn(ll,2,2)
10337         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10338         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10339      &    +ekont*derx_turn(ll,4,2)
10340         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10341         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10342         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10343       enddo
10344 cd      goto 1112
10345 cgrad      do m=i+1,j-1
10346 cgrad        do ll=1,3
10347 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10348 cgrad        enddo
10349 cgrad      enddo
10350 cgrad      do m=k+1,l-1
10351 cgrad        do ll=1,3
10352 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10353 cgrad        enddo
10354 cgrad      enddo
10355 cgrad1112  continue
10356 cgrad      do m=i+2,j2
10357 cgrad        do ll=1,3
10358 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10359 cgrad        enddo
10360 cgrad      enddo
10361 cgrad      do m=k+2,l2
10362 cgrad        do ll=1,3
10363 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10364 cgrad        enddo
10365 cgrad      enddo
10366 cd      do iii=1,nres-3
10367 cd        write (2,*) iii,g_corr6_loc(iii)
10368 cd      enddo
10369       eello_turn6=ekont*eel_turn6
10370 cd      write (2,*) 'ekont',ekont
10371 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10372       return
10373       end
10374
10375 C-----------------------------------------------------------------------------
10376       double precision function scalar(u,v)
10377 !DIR$ INLINEALWAYS scalar
10378 #ifndef OSF
10379 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10380 #endif
10381       implicit none
10382       double precision u(3),v(3)
10383 cd      double precision sc
10384 cd      integer i
10385 cd      sc=0.0d0
10386 cd      do i=1,3
10387 cd        sc=sc+u(i)*v(i)
10388 cd      enddo
10389 cd      scalar=sc
10390
10391       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10392       return
10393       end
10394 crc-------------------------------------------------
10395       SUBROUTINE MATVEC2(A1,V1,V2)
10396 !DIR$ INLINEALWAYS MATVEC2
10397 #ifndef OSF
10398 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10399 #endif
10400       implicit real*8 (a-h,o-z)
10401       include 'DIMENSIONS'
10402       DIMENSION A1(2,2),V1(2),V2(2)
10403 c      DO 1 I=1,2
10404 c        VI=0.0
10405 c        DO 3 K=1,2
10406 c    3     VI=VI+A1(I,K)*V1(K)
10407 c        Vaux(I)=VI
10408 c    1 CONTINUE
10409
10410       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10411       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10412
10413       v2(1)=vaux1
10414       v2(2)=vaux2
10415       END
10416 C---------------------------------------
10417       SUBROUTINE MATMAT2(A1,A2,A3)
10418 #ifndef OSF
10419 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10420 #endif
10421       implicit real*8 (a-h,o-z)
10422       include 'DIMENSIONS'
10423       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10424 c      DIMENSION AI3(2,2)
10425 c        DO  J=1,2
10426 c          A3IJ=0.0
10427 c          DO K=1,2
10428 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10429 c          enddo
10430 c          A3(I,J)=A3IJ
10431 c       enddo
10432 c      enddo
10433
10434       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10435       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10436       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10437       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10438
10439       A3(1,1)=AI3_11
10440       A3(2,1)=AI3_21
10441       A3(1,2)=AI3_12
10442       A3(2,2)=AI3_22
10443       END
10444
10445 c-------------------------------------------------------------------------
10446       double precision function scalar2(u,v)
10447 !DIR$ INLINEALWAYS scalar2
10448       implicit none
10449       double precision u(2),v(2)
10450       double precision sc
10451       integer i
10452       scalar2=u(1)*v(1)+u(2)*v(2)
10453       return
10454       end
10455
10456 C-----------------------------------------------------------------------------
10457
10458       subroutine transpose2(a,at)
10459 !DIR$ INLINEALWAYS transpose2
10460 #ifndef OSF
10461 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10462 #endif
10463       implicit none
10464       double precision a(2,2),at(2,2)
10465       at(1,1)=a(1,1)
10466       at(1,2)=a(2,1)
10467       at(2,1)=a(1,2)
10468       at(2,2)=a(2,2)
10469       return
10470       end
10471 c--------------------------------------------------------------------------
10472       subroutine transpose(n,a,at)
10473       implicit none
10474       integer n,i,j
10475       double precision a(n,n),at(n,n)
10476       do i=1,n
10477         do j=1,n
10478           at(j,i)=a(i,j)
10479         enddo
10480       enddo
10481       return
10482       end
10483 C---------------------------------------------------------------------------
10484       subroutine prodmat3(a1,a2,kk,transp,prod)
10485 !DIR$ INLINEALWAYS prodmat3
10486 #ifndef OSF
10487 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10488 #endif
10489       implicit none
10490       integer i,j
10491       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10492       logical transp
10493 crc      double precision auxmat(2,2),prod_(2,2)
10494
10495       if (transp) then
10496 crc        call transpose2(kk(1,1),auxmat(1,1))
10497 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10498 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10499
10500            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10501      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10502            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10503      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10504            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10505      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10506            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10507      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10508
10509       else
10510 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10511 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10512
10513            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10514      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10515            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10516      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10517            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10518      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10519            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10520      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10521
10522       endif
10523 c      call transpose2(a2(1,1),a2t(1,1))
10524
10525 crc      print *,transp
10526 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10527 crc      print *,((prod(i,j),i=1,2),j=1,2)
10528
10529       return
10530       end
10531 CCC----------------------------------------------
10532       subroutine Eliptransfer(eliptran)
10533       implicit real*8 (a-h,o-z)
10534       include 'DIMENSIONS'
10535       include 'COMMON.GEO'
10536       include 'COMMON.VAR'
10537       include 'COMMON.LOCAL'
10538       include 'COMMON.CHAIN'
10539       include 'COMMON.DERIV'
10540       include 'COMMON.NAMES'
10541       include 'COMMON.INTERACT'
10542       include 'COMMON.IOUNITS'
10543       include 'COMMON.CALC'
10544       include 'COMMON.CONTROL'
10545       include 'COMMON.SPLITELE'
10546       include 'COMMON.SBRIDGE'
10547 C this is done by Adasko
10548 C      print *,"wchodze"
10549 C structure of box:
10550 C      water
10551 C--bordliptop-- buffore starts
10552 C--bufliptop--- here true lipid starts
10553 C      lipid
10554 C--buflipbot--- lipid ends buffore starts
10555 C--bordlipbot--buffore ends
10556       eliptran=0.0
10557       do i=ilip_start,ilip_end
10558 C       do i=1,1
10559         if (itype(i).eq.ntyp1) cycle
10560
10561         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10562         if (positi.le.0) positi=positi+boxzsize
10563 C        print *,i
10564 C first for peptide groups
10565 c for each residue check if it is in lipid or lipid water border area
10566        if ((positi.gt.bordlipbot)
10567      &.and.(positi.lt.bordliptop)) then
10568 C the energy transfer exist
10569         if (positi.lt.buflipbot) then
10570 C what fraction I am in
10571          fracinbuf=1.0d0-
10572      &        ((positi-bordlipbot)/lipbufthick)
10573 C lipbufthick is thickenes of lipid buffore
10574          sslip=sscalelip(fracinbuf)
10575          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10576          eliptran=eliptran+sslip*pepliptran
10577          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10578          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10579 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10580
10581 C        print *,"doing sccale for lower part"
10582 C         print *,i,sslip,fracinbuf,ssgradlip
10583         elseif (positi.gt.bufliptop) then
10584          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10585          sslip=sscalelip(fracinbuf)
10586          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10587          eliptran=eliptran+sslip*pepliptran
10588          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10589          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10590 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10591 C          print *, "doing sscalefor top part"
10592 C         print *,i,sslip,fracinbuf,ssgradlip
10593         else
10594          eliptran=eliptran+pepliptran
10595 C         print *,"I am in true lipid"
10596         endif
10597 C       else
10598 C       eliptran=elpitran+0.0 ! I am in water
10599        endif
10600        enddo
10601 C       print *, "nic nie bylo w lipidzie?"
10602 C now multiply all by the peptide group transfer factor
10603 C       eliptran=eliptran*pepliptran
10604 C now the same for side chains
10605 CV       do i=1,1
10606        do i=ilip_start,ilip_end
10607         if (itype(i).eq.ntyp1) cycle
10608         positi=(mod(c(3,i+nres),boxzsize))
10609         if (positi.le.0) positi=positi+boxzsize
10610 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10611 c for each residue check if it is in lipid or lipid water border area
10612 C       respos=mod(c(3,i+nres),boxzsize)
10613 C       print *,positi,bordlipbot,buflipbot
10614        if ((positi.gt.bordlipbot)
10615      & .and.(positi.lt.bordliptop)) then
10616 C the energy transfer exist
10617         if (positi.lt.buflipbot) then
10618          fracinbuf=1.0d0-
10619      &     ((positi-bordlipbot)/lipbufthick)
10620 C lipbufthick is thickenes of lipid buffore
10621          sslip=sscalelip(fracinbuf)
10622          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10623          eliptran=eliptran+sslip*liptranene(itype(i))
10624          gliptranx(3,i)=gliptranx(3,i)
10625      &+ssgradlip*liptranene(itype(i))
10626          gliptranc(3,i-1)= gliptranc(3,i-1)
10627      &+ssgradlip*liptranene(itype(i))
10628 C         print *,"doing sccale for lower part"
10629         elseif (positi.gt.bufliptop) then
10630          fracinbuf=1.0d0-
10631      &((bordliptop-positi)/lipbufthick)
10632          sslip=sscalelip(fracinbuf)
10633          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10634          eliptran=eliptran+sslip*liptranene(itype(i))
10635          gliptranx(3,i)=gliptranx(3,i)
10636      &+ssgradlip*liptranene(itype(i))
10637          gliptranc(3,i-1)= gliptranc(3,i-1)
10638      &+ssgradlip*liptranene(itype(i))
10639 C          print *, "doing sscalefor top part",sslip,fracinbuf
10640         else
10641          eliptran=eliptran+liptranene(itype(i))
10642 C         print *,"I am in true lipid"
10643         endif
10644         endif ! if in lipid or buffor
10645 C       else
10646 C       eliptran=elpitran+0.0 ! I am in water
10647        enddo
10648        return
10649        end
10650 C---------------------------------------------------------
10651 C AFM soubroutine for constant force
10652        subroutine AFMforce(Eafmforce)
10653        implicit real*8 (a-h,o-z)
10654       include 'DIMENSIONS'
10655       include 'COMMON.GEO'
10656       include 'COMMON.VAR'
10657       include 'COMMON.LOCAL'
10658       include 'COMMON.CHAIN'
10659       include 'COMMON.DERIV'
10660       include 'COMMON.NAMES'
10661       include 'COMMON.INTERACT'
10662       include 'COMMON.IOUNITS'
10663       include 'COMMON.CALC'
10664       include 'COMMON.CONTROL'
10665       include 'COMMON.SPLITELE'
10666       include 'COMMON.SBRIDGE'
10667       real*8 diffafm(3)
10668       dist=0.0d0
10669       Eafmforce=0.0d0
10670       do i=1,3
10671       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10672       dist=dist+diffafm(i)**2
10673       enddo
10674       dist=dsqrt(dist)
10675       Eafmforce=-forceAFMconst*(dist-distafminit)
10676       do i=1,3
10677       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10678       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10679       enddo
10680 C      print *,'AFM',Eafmforce
10681       return
10682       end
10683 C---------------------------------------------------------
10684 C AFM subroutine with pseudoconstant velocity
10685        subroutine AFMvel(Eafmforce)
10686        implicit real*8 (a-h,o-z)
10687       include 'DIMENSIONS'
10688       include 'COMMON.GEO'
10689       include 'COMMON.VAR'
10690       include 'COMMON.LOCAL'
10691       include 'COMMON.CHAIN'
10692       include 'COMMON.DERIV'
10693       include 'COMMON.NAMES'
10694       include 'COMMON.INTERACT'
10695       include 'COMMON.IOUNITS'
10696       include 'COMMON.CALC'
10697       include 'COMMON.CONTROL'
10698       include 'COMMON.SPLITELE'
10699       include 'COMMON.SBRIDGE'
10700       real*8 diffafm(3)
10701 C Only for check grad COMMENT if not used for checkgrad
10702 C      totT=3.0d0
10703 C--------------------------------------------------------
10704 C      print *,"wchodze"
10705       dist=0.0d0
10706       Eafmforce=0.0d0
10707       do i=1,3
10708       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10709       dist=dist+diffafm(i)**2
10710       enddo
10711       dist=dsqrt(dist)
10712       Eafmforce=0.5d0*forceAFMconst
10713      & *(distafminit+totTafm*velAFMconst-dist)**2
10714 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10715       do i=1,3
10716       gradafm(i,afmend-1)=-forceAFMconst*
10717      &(distafminit+totTafm*velAFMconst-dist)
10718      &*diffafm(i)/dist
10719       gradafm(i,afmbeg-1)=forceAFMconst*
10720      &(distafminit+totTafm*velAFMconst-dist)
10721      &*diffafm(i)/dist
10722       enddo
10723 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10724       return
10725       end
10726 C-----------------------------------------------------------
10727 C first for shielding is setting of function of side-chains
10728        subroutine set_shield_fac
10729       implicit real*8 (a-h,o-z)
10730       include 'DIMENSIONS'
10731       include 'COMMON.CHAIN'
10732       include 'COMMON.DERIV'
10733       include 'COMMON.IOUNITS'
10734       include 'COMMON.SHIELD'
10735       include 'COMMON.INTERACT'
10736 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10737       double precision div77_81/0.974996043d0/,
10738      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10739
10740 C the vector between center of side_chain and peptide group
10741        double precision pep_side(3),long,side_calf(3),
10742      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10743      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10744 C the line belowe needs to be changed for FGPROC>1
10745       do i=1,nres-1
10746       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10747       ishield_list(i)=0
10748 Cif there two consequtive dummy atoms there is no peptide group between them
10749 C the line below has to be changed for FGPROC>1
10750       VolumeTotal=0.0
10751       do k=1,nres
10752        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10753        dist_pep_side=0.0
10754        dist_side_calf=0.0
10755        do j=1,3
10756 C first lets set vector conecting the ithe side-chain with kth side-chain
10757       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10758 C      pep_side(j)=2.0d0
10759 C and vector conecting the side-chain with its proper calfa
10760       side_calf(j)=c(j,k+nres)-c(j,k)
10761 C      side_calf(j)=2.0d0
10762       pept_group(j)=c(j,i)-c(j,i+1)
10763 C lets have their lenght
10764       dist_pep_side=pep_side(j)**2+dist_pep_side
10765       dist_side_calf=dist_side_calf+side_calf(j)**2
10766       dist_pept_group=dist_pept_group+pept_group(j)**2
10767       enddo
10768        dist_pep_side=dsqrt(dist_pep_side)
10769        dist_pept_group=dsqrt(dist_pept_group)
10770        dist_side_calf=dsqrt(dist_side_calf)
10771       do j=1,3
10772         pep_side_norm(j)=pep_side(j)/dist_pep_side
10773         side_calf_norm(j)=dist_side_calf
10774       enddo
10775 C now sscale fraction
10776        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10777 C       print *,buff_shield,"buff"
10778 C now sscale
10779         if (sh_frac_dist.le.0.0) cycle
10780 C If we reach here it means that this side chain reaches the shielding sphere
10781 C Lets add him to the list for gradient
10782         ishield_list(i)=ishield_list(i)+1
10783 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10784 C this list is essential otherwise problem would be O3
10785         shield_list(ishield_list(i),i)=k
10786 C Lets have the sscale value
10787         if (sh_frac_dist.gt.1.0) then
10788          scale_fac_dist=1.0d0
10789          do j=1,3
10790          sh_frac_dist_grad(j)=0.0d0
10791          enddo
10792         else
10793          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10794      &                   *(2.0*sh_frac_dist-3.0d0)
10795          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10796      &                  /dist_pep_side/buff_shield*0.5
10797 C remember for the final gradient multiply sh_frac_dist_grad(j)
10798 C for side_chain by factor -2 !
10799          do j=1,3
10800          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10801 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10802 C     &                    sh_frac_dist_grad(j)
10803          enddo
10804         endif
10805 C        if ((i.eq.3).and.(k.eq.2)) then
10806 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10807 C     & ,"TU"
10808 C        endif
10809
10810 C this is what is now we have the distance scaling now volume...
10811       short=short_r_sidechain(itype(k))
10812       long=long_r_sidechain(itype(k))
10813       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10814 C now costhet_grad
10815 C       costhet=0.0d0
10816        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10817 C       costhet_fac=0.0d0
10818        do j=1,3
10819          costhet_grad(j)=costhet_fac*pep_side(j)
10820        enddo
10821 C remember for the final gradient multiply costhet_grad(j)
10822 C for side_chain by factor -2 !
10823 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10824 C pep_side0pept_group is vector multiplication
10825       pep_side0pept_group=0.0
10826       do j=1,3
10827       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10828       enddo
10829       cosalfa=(pep_side0pept_group/
10830      & (dist_pep_side*dist_side_calf))
10831       fac_alfa_sin=1.0-cosalfa**2
10832       fac_alfa_sin=dsqrt(fac_alfa_sin)
10833       rkprim=fac_alfa_sin*(long-short)+short
10834 C now costhet_grad
10835        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10836        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10837
10838        do j=1,3
10839          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10840      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10841      &*(long-short)/fac_alfa_sin*cosalfa/
10842      &((dist_pep_side*dist_side_calf))*
10843      &((side_calf(j))-cosalfa*
10844      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10845
10846         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10847      &*(long-short)/fac_alfa_sin*cosalfa
10848      &/((dist_pep_side*dist_side_calf))*
10849      &(pep_side(j)-
10850      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10851        enddo
10852
10853       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10854      &                    /VSolvSphere_div
10855 C now the gradient...
10856 C grad_shield is gradient of Calfa for peptide groups
10857       do j=1,3
10858       grad_shield(j,i)=grad_shield(j,i)
10859 C gradient po skalowaniu
10860      &                +(sh_frac_dist_grad(j)
10861 C  gradient po costhet
10862      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10863      &-scale_fac_dist*(cosphi_grad_long(j))
10864      &/(1.0-cosphi) )*div77_81
10865      &*VofOverlap
10866 C grad_shield_side is Cbeta sidechain gradient
10867       grad_shield_side(j,ishield_list(i),i)=
10868      &        (sh_frac_dist_grad(j)*(-2.0d0)
10869      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10870      &       +scale_fac_dist*(cosphi_grad_long(j))
10871      &        *2.0d0/(1.0-cosphi))
10872      &        *div77_81*VofOverlap
10873
10874        grad_shield_loc(j,ishield_list(i),i)=
10875      &   scale_fac_dist*cosphi_grad_loc(j)
10876      &        *2.0d0/(1.0-cosphi)
10877      &        *div77_81*VofOverlap
10878       enddo
10879       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10880       enddo
10881       fac_shield(i)=VolumeTotal*div77_81+div4_81
10882 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10883       enddo
10884       return
10885       end
10886