source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.eq.1) then
 146        call set_shield_fac
 147       else if  (shield_mode.eq.2) then
 148        call set_shield_fac2
 149       endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172         write (iout,*) "Soft-spheer ELEC potential"
 173 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174 c     &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 207         call ebend(ebe,ethetacnstr)
 208         endif
 209 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 210 C energy function
 211        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 212          call ebend_kcc(ebe,ethetacnstr)
 213         endif
 214       else
 215         ebe=0
 216         ethetacnstr=0
 217       endif
 218 c      print *,"Processor",myrank," computed UB"
 219 C
 220 C Calculate the SC local energy.
 221 C
 222 C      print *,"TU DOCHODZE?"
 223       call esc(escloc)
 224 c      print *,"Processor",myrank," computed USC"
 225 C
 226 C Calculate the virtual-bond torsional energy.
 227 C
 228 cd    print *,'nterm=',nterm
 229 C      print *,"tor",tor_mode
 230       if (wtor.gt.0) then
 231        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 232        call etor(etors,edihcnstr)
 233        endif
 234 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 235 C energy function
 236        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 237        call etor_kcc(etors,edihcnstr)
 238        endif
 239       else
 240        etors=0
 241        edihcnstr=0
 242       endif
 243 c      print *,"Processor",myrank," computed Utor"
 244 C
 245 C 6/23/01 Calculate double-torsional energy
 246 C
 247       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 248        call etor_d(etors_d)
 249       else
 250        etors_d=0
 251       endif
 252 c      print *,"Processor",myrank," computed Utord"
 253 C
 254 C 21/5/07 Calculate local sicdechain correlation energy
 255 C
 256       if (wsccor.gt.0.0d0) then
 257         call eback_sc_corr(esccor)
 258       else
 259         esccor=0.0d0
 260       endif
 261 C      print *,"PRZED MULIt"
 262 c      print *,"Processor",myrank," computed Usccorr"
 263 C
 264 C 12/1/95 Multi-body terms
 265 C
 266       n_corr=0
 267       n_corr1=0
 268       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 269      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 270          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 271 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 272 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 273       else
 274          ecorr=0.0d0
 275          ecorr5=0.0d0
 276          ecorr6=0.0d0
 277          eturn6=0.0d0
 278       endif
 279       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 280          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 281 cd         write (iout,*) "multibody_hb ecorr",ecorr
 282       endif
 283 c      print *,"Processor",myrank," computed Ucorr"
 284 C
 285 C If performing constraint dynamics, call the constraint energy
 286 C  after the equilibration time
 287       if(usampl.and.totT.gt.eq_time) then
 288          call EconstrQ
 289          call Econstr_back
 290       else
 291          Uconst=0.0d0
 292          Uconst_back=0.0d0
 293       endif
 294 C 01/27/2015 added by adasko
 295 C the energy component below is energy transfer into lipid environment
 296 C based on partition function
 297 C      print *,"przed lipidami"
 298       if (wliptran.gt.0) then
 299         call Eliptransfer(eliptran)
 300       endif
 301 C      print *,"za lipidami"
 302       if (AFMlog.gt.0) then
 303         call AFMforce(Eafmforce)
 304       else if (selfguide.gt.0) then
 305         call AFMvel(Eafmforce)
 306       endif
 307 #ifdef TIMING
 308       time_enecalc=time_enecalc+MPI_Wtime()-time00
 309 #endif
 310 c      print *,"Processor",myrank," computed Uconstr"
 311 #ifdef TIMING
 312       time00=MPI_Wtime()
 313 #endif
 314 c
 315 C Sum the energies
 316 C
 317       energia(1)=evdw
 318 #ifdef SCP14
 319       energia(2)=evdw2-evdw2_14
 320       energia(18)=evdw2_14
 321 #else
 322       energia(2)=evdw2
 323       energia(18)=0.0d0
 324 #endif
 325 #ifdef SPLITELE
 326       energia(3)=ees
 327       energia(16)=evdw1
 328 #else
 329       energia(3)=ees+evdw1
 330       energia(16)=0.0d0
 331 #endif
 332       energia(4)=ecorr
 333       energia(5)=ecorr5
 334       energia(6)=ecorr6
 335       energia(7)=eel_loc
 336       energia(8)=eello_turn3
 337       energia(9)=eello_turn4
 338       energia(10)=eturn6
 339       energia(11)=ebe
 340       energia(12)=escloc
 341       energia(13)=etors
 342       energia(14)=etors_d
 343       energia(15)=ehpb
 344       energia(19)=edihcnstr
 345       energia(17)=estr
 346       energia(20)=Uconst+Uconst_back
 347       energia(21)=esccor
 348       energia(22)=eliptran
 349       energia(23)=Eafmforce
 350       energia(24)=ethetacnstr
 351 c    Here are the energies showed per procesor if the are more processors
 352 c    per molecule then we sum it up in sum_energy subroutine
 353 c      print *," Processor",myrank," calls SUM_ENERGY"
 354       call sum_energy(energia,.true.)
 355       if (dyn_ss) call dyn_set_nss
 356 c      print *," Processor",myrank," left SUM_ENERGY"
 357 #ifdef TIMING
 358       time_sumene=time_sumene+MPI_Wtime()-time00
 359 #endif
 360       return
 361       end
 362 c-------------------------------------------------------------------------------
 363       subroutine sum_energy(energia,reduce)
 364       implicit real*8 (a-h,o-z)
 365       include 'DIMENSIONS'
 366 #ifndef ISNAN
 367       external proc_proc
 368 #ifdef WINPGI
 369 cMS$ATTRIBUTES C ::  proc_proc
 370 #endif
 371 #endif
 372 #ifdef MPI
 373       include "mpif.h"
 374 #endif
 375       include 'COMMON.SETUP'
 376       include 'COMMON.IOUNITS'
 377       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 378       include 'COMMON.FFIELD'
 379       include 'COMMON.DERIV'
 380       include 'COMMON.INTERACT'
 381       include 'COMMON.SBRIDGE'
 382       include 'COMMON.CHAIN'
 383       include 'COMMON.VAR'
 384       include 'COMMON.CONTROL'
 385       include 'COMMON.TIME1'
 386       logical reduce
 387 #ifdef MPI
 388       if (nfgtasks.gt.1 .and. reduce) then
 389 #ifdef DEBUG
 390         write (iout,*) "energies before REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         do i=0,n_ene
 395           enebuff(i)=energia(i)
 396         enddo
 397         time00=MPI_Wtime()
 398         call MPI_Barrier(FG_COMM,IERR)
 399         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 400         time00=MPI_Wtime()
 401         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 402      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 403 #ifdef DEBUG
 404         write (iout,*) "energies after REDUCE"
 405         call enerprint(energia)
 406         call flush(iout)
 407 #endif
 408         time_Reduce=time_Reduce+MPI_Wtime()-time00
 409       endif
 410       if (fg_rank.eq.0) then
 411 #endif
 412       evdw=energia(1)
 413 #ifdef SCP14
 414       evdw2=energia(2)+energia(18)
 415       evdw2_14=energia(18)
 416 #else
 417       evdw2=energia(2)
 418 #endif
 419 #ifdef SPLITELE
 420       ees=energia(3)
 421       evdw1=energia(16)
 422 #else
 423       ees=energia(3)
 424       evdw1=0.0d0
 425 #endif
 426       ecorr=energia(4)
 427       ecorr5=energia(5)
 428       ecorr6=energia(6)
 429       eel_loc=energia(7)
 430       eello_turn3=energia(8)
 431       eello_turn4=energia(9)
 432       eturn6=energia(10)
 433       ebe=energia(11)
 434       escloc=energia(12)
 435       etors=energia(13)
 436       etors_d=energia(14)
 437       ehpb=energia(15)
 438       edihcnstr=energia(19)
 439       estr=energia(17)
 440       Uconst=energia(20)
 441       esccor=energia(21)
 442       eliptran=energia(22)
 443       Eafmforce=energia(23)
 444       ethetacnstr=energia(24)
 445 #ifdef SPLITELE
 446       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 447      & +wang*ebe+wtor*etors+wscloc*escloc
 448      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 449      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 450      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 451      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 452      & +ethetacnstr
 453 #else
 454       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 455      & +wang*ebe+wtor*etors+wscloc*escloc
 456      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 457      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 458      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 459      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 460      & +Eafmforce
 461      & +ethetacnstr
 462 #endif
 463       energia(0)=etot
 464 c detecting NaNQ
 465 #ifdef ISNAN
 466 #ifdef AIX
 467       if (isnan(etot).ne.0) energia(0)=1.0d+99
 468 #else
 469       if (isnan(etot)) energia(0)=1.0d+99
 470 #endif
 471 #else
 472       i=0
 473 #ifdef WINPGI
 474       idumm=proc_proc(etot,i)
 475 #else
 476       call proc_proc(etot,i)
 477 #endif
 478       if(i.eq.1)energia(0)=1.0d+99
 479 #endif
 480 #ifdef MPI
 481       endif
 482 #endif
 483       return
 484       end
 485 c-------------------------------------------------------------------------------
 486       subroutine sum_gradient
 487       implicit real*8 (a-h,o-z)
 488       include 'DIMENSIONS'
 489 #ifndef ISNAN
 490       external proc_proc
 491 #ifdef WINPGI
 492 cMS$ATTRIBUTES C ::  proc_proc
 493 #endif
 494 #endif
 495 #ifdef MPI
 496       include 'mpif.h'
 497 #endif
 498       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 499      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 500      & ,gloc_scbuf(3,-1:maxres)
 501       include 'COMMON.SETUP'
 502       include 'COMMON.IOUNITS'
 503       include 'COMMON.FFIELD'
 504       include 'COMMON.DERIV'
 505       include 'COMMON.INTERACT'
 506       include 'COMMON.SBRIDGE'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.VAR'
 509       include 'COMMON.CONTROL'
 510       include 'COMMON.TIME1'
 511       include 'COMMON.MAXGRAD'
 512       include 'COMMON.SCCOR'
 513 #ifdef TIMING
 514       time01=MPI_Wtime()
 515 #endif
 516 #ifdef DEBUG
 517       write (iout,*) "sum_gradient gvdwc, gvdwx"
 518       do i=1,nres
 519         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 520      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 521       enddo
 522       call flush(iout)
 523 #endif
 524 #ifdef MPI
 525 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 526         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 527      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 528 #endif
 529 C
 530 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 531 C            in virtual-bond-vector coordinates
 532 C
 533 #ifdef DEBUG
 534 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 535 c      do i=1,nres-1
 536 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 537 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 538 c      enddo
 539 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 540 c      do i=1,nres-1
 541 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 542 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 543 c      enddo
 544       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 545       do i=1,nres
 546         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 547      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 548      &   g_corr5_loc(i)
 549       enddo
 550       call flush(iout)
 551 #endif
 552 #ifdef SPLITELE
 553       do i=0,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564      &                +wliptran*gliptranc(j,i)
 565      &                +gradafm(j,i)
 566      &                 +welec*gshieldc(j,i)
 567      &                 +wcorr*gshieldc_ec(j,i)
 568      &                 +wturn3*gshieldc_t3(j,i)
 569      &                 +wturn4*gshieldc_t4(j,i)
 570      &                 +wel_loc*gshieldc_ll(j,i)
 571
 572
 573         enddo
 574       enddo
 575 #else
 576       do i=0,nct
 577         do j=1,3
 578           gradbufc(j,i)=wsc*gvdwc(j,i)+
 579      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 580      &                welec*gelc_long(j,i)+
 581      &                wbond*gradb(j,i)+
 582      &                wel_loc*gel_loc_long(j,i)+
 583      &                wcorr*gradcorr_long(j,i)+
 584      &                wcorr5*gradcorr5_long(j,i)+
 585      &                wcorr6*gradcorr6_long(j,i)+
 586      &                wturn6*gcorr6_turn_long(j,i)+
 587      &                wstrain*ghpbc(j,i)
 588      &                +wliptran*gliptranc(j,i)
 589      &                +gradafm(j,i)
 590      &                 +welec*gshieldc(j,i)
 591      &                 +wcorr*gshieldc_ec(j,i)
 592      &                 +wturn4*gshieldc_t4(j,i)
 593      &                 +wel_loc*gshieldc_ll(j,i)
 594
 595
 596         enddo
 597       enddo
 598 #endif
 599 #ifdef MPI
 600       if (nfgtasks.gt.1) then
 601       time00=MPI_Wtime()
 602 #ifdef DEBUG
 603       write (iout,*) "gradbufc before allreduce"
 604       do i=1,nres
 605         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 606       enddo
 607       call flush(iout)
 608 #endif
 609       do i=0,nres
 610         do j=1,3
 611           gradbufc_sum(j,i)=gradbufc(j,i)
 612         enddo
 613       enddo
 614 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 615 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 616 c      time_reduce=time_reduce+MPI_Wtime()-time00
 617 #ifdef DEBUG
 618 c      write (iout,*) "gradbufc_sum after allreduce"
 619 c      do i=1,nres
 620 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 621 c      enddo
 622 c      call flush(iout)
 623 #endif
 624 #ifdef TIMING
 625 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 626 #endif
 627       do i=nnt,nres
 628         do k=1,3
 629           gradbufc(k,i)=0.0d0
 630         enddo
 631       enddo
 632 #ifdef DEBUG
 633       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 634       write (iout,*) (i," jgrad_start",jgrad_start(i),
 635      &                  " jgrad_end  ",jgrad_end(i),
 636      &                  i=igrad_start,igrad_end)
 637 #endif
 638 c
 639 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 640 c do not parallelize this part.
 641 c
 642 c      do i=igrad_start,igrad_end
 643 c        do j=jgrad_start(i),jgrad_end(i)
 644 c          do k=1,3
 645 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 646 c          enddo
 647 c        enddo
 648 c      enddo
 649       do j=1,3
 650         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 651       enddo
 652       do i=nres-2,-1,-1
 653         do j=1,3
 654           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 655         enddo
 656       enddo
 657 #ifdef DEBUG
 658       write (iout,*) "gradbufc after summing"
 659       do i=1,nres
 660         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 661       enddo
 662       call flush(iout)
 663 #endif
 664       else
 665 #endif
 666 #ifdef DEBUG
 667       write (iout,*) "gradbufc"
 668       do i=1,nres
 669         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 670       enddo
 671       call flush(iout)
 672 #endif
 673       do i=-1,nres
 674         do j=1,3
 675           gradbufc_sum(j,i)=gradbufc(j,i)
 676           gradbufc(j,i)=0.0d0
 677         enddo
 678       enddo
 679       do j=1,3
 680         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 681       enddo
 682       do i=nres-2,-1,-1
 683         do j=1,3
 684           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 685         enddo
 686       enddo
 687 c      do i=nnt,nres-1
 688 c        do k=1,3
 689 c          gradbufc(k,i)=0.0d0
 690 c        enddo
 691 c        do j=i+1,nres
 692 c          do k=1,3
 693 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 694 c          enddo
 695 c        enddo
 696 c      enddo
 697 #ifdef DEBUG
 698       write (iout,*) "gradbufc after summing"
 699       do i=1,nres
 700         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 701       enddo
 702       call flush(iout)
 703 #endif
 704 #ifdef MPI
 705       endif
 706 #endif
 707       do k=1,3
 708         gradbufc(k,nres)=0.0d0
 709       enddo
 710       do i=-1,nct
 711         do j=1,3
 712 #ifdef SPLITELE
 713 C          print *,gradbufc(1,13)
 714 C          print *,welec*gelc(1,13)
 715 C          print *,wel_loc*gel_loc(1,13)
 716 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 717 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 718 C          print *,wel_loc*gel_loc_long(1,13)
 719 C          print *,gradafm(1,13),"AFM"
 720           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 721      &                wel_loc*gel_loc(j,i)+
 722      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 723      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 724      &                wel_loc*gel_loc_long(j,i)+
 725      &                wcorr*gradcorr_long(j,i)+
 726      &                wcorr5*gradcorr5_long(j,i)+
 727      &                wcorr6*gradcorr6_long(j,i)+
 728      &                wturn6*gcorr6_turn_long(j,i))+
 729      &                wbond*gradb(j,i)+
 730      &                wcorr*gradcorr(j,i)+
 731      &                wturn3*gcorr3_turn(j,i)+
 732      &                wturn4*gcorr4_turn(j,i)+
 733      &                wcorr5*gradcorr5(j,i)+
 734      &                wcorr6*gradcorr6(j,i)+
 735      &                wturn6*gcorr6_turn(j,i)+
 736      &                wsccor*gsccorc(j,i)
 737      &               +wscloc*gscloc(j,i)
 738      &               +wliptran*gliptranc(j,i)
 739      &                +gradafm(j,i)
 740      &                 +welec*gshieldc(j,i)
 741      &                 +welec*gshieldc_loc(j,i)
 742      &                 +wcorr*gshieldc_ec(j,i)
 743      &                 +wcorr*gshieldc_loc_ec(j,i)
 744      &                 +wturn3*gshieldc_t3(j,i)
 745      &                 +wturn3*gshieldc_loc_t3(j,i)
 746      &                 +wturn4*gshieldc_t4(j,i)
 747      &                 +wturn4*gshieldc_loc_t4(j,i)
 748      &                 +wel_loc*gshieldc_ll(j,i)
 749      &                 +wel_loc*gshieldc_loc_ll(j,i)
 750
 751
 752
 753
 754
 755
 756 #else
 757           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 758      &                wel_loc*gel_loc(j,i)+
 759      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 760      &                welec*gelc_long(j,i)+
 761      &                wel_loc*gel_loc_long(j,i)+
 762      &                wcorr*gcorr_long(j,i)+
 763      &                wcorr5*gradcorr5_long(j,i)+
 764      &                wcorr6*gradcorr6_long(j,i)+
 765      &                wturn6*gcorr6_turn_long(j,i))+
 766      &                wbond*gradb(j,i)+
 767      &                wcorr*gradcorr(j,i)+
 768      &                wturn3*gcorr3_turn(j,i)+
 769      &                wturn4*gcorr4_turn(j,i)+
 770      &                wcorr5*gradcorr5(j,i)+
 771      &                wcorr6*gradcorr6(j,i)+
 772      &                wturn6*gcorr6_turn(j,i)+
 773      &                wsccor*gsccorc(j,i)
 774      &               +wscloc*gscloc(j,i)
 775      &               +wliptran*gliptranc(j,i)
 776      &                +gradafm(j,i)
 777      &                 +welec*gshieldc(j,i)
 778      &                 +welec*gshieldc_loc(j,i)
 779      &                 +wcorr*gshieldc_ec(j,i)
 780      &                 +wcorr*gshieldc_loc_ec(j,i)
 781      &                 +wturn3*gshieldc_t3(j,i)
 782      &                 +wturn3*gshieldc_loc_t3(j,i)
 783      &                 +wturn4*gshieldc_t4(j,i)
 784      &                 +wturn4*gshieldc_loc_t4(j,i)
 785      &                 +wel_loc*gshieldc_ll(j,i)
 786      &                 +wel_loc*gshieldc_loc_ll(j,i)
 787
 788
 789
 790
 791
 792 #endif
 793           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 794      &                  wbond*gradbx(j,i)+
 795      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 796      &                  wsccor*gsccorx(j,i)
 797      &                 +wscloc*gsclocx(j,i)
 798      &                 +wliptran*gliptranx(j,i)
 799      &                 +welec*gshieldx(j,i)
 800      &                 +wcorr*gshieldx_ec(j,i)
 801      &                 +wturn3*gshieldx_t3(j,i)
 802      &                 +wturn4*gshieldx_t4(j,i)
 803      &                 +wel_loc*gshieldx_ll(j,i)
 804
 805
 806
 807         enddo
 808       enddo
 809 #ifdef DEBUG
 810       write (iout,*) "gloc before adding corr"
 811       do i=1,4*nres
 812         write (iout,*) i,gloc(i,icg)
 813       enddo
 814 #endif
 815       do i=1,nres-3
 816         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 817      &   +wcorr5*g_corr5_loc(i)
 818      &   +wcorr6*g_corr6_loc(i)
 819      &   +wturn4*gel_loc_turn4(i)
 820      &   +wturn3*gel_loc_turn3(i)
 821      &   +wturn6*gel_loc_turn6(i)
 822      &   +wel_loc*gel_loc_loc(i)
 823       enddo
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after adding corr"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830 #ifdef MPI
 831       if (nfgtasks.gt.1) then
 832         do j=1,3
 833           do i=1,nres
 834             gradbufc(j,i)=gradc(j,i,icg)
 835             gradbufx(j,i)=gradx(j,i,icg)
 836           enddo
 837         enddo
 838         do i=1,4*nres
 839           glocbuf(i)=gloc(i,icg)
 840         enddo
 841 c#define DEBUG
 842 #ifdef DEBUG
 843       write (iout,*) "gloc_sc before reduce"
 844       do i=1,nres
 845        do j=1,1
 846         write (iout,*) i,j,gloc_sc(j,i,icg)
 847        enddo
 848       enddo
 849 #endif
 850 c#undef DEBUG
 851         do i=1,nres
 852          do j=1,3
 853           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 854          enddo
 855         enddo
 856         time00=MPI_Wtime()
 857         call MPI_Barrier(FG_COMM,IERR)
 858         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 859         time00=MPI_Wtime()
 860         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 861      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 862         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 863      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 864         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         time_reduce=time_reduce+MPI_Wtime()-time00
 867         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 868      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 869         time_reduce=time_reduce+MPI_Wtime()-time00
 870 c#define DEBUG
 871 #ifdef DEBUG
 872       write (iout,*) "gloc_sc after reduce"
 873       do i=1,nres
 874        do j=1,1
 875         write (iout,*) i,j,gloc_sc(j,i,icg)
 876        enddo
 877       enddo
 878 #endif
 879 c#undef DEBUG
 880 #ifdef DEBUG
 881       write (iout,*) "gloc after reduce"
 882       do i=1,4*nres
 883         write (iout,*) i,gloc(i,icg)
 884       enddo
 885 #endif
 886       endif
 887 #endif
 888       if (gnorm_check) then
 889 c
 890 c Compute the maximum elements of the gradient
 891 c
 892       gvdwc_max=0.0d0
 893       gvdwc_scp_max=0.0d0
 894       gelc_max=0.0d0
 895       gvdwpp_max=0.0d0
 896       gradb_max=0.0d0
 897       ghpbc_max=0.0d0
 898       gradcorr_max=0.0d0
 899       gel_loc_max=0.0d0
 900       gcorr3_turn_max=0.0d0
 901       gcorr4_turn_max=0.0d0
 902       gradcorr5_max=0.0d0
 903       gradcorr6_max=0.0d0
 904       gcorr6_turn_max=0.0d0
 905       gsccorc_max=0.0d0
 906       gscloc_max=0.0d0
 907       gvdwx_max=0.0d0
 908       gradx_scp_max=0.0d0
 909       ghpbx_max=0.0d0
 910       gradxorr_max=0.0d0
 911       gsccorx_max=0.0d0
 912       gsclocx_max=0.0d0
 913       do i=1,nct
 914         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 915         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 916         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 917         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 918      &   gvdwc_scp_max=gvdwc_scp_norm
 919         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 920         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 921         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 922         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 923         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 924         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 925         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 926         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 927         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 928         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 929         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 930         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 931         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 932      &    gcorr3_turn(1,i)))
 933         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 934      &    gcorr3_turn_max=gcorr3_turn_norm
 935         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 936      &    gcorr4_turn(1,i)))
 937         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 938      &    gcorr4_turn_max=gcorr4_turn_norm
 939         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 940         if (gradcorr5_norm.gt.gradcorr5_max)
 941      &    gradcorr5_max=gradcorr5_norm
 942         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 943         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 944         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 945      &    gcorr6_turn(1,i)))
 946         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 947      &    gcorr6_turn_max=gcorr6_turn_norm
 948         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 949         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 950         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 951         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 952         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 953         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 954         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 955         if (gradx_scp_norm.gt.gradx_scp_max)
 956      &    gradx_scp_max=gradx_scp_norm
 957         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 958         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 959         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 960         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 961         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 962         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 963         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 964         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 965       enddo
 966       if (gradout) then
 967 #ifdef AIX
 968         open(istat,file=statname,position="append")
 969 #else
 970         open(istat,file=statname,access="append")
 971 #endif
 972         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 973      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 974      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 975      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 976      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 977      &     gsccorx_max,gsclocx_max
 978         close(istat)
 979         if (gvdwc_max.gt.1.0d4) then
 980           write (iout,*) "gvdwc gvdwx gradb gradbx"
 981           do i=nnt,nct
 982             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 983      &        gradb(j,i),gradbx(j,i),j=1,3)
 984           enddo
 985           call pdbout(0.0d0,'cipiszcze',iout)
 986           call flush(iout)
 987         endif
 988       endif
 989       endif
 990 #ifdef DEBUG
 991       write (iout,*) "gradc gradx gloc"
 992       do i=1,nres
 993         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 994      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 995       enddo
 996 #endif
 997 #ifdef TIMING
 998       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 999 #endif
1000       return
1001       end
1002 c-------------------------------------------------------------------------------
1003       subroutine rescale_weights(t_bath)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.CONTROL'
1010       double precision kfac /2.4d0/
1011       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1012 c      facT=temp0/t_bath
1013 c      facT=2*temp0/(t_bath+temp0)
1014       if (rescale_mode.eq.0) then
1015         facT=1.0d0
1016         facT2=1.0d0
1017         facT3=1.0d0
1018         facT4=1.0d0
1019         facT5=1.0d0
1020       else if (rescale_mode.eq.1) then
1021         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1022         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1023         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1024         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1025         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1026       else if (rescale_mode.eq.2) then
1027         x=t_bath/temp0
1028         x2=x*x
1029         x3=x2*x
1030         x4=x3*x
1031         x5=x4*x
1032         facT=licznik/dlog(dexp(x)+dexp(-x))
1033         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1034         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1035         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1036         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1037       else
1038         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1039         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1040 #ifdef MPI
1041        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1042 #endif
1043        stop 555
1044       endif
1045       if (shield_mode.gt.0) then
1046        wscp=weights(2)*fact
1047        wsc=weights(1)*fact
1048        wvdwpp=weights(16)*fact
1049       endif
1050       welec=weights(3)*fact
1051       wcorr=weights(4)*fact3
1052       wcorr5=weights(5)*fact4
1053       wcorr6=weights(6)*fact5
1054       wel_loc=weights(7)*fact2
1055       wturn3=weights(8)*fact2
1056       wturn4=weights(9)*fact3
1057       wturn6=weights(10)*fact5
1058       wtor=weights(13)*fact
1059       wtor_d=weights(14)*fact2
1060       wsccor=weights(21)*fact
1061
1062       return
1063       end
1064 C------------------------------------------------------------------------
1065       subroutine enerprint(energia)
1066       implicit real*8 (a-h,o-z)
1067       include 'DIMENSIONS'
1068       include 'COMMON.IOUNITS'
1069       include 'COMMON.FFIELD'
1070       include 'COMMON.SBRIDGE'
1071       include 'COMMON.MD'
1072       double precision energia(0:n_ene)
1073       etot=energia(0)
1074       evdw=energia(1)
1075       evdw2=energia(2)
1076 #ifdef SCP14
1077       evdw2=energia(2)+energia(18)
1078 #else
1079       evdw2=energia(2)
1080 #endif
1081       ees=energia(3)
1082 #ifdef SPLITELE
1083       evdw1=energia(16)
1084 #endif
1085       ecorr=energia(4)
1086       ecorr5=energia(5)
1087       ecorr6=energia(6)
1088       eel_loc=energia(7)
1089       eello_turn3=energia(8)
1090       eello_turn4=energia(9)
1091       eello_turn6=energia(10)
1092       ebe=energia(11)
1093       escloc=energia(12)
1094       etors=energia(13)
1095       etors_d=energia(14)
1096       ehpb=energia(15)
1097       edihcnstr=energia(19)
1098       estr=energia(17)
1099       Uconst=energia(20)
1100       esccor=energia(21)
1101       eliptran=energia(22)
1102       Eafmforce=energia(23)
1103       ethetacnstr=energia(24)
1104 #ifdef SPLITELE
1105       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1106      &  estr,wbond,ebe,wang,
1107      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1108      &  ecorr,wcorr,
1109      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1110      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1111      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1112      &  etot
1113    10 format (/'Virtual-chain energies:'//
1114      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1115      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1116      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1117      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1118      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1119      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1120      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1121      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1122      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1123      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1124      & ' (SS bridges & dist. cnstr.)'/
1125      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1126      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1127      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1128      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1129      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1130      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1131      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1132      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1133      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1134      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1135      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1136      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1137      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1138      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1139      & 'ETOT=  ',1pE16.6,' (total)')
1140
1141 #else
1142       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1143      &  estr,wbond,ebe,wang,
1144      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1145      &  ecorr,wcorr,
1146      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1147      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1148      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1149      &  etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1154      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1155      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1156      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1157      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1158      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1159      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1160      & ' (SS bridges & dist. cnstr.)'/
1161      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1162      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1163      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1164      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1165      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1166      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1167      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1168      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1169      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1170      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1171      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1172      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1173      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1174      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1175      & 'ETOT=  ',1pE16.6,' (total)')
1176 #endif
1177       return
1178       end
1179 C-----------------------------------------------------------------------
1180       subroutine elj(evdw)
1181 C
1182 C This subroutine calculates the interaction energy of nonbonded side chains
1183 C assuming the LJ potential of interaction.
1184 C
1185       implicit real*8 (a-h,o-z)
1186       include 'DIMENSIONS'
1187       parameter (accur=1.0d-10)
1188       include 'COMMON.GEO'
1189       include 'COMMON.VAR'
1190       include 'COMMON.LOCAL'
1191       include 'COMMON.CHAIN'
1192       include 'COMMON.DERIV'
1193       include 'COMMON.INTERACT'
1194       include 'COMMON.TORSION'
1195       include 'COMMON.SBRIDGE'
1196       include 'COMMON.NAMES'
1197       include 'COMMON.IOUNITS'
1198       include 'COMMON.CONTACTS'
1199       dimension gg(3)
1200 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1201       evdw=0.0D0
1202       do i=iatsc_s,iatsc_e
1203         itypi=iabs(itype(i))
1204         if (itypi.eq.ntyp1) cycle
1205         itypi1=iabs(itype(i+1))
1206         xi=c(1,nres+i)
1207         yi=c(2,nres+i)
1208         zi=c(3,nres+i)
1209 C Change 12/1/95
1210         num_conti=0
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1216 cd   &                  'iend=',iend(i,iint)
1217           do j=istart(i,iint),iend(i,iint)
1218             itypj=iabs(itype(j))
1219             if (itypj.eq.ntyp1) cycle
1220             xj=c(1,nres+j)-xi
1221             yj=c(2,nres+j)-yi
1222             zj=c(3,nres+j)-zi
1223 C Change 12/1/95 to calculate four-body interactions
1224             rij=xj*xj+yj*yj+zj*zj
1225             rrij=1.0D0/rij
1226 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1227             eps0ij=eps(itypi,itypj)
1228             fac=rrij**expon2
1229 C have you changed here?
1230             e1=fac*fac*aa
1231             e2=fac*bb
1232             evdwij=e1+e2
1233 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1234 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1235 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1236 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1237 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1238 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1239             evdw=evdw+evdwij
1240 C
1241 C Calculate the components of the gradient in DC and X
1242 C
1243             fac=-rrij*(e1+evdwij)
1244             gg(1)=xj*fac
1245             gg(2)=yj*fac
1246             gg(3)=zj*fac
1247             do k=1,3
1248               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1249               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1250               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1251               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1252             enddo
1253 cgrad            do k=i,j-1
1254 cgrad              do l=1,3
1255 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1256 cgrad              enddo
1257 cgrad            enddo
1258 C
1259 C 12/1/95, revised on 5/20/97
1260 C
1261 C Calculate the contact function. The ith column of the array JCONT will
1262 C contain the numbers of atoms that make contacts with the atom I (of numbers
1263 C greater than I). The arrays FACONT and GACONT will contain the values of
1264 C the contact function and its derivative.
1265 C
1266 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1267 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1268 C Uncomment next line, if the correlation interactions are contact function only
1269             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1270               rij=dsqrt(rij)
1271               sigij=sigma(itypi,itypj)
1272               r0ij=rs0(itypi,itypj)
1273 C
1274 C Check whether the SC's are not too far to make a contact.
1275 C
1276               rcut=1.5d0*r0ij
1277               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1278 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1279 C
1280               if (fcont.gt.0.0D0) then
1281 C If the SC-SC distance if close to sigma, apply spline.
1282 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1283 cAdam &             fcont1,fprimcont1)
1284 cAdam           fcont1=1.0d0-fcont1
1285 cAdam           if (fcont1.gt.0.0d0) then
1286 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1287 cAdam             fcont=fcont*fcont1
1288 cAdam           endif
1289 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1290 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1291 cga             do k=1,3
1292 cga               gg(k)=gg(k)*eps0ij
1293 cga             enddo
1294 cga             eps0ij=-evdwij*eps0ij
1295 C Uncomment for AL's type of SC correlation interactions.
1296 cadam           eps0ij=-evdwij
1297                 num_conti=num_conti+1
1298                 jcont(num_conti,i)=j
1299                 facont(num_conti,i)=fcont*eps0ij
1300                 fprimcont=eps0ij*fprimcont/rij
1301                 fcont=expon*fcont
1302 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1303 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1304 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1305 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1306                 gacont(1,num_conti,i)=-fprimcont*xj
1307                 gacont(2,num_conti,i)=-fprimcont*yj
1308                 gacont(3,num_conti,i)=-fprimcont*zj
1309 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1310 cd              write (iout,'(2i3,3f10.5)')
1311 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1312               endif
1313             endif
1314           enddo      ! j
1315         enddo        ! iint
1316 C Change 12/1/95
1317         num_cont(i)=num_conti
1318       enddo          ! i
1319       do i=1,nct
1320         do j=1,3
1321           gvdwc(j,i)=expon*gvdwc(j,i)
1322           gvdwx(j,i)=expon*gvdwx(j,i)
1323         enddo
1324       enddo
1325 C******************************************************************************
1326 C
1327 C                              N O T E !!!
1328 C
1329 C To save time, the factor of EXPON has been extracted from ALL components
1330 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1331 C use!
1332 C
1333 C******************************************************************************
1334       return
1335       end
1336 C-----------------------------------------------------------------------------
1337       subroutine eljk(evdw)
1338 C
1339 C This subroutine calculates the interaction energy of nonbonded side chains
1340 C assuming the LJK potential of interaction.
1341 C
1342       implicit real*8 (a-h,o-z)
1343       include 'DIMENSIONS'
1344       include 'COMMON.GEO'
1345       include 'COMMON.VAR'
1346       include 'COMMON.LOCAL'
1347       include 'COMMON.CHAIN'
1348       include 'COMMON.DERIV'
1349       include 'COMMON.INTERACT'
1350       include 'COMMON.IOUNITS'
1351       include 'COMMON.NAMES'
1352       dimension gg(3)
1353       logical scheck
1354 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1355       evdw=0.0D0
1356       do i=iatsc_s,iatsc_e
1357         itypi=iabs(itype(i))
1358         if (itypi.eq.ntyp1) cycle
1359         itypi1=iabs(itype(i+1))
1360         xi=c(1,nres+i)
1361         yi=c(2,nres+i)
1362         zi=c(3,nres+i)
1363 C
1364 C Calculate SC interaction energy.
1365 C
1366         do iint=1,nint_gr(i)
1367           do j=istart(i,iint),iend(i,iint)
1368             itypj=iabs(itype(j))
1369             if (itypj.eq.ntyp1) cycle
1370             xj=c(1,nres+j)-xi
1371             yj=c(2,nres+j)-yi
1372             zj=c(3,nres+j)-zi
1373             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1374             fac_augm=rrij**expon
1375             e_augm=augm(itypi,itypj)*fac_augm
1376             r_inv_ij=dsqrt(rrij)
1377             rij=1.0D0/r_inv_ij
1378             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1379             fac=r_shift_inv**expon
1380 C have you changed here?
1381             e1=fac*fac*aa
1382             e2=fac*bb
1383             evdwij=e_augm+e1+e2
1384 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1385 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1386 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1387 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1388 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1389 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1390 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1391             evdw=evdw+evdwij
1392 C
1393 C Calculate the components of the gradient in DC and X
1394 C
1395             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1396             gg(1)=xj*fac
1397             gg(2)=yj*fac
1398             gg(3)=zj*fac
1399             do k=1,3
1400               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1401               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1402               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1403               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1404             enddo
1405 cgrad            do k=i,j-1
1406 cgrad              do l=1,3
1407 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1408 cgrad              enddo
1409 cgrad            enddo
1410           enddo      ! j
1411         enddo        ! iint
1412       enddo          ! i
1413       do i=1,nct
1414         do j=1,3
1415           gvdwc(j,i)=expon*gvdwc(j,i)
1416           gvdwx(j,i)=expon*gvdwx(j,i)
1417         enddo
1418       enddo
1419       return
1420       end
1421 C-----------------------------------------------------------------------------
1422       subroutine ebp(evdw)
1423 C
1424 C This subroutine calculates the interaction energy of nonbonded side chains
1425 C assuming the Berne-Pechukas potential of interaction.
1426 C
1427       implicit real*8 (a-h,o-z)
1428       include 'DIMENSIONS'
1429       include 'COMMON.GEO'
1430       include 'COMMON.VAR'
1431       include 'COMMON.LOCAL'
1432       include 'COMMON.CHAIN'
1433       include 'COMMON.DERIV'
1434       include 'COMMON.NAMES'
1435       include 'COMMON.INTERACT'
1436       include 'COMMON.IOUNITS'
1437       include 'COMMON.CALC'
1438       common /srutu/ icall
1439 c     double precision rrsave(maxdim)
1440       logical lprn
1441       evdw=0.0D0
1442 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1443       evdw=0.0D0
1444 c     if (icall.eq.0) then
1445 c       lprn=.true.
1446 c     else
1447         lprn=.false.
1448 c     endif
1449       ind=0
1450       do i=iatsc_s,iatsc_e
1451         itypi=iabs(itype(i))
1452         if (itypi.eq.ntyp1) cycle
1453         itypi1=iabs(itype(i+1))
1454         xi=c(1,nres+i)
1455         yi=c(2,nres+i)
1456         zi=c(3,nres+i)
1457         dxi=dc_norm(1,nres+i)
1458         dyi=dc_norm(2,nres+i)
1459         dzi=dc_norm(3,nres+i)
1460 c        dsci_inv=dsc_inv(itypi)
1461         dsci_inv=vbld_inv(i+nres)
1462 C
1463 C Calculate SC interaction energy.
1464 C
1465         do iint=1,nint_gr(i)
1466           do j=istart(i,iint),iend(i,iint)
1467             ind=ind+1
1468             itypj=iabs(itype(j))
1469             if (itypj.eq.ntyp1) cycle
1470 c            dscj_inv=dsc_inv(itypj)
1471             dscj_inv=vbld_inv(j+nres)
1472             chi1=chi(itypi,itypj)
1473             chi2=chi(itypj,itypi)
1474             chi12=chi1*chi2
1475             chip1=chip(itypi)
1476             chip2=chip(itypj)
1477             chip12=chip1*chip2
1478             alf1=alp(itypi)
1479             alf2=alp(itypj)
1480             alf12=0.5D0*(alf1+alf2)
1481 C For diagnostics only!!!
1482 c           chi1=0.0D0
1483 c           chi2=0.0D0
1484 c           chi12=0.0D0
1485 c           chip1=0.0D0
1486 c           chip2=0.0D0
1487 c           chip12=0.0D0
1488 c           alf1=0.0D0
1489 c           alf2=0.0D0
1490 c           alf12=0.0D0
1491             xj=c(1,nres+j)-xi
1492             yj=c(2,nres+j)-yi
1493             zj=c(3,nres+j)-zi
1494             dxj=dc_norm(1,nres+j)
1495             dyj=dc_norm(2,nres+j)
1496             dzj=dc_norm(3,nres+j)
1497             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1498 cd          if (icall.eq.0) then
1499 cd            rrsave(ind)=rrij
1500 cd          else
1501 cd            rrij=rrsave(ind)
1502 cd          endif
1503             rij=dsqrt(rrij)
1504 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1505             call sc_angular
1506 C Calculate whole angle-dependent part of epsilon and contributions
1507 C to its derivatives
1508 C have you changed here?
1509             fac=(rrij*sigsq)**expon2
1510             e1=fac*fac*aa
1511             e2=fac*bb
1512             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1513             eps2der=evdwij*eps3rt
1514             eps3der=evdwij*eps2rt
1515             evdwij=evdwij*eps2rt*eps3rt
1516             evdw=evdw+evdwij
1517             if (lprn) then
1518             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1519             epsi=bb**2/aa
1520 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1521 cd     &        restyp(itypi),i,restyp(itypj),j,
1522 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1523 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1524 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1525 cd     &        evdwij
1526             endif
1527 C Calculate gradient components.
1528             e1=e1*eps1*eps2rt**2*eps3rt**2
1529             fac=-expon*(e1+evdwij)
1530             sigder=fac/sigsq
1531             fac=rrij*fac
1532 C Calculate radial part of the gradient
1533             gg(1)=xj*fac
1534             gg(2)=yj*fac
1535             gg(3)=zj*fac
1536 C Calculate the angular part of the gradient and sum add the contributions
1537 C to the appropriate components of the Cartesian gradient.
1538             call sc_grad
1539           enddo      ! j
1540         enddo        ! iint
1541       enddo          ! i
1542 c     stop
1543       return
1544       end
1545 C-----------------------------------------------------------------------------
1546       subroutine egb(evdw)
1547 C
1548 C This subroutine calculates the interaction energy of nonbonded side chains
1549 C assuming the Gay-Berne potential of interaction.
1550 C
1551       implicit real*8 (a-h,o-z)
1552       include 'DIMENSIONS'
1553       include 'COMMON.GEO'
1554       include 'COMMON.VAR'
1555       include 'COMMON.LOCAL'
1556       include 'COMMON.CHAIN'
1557       include 'COMMON.DERIV'
1558       include 'COMMON.NAMES'
1559       include 'COMMON.INTERACT'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.CALC'
1562       include 'COMMON.CONTROL'
1563       include 'COMMON.SPLITELE'
1564       include 'COMMON.SBRIDGE'
1565       logical lprn
1566       integer xshift,yshift,zshift
1567
1568       evdw=0.0D0
1569 ccccc      energy_dec=.false.
1570 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1571       evdw=0.0D0
1572       lprn=.false.
1573 c     if (icall.eq.0) lprn=.false.
1574       ind=0
1575 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1576 C we have the original box)
1577 C      do xshift=-1,1
1578 C      do yshift=-1,1
1579 C      do zshift=-1,1
1580       do i=iatsc_s,iatsc_e
1581         itypi=iabs(itype(i))
1582         if (itypi.eq.ntyp1) cycle
1583         itypi1=iabs(itype(i+1))
1584         xi=c(1,nres+i)
1585         yi=c(2,nres+i)
1586         zi=c(3,nres+i)
1587 C Return atom into box, boxxsize is size of box in x dimension
1588 c  134   continue
1589 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1590 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1591 C Condition for being inside the proper box
1592 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1593 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1594 c        go to 134
1595 c        endif
1596 c  135   continue
1597 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1598 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1599 C Condition for being inside the proper box
1600 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1601 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1602 c        go to 135
1603 c        endif
1604 c  136   continue
1605 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1606 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1607 C Condition for being inside the proper box
1608 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1609 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1610 c        go to 136
1611 c        endif
1612           xi=mod(xi,boxxsize)
1613           if (xi.lt.0) xi=xi+boxxsize
1614           yi=mod(yi,boxysize)
1615           if (yi.lt.0) yi=yi+boxysize
1616           zi=mod(zi,boxzsize)
1617           if (zi.lt.0) zi=zi+boxzsize
1618 C define scaling factor for lipids
1619
1620 C        if (positi.le.0) positi=positi+boxzsize
1621 C        print *,i
1622 C first for peptide groups
1623 c for each residue check if it is in lipid or lipid water border area
1624        if ((zi.gt.bordlipbot)
1625      &.and.(zi.lt.bordliptop)) then
1626 C the energy transfer exist
1627         if (zi.lt.buflipbot) then
1628 C what fraction I am in
1629          fracinbuf=1.0d0-
1630      &        ((zi-bordlipbot)/lipbufthick)
1631 C lipbufthick is thickenes of lipid buffore
1632          sslipi=sscalelip(fracinbuf)
1633          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1634         elseif (zi.gt.bufliptop) then
1635          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1636          sslipi=sscalelip(fracinbuf)
1637          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1638         else
1639          sslipi=1.0d0
1640          ssgradlipi=0.0
1641         endif
1642        else
1643          sslipi=0.0d0
1644          ssgradlipi=0.0
1645        endif
1646
1647 C          xi=xi+xshift*boxxsize
1648 C          yi=yi+yshift*boxysize
1649 C          zi=zi+zshift*boxzsize
1650
1651         dxi=dc_norm(1,nres+i)
1652         dyi=dc_norm(2,nres+i)
1653         dzi=dc_norm(3,nres+i)
1654 c        dsci_inv=dsc_inv(itypi)
1655         dsci_inv=vbld_inv(i+nres)
1656 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1657 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1658 C
1659 C Calculate SC interaction energy.
1660 C
1661         do iint=1,nint_gr(i)
1662           do j=istart(i,iint),iend(i,iint)
1663             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1664
1665 c              write(iout,*) "PRZED ZWYKLE", evdwij
1666               call dyn_ssbond_ene(i,j,evdwij)
1667 c              write(iout,*) "PO ZWYKLE", evdwij
1668
1669               evdw=evdw+evdwij
1670               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1671      &                        'evdw',i,j,evdwij,' ss'
1672 C triple bond artifac removal
1673              do k=j+1,iend(i,iint)
1674 C search over all next residues
1675               if (dyn_ss_mask(k)) then
1676 C check if they are cysteins
1677 C              write(iout,*) 'k=',k
1678
1679 c              write(iout,*) "PRZED TRI", evdwij
1680                evdwij_przed_tri=evdwij
1681               call triple_ssbond_ene(i,j,k,evdwij)
1682 c               if(evdwij_przed_tri.ne.evdwij) then
1683 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1684 c               endif
1685
1686 c              write(iout,*) "PO TRI", evdwij
1687 C call the energy function that removes the artifical triple disulfide
1688 C bond the soubroutine is located in ssMD.F
1689               evdw=evdw+evdwij
1690               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1691      &                        'evdw',i,j,evdwij,'tss'
1692               endif!dyn_ss_mask(k)
1693              enddo! k
1694             ELSE
1695             ind=ind+1
1696             itypj=iabs(itype(j))
1697             if (itypj.eq.ntyp1) cycle
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1701 c     &       1.0d0/vbld(j+nres)
1702 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1703             sig0ij=sigma(itypi,itypj)
1704             chi1=chi(itypi,itypj)
1705             chi2=chi(itypj,itypi)
1706             chi12=chi1*chi2
1707             chip1=chip(itypi)
1708             chip2=chip(itypj)
1709             chip12=chip1*chip2
1710             alf1=alp(itypi)
1711             alf2=alp(itypj)
1712             alf12=0.5D0*(alf1+alf2)
1713 C For diagnostics only!!!
1714 c           chi1=0.0D0
1715 c           chi2=0.0D0
1716 c           chi12=0.0D0
1717 c           chip1=0.0D0
1718 c           chip2=0.0D0
1719 c           chip12=0.0D0
1720 c           alf1=0.0D0
1721 c           alf2=0.0D0
1722 c           alf12=0.0D0
1723             xj=c(1,nres+j)
1724             yj=c(2,nres+j)
1725             zj=c(3,nres+j)
1726 C Return atom J into box the original box
1727 c  137   continue
1728 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1729 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1730 C Condition for being inside the proper box
1731 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1732 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1733 c        go to 137
1734 c        endif
1735 c  138   continue
1736 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1737 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1738 C Condition for being inside the proper box
1739 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1740 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1741 c        go to 138
1742 c        endif
1743 c  139   continue
1744 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1745 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1746 C Condition for being inside the proper box
1747 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1748 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1749 c        go to 139
1750 c        endif
1751           xj=mod(xj,boxxsize)
1752           if (xj.lt.0) xj=xj+boxxsize
1753           yj=mod(yj,boxysize)
1754           if (yj.lt.0) yj=yj+boxysize
1755           zj=mod(zj,boxzsize)
1756           if (zj.lt.0) zj=zj+boxzsize
1757        if ((zj.gt.bordlipbot)
1758      &.and.(zj.lt.bordliptop)) then
1759 C the energy transfer exist
1760         if (zj.lt.buflipbot) then
1761 C what fraction I am in
1762          fracinbuf=1.0d0-
1763      &        ((zj-bordlipbot)/lipbufthick)
1764 C lipbufthick is thickenes of lipid buffore
1765          sslipj=sscalelip(fracinbuf)
1766          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1767         elseif (zj.gt.bufliptop) then
1768          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1769          sslipj=sscalelip(fracinbuf)
1770          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1771         else
1772          sslipj=1.0d0
1773          ssgradlipj=0.0
1774         endif
1775        else
1776          sslipj=0.0d0
1777          ssgradlipj=0.0
1778        endif
1779       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1780      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1781       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1782      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1783 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1784 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1785 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1786 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1787 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1788       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1789       xj_safe=xj
1790       yj_safe=yj
1791       zj_safe=zj
1792       subchap=0
1793       do xshift=-1,1
1794       do yshift=-1,1
1795       do zshift=-1,1
1796           xj=xj_safe+xshift*boxxsize
1797           yj=yj_safe+yshift*boxysize
1798           zj=zj_safe+zshift*boxzsize
1799           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1800           if(dist_temp.lt.dist_init) then
1801             dist_init=dist_temp
1802             xj_temp=xj
1803             yj_temp=yj
1804             zj_temp=zj
1805             subchap=1
1806           endif
1807        enddo
1808        enddo
1809        enddo
1810        if (subchap.eq.1) then
1811           xj=xj_temp-xi
1812           yj=yj_temp-yi
1813           zj=zj_temp-zi
1814        else
1815           xj=xj_safe-xi
1816           yj=yj_safe-yi
1817           zj=zj_safe-zi
1818        endif
1819             dxj=dc_norm(1,nres+j)
1820             dyj=dc_norm(2,nres+j)
1821             dzj=dc_norm(3,nres+j)
1822 C            xj=xj-xi
1823 C            yj=yj-yi
1824 C            zj=zj-zi
1825 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1826 c            write (iout,*) "j",j," dc_norm",
1827 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1828             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1829             rij=dsqrt(rrij)
1830             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1831             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1832
1833 c            write (iout,'(a7,4f8.3)')
1834 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1835             if (sss.gt.0.0d0) then
1836 C Calculate angle-dependent terms of energy and contributions to their
1837 C derivatives.
1838             call sc_angular
1839             sigsq=1.0D0/sigsq
1840             sig=sig0ij*dsqrt(sigsq)
1841             rij_shift=1.0D0/rij-sig+sig0ij
1842 c for diagnostics; uncomment
1843 c            rij_shift=1.2*sig0ij
1844 C I hate to put IF's in the loops, but here don't have another choice!!!!
1845             if (rij_shift.le.0.0D0) then
1846               evdw=1.0D20
1847 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1848 cd     &        restyp(itypi),i,restyp(itypj),j,
1849 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1850               return
1851             endif
1852             sigder=-sig*sigsq
1853 c---------------------------------------------------------------
1854             rij_shift=1.0D0/rij_shift
1855             fac=rij_shift**expon
1856 C here to start with
1857 C            if (c(i,3).gt.
1858             faclip=fac
1859             e1=fac*fac*aa
1860             e2=fac*bb
1861             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1862             eps2der=evdwij*eps3rt
1863             eps3der=evdwij*eps2rt
1864 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1865 C     &((sslipi+sslipj)/2.0d0+
1866 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1867 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1868 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1869             evdwij=evdwij*eps2rt*eps3rt
1870             evdw=evdw+evdwij*sss
1871             if (lprn) then
1872             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1873             epsi=bb**2/aa
1874             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1875      &        restyp(itypi),i,restyp(itypj),j,
1876      &        epsi,sigm,chi1,chi2,chip1,chip2,
1877      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1878      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1879      &        evdwij
1880             endif
1881
1882             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1883      &                        'evdw',i,j,evdwij
1884
1885 C Calculate gradient components.
1886             e1=e1*eps1*eps2rt**2*eps3rt**2
1887             fac=-expon*(e1+evdwij)*rij_shift
1888             sigder=fac*sigder
1889             fac=rij*fac
1890 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1891 c     &      evdwij,fac,sigma(itypi,itypj),expon
1892             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1893 c            fac=0.0d0
1894 C Calculate the radial part of the gradient
1895             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1896      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1897      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1898      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1899             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1900             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1901 C            gg_lipi(3)=0.0d0
1902 C            gg_lipj(3)=0.0d0
1903             gg(1)=xj*fac
1904             gg(2)=yj*fac
1905             gg(3)=zj*fac
1906 C Calculate angular part of the gradient.
1907             call sc_grad
1908             endif
1909             ENDIF    ! dyn_ss
1910           enddo      ! j
1911         enddo        ! iint
1912       enddo          ! i
1913 C      enddo          ! zshift
1914 C      enddo          ! yshift
1915 C      enddo          ! xshift
1916 c      write (iout,*) "Number of loop steps in EGB:",ind
1917 cccc      energy_dec=.false.
1918       return
1919       end
1920 C-----------------------------------------------------------------------------
1921       subroutine egbv(evdw)
1922 C
1923 C This subroutine calculates the interaction energy of nonbonded side chains
1924 C assuming the Gay-Berne-Vorobjev potential of interaction.
1925 C
1926       implicit real*8 (a-h,o-z)
1927       include 'DIMENSIONS'
1928       include 'COMMON.GEO'
1929       include 'COMMON.VAR'
1930       include 'COMMON.LOCAL'
1931       include 'COMMON.CHAIN'
1932       include 'COMMON.DERIV'
1933       include 'COMMON.NAMES'
1934       include 'COMMON.INTERACT'
1935       include 'COMMON.IOUNITS'
1936       include 'COMMON.CALC'
1937       common /srutu/ icall
1938       logical lprn
1939       evdw=0.0D0
1940 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1941       evdw=0.0D0
1942       lprn=.false.
1943 c     if (icall.eq.0) lprn=.true.
1944       ind=0
1945       do i=iatsc_s,iatsc_e
1946         itypi=iabs(itype(i))
1947         if (itypi.eq.ntyp1) cycle
1948         itypi1=iabs(itype(i+1))
1949         xi=c(1,nres+i)
1950         yi=c(2,nres+i)
1951         zi=c(3,nres+i)
1952           xi=mod(xi,boxxsize)
1953           if (xi.lt.0) xi=xi+boxxsize
1954           yi=mod(yi,boxysize)
1955           if (yi.lt.0) yi=yi+boxysize
1956           zi=mod(zi,boxzsize)
1957           if (zi.lt.0) zi=zi+boxzsize
1958 C define scaling factor for lipids
1959
1960 C        if (positi.le.0) positi=positi+boxzsize
1961 C        print *,i
1962 C first for peptide groups
1963 c for each residue check if it is in lipid or lipid water border area
1964        if ((zi.gt.bordlipbot)
1965      &.and.(zi.lt.bordliptop)) then
1966 C the energy transfer exist
1967         if (zi.lt.buflipbot) then
1968 C what fraction I am in
1969          fracinbuf=1.0d0-
1970      &        ((zi-bordlipbot)/lipbufthick)
1971 C lipbufthick is thickenes of lipid buffore
1972          sslipi=sscalelip(fracinbuf)
1973          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1974         elseif (zi.gt.bufliptop) then
1975          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1976          sslipi=sscalelip(fracinbuf)
1977          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1978         else
1979          sslipi=1.0d0
1980          ssgradlipi=0.0
1981         endif
1982        else
1983          sslipi=0.0d0
1984          ssgradlipi=0.0
1985        endif
1986
1987         dxi=dc_norm(1,nres+i)
1988         dyi=dc_norm(2,nres+i)
1989         dzi=dc_norm(3,nres+i)
1990 c        dsci_inv=dsc_inv(itypi)
1991         dsci_inv=vbld_inv(i+nres)
1992 C
1993 C Calculate SC interaction energy.
1994 C
1995         do iint=1,nint_gr(i)
1996           do j=istart(i,iint),iend(i,iint)
1997             ind=ind+1
1998             itypj=iabs(itype(j))
1999             if (itypj.eq.ntyp1) cycle
2000 c            dscj_inv=dsc_inv(itypj)
2001             dscj_inv=vbld_inv(j+nres)
2002             sig0ij=sigma(itypi,itypj)
2003             r0ij=r0(itypi,itypj)
2004             chi1=chi(itypi,itypj)
2005             chi2=chi(itypj,itypi)
2006             chi12=chi1*chi2
2007             chip1=chip(itypi)
2008             chip2=chip(itypj)
2009             chip12=chip1*chip2
2010             alf1=alp(itypi)
2011             alf2=alp(itypj)
2012             alf12=0.5D0*(alf1+alf2)
2013 C For diagnostics only!!!
2014 c           chi1=0.0D0
2015 c           chi2=0.0D0
2016 c           chi12=0.0D0
2017 c           chip1=0.0D0
2018 c           chip2=0.0D0
2019 c           chip12=0.0D0
2020 c           alf1=0.0D0
2021 c           alf2=0.0D0
2022 c           alf12=0.0D0
2023 C            xj=c(1,nres+j)-xi
2024 C            yj=c(2,nres+j)-yi
2025 C            zj=c(3,nres+j)-zi
2026           xj=mod(xj,boxxsize)
2027           if (xj.lt.0) xj=xj+boxxsize
2028           yj=mod(yj,boxysize)
2029           if (yj.lt.0) yj=yj+boxysize
2030           zj=mod(zj,boxzsize)
2031           if (zj.lt.0) zj=zj+boxzsize
2032        if ((zj.gt.bordlipbot)
2033      &.and.(zj.lt.bordliptop)) then
2034 C the energy transfer exist
2035         if (zj.lt.buflipbot) then
2036 C what fraction I am in
2037          fracinbuf=1.0d0-
2038      &        ((zj-bordlipbot)/lipbufthick)
2039 C lipbufthick is thickenes of lipid buffore
2040          sslipj=sscalelip(fracinbuf)
2041          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2042         elseif (zj.gt.bufliptop) then
2043          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2044          sslipj=sscalelip(fracinbuf)
2045          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2046         else
2047          sslipj=1.0d0
2048          ssgradlipj=0.0
2049         endif
2050        else
2051          sslipj=0.0d0
2052          ssgradlipj=0.0
2053        endif
2054       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2055      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2056       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2057      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2058 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2059 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2060 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2061       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2062       xj_safe=xj
2063       yj_safe=yj
2064       zj_safe=zj
2065       subchap=0
2066       do xshift=-1,1
2067       do yshift=-1,1
2068       do zshift=-1,1
2069           xj=xj_safe+xshift*boxxsize
2070           yj=yj_safe+yshift*boxysize
2071           zj=zj_safe+zshift*boxzsize
2072           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2073           if(dist_temp.lt.dist_init) then
2074             dist_init=dist_temp
2075             xj_temp=xj
2076             yj_temp=yj
2077             zj_temp=zj
2078             subchap=1
2079           endif
2080        enddo
2081        enddo
2082        enddo
2083        if (subchap.eq.1) then
2084           xj=xj_temp-xi
2085           yj=yj_temp-yi
2086           zj=zj_temp-zi
2087        else
2088           xj=xj_safe-xi
2089           yj=yj_safe-yi
2090           zj=zj_safe-zi
2091        endif
2092             dxj=dc_norm(1,nres+j)
2093             dyj=dc_norm(2,nres+j)
2094             dzj=dc_norm(3,nres+j)
2095             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2096             rij=dsqrt(rrij)
2097 C Calculate angle-dependent terms of energy and contributions to their
2098 C derivatives.
2099             call sc_angular
2100             sigsq=1.0D0/sigsq
2101             sig=sig0ij*dsqrt(sigsq)
2102             rij_shift=1.0D0/rij-sig+r0ij
2103 C I hate to put IF's in the loops, but here don't have another choice!!!!
2104             if (rij_shift.le.0.0D0) then
2105               evdw=1.0D20
2106               return
2107             endif
2108             sigder=-sig*sigsq
2109 c---------------------------------------------------------------
2110             rij_shift=1.0D0/rij_shift
2111             fac=rij_shift**expon
2112             e1=fac*fac*aa
2113             e2=fac*bb
2114             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2115             eps2der=evdwij*eps3rt
2116             eps3der=evdwij*eps2rt
2117             fac_augm=rrij**expon
2118             e_augm=augm(itypi,itypj)*fac_augm
2119             evdwij=evdwij*eps2rt*eps3rt
2120             evdw=evdw+evdwij+e_augm
2121             if (lprn) then
2122             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2123             epsi=bb**2/aa
2124             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2125      &        restyp(itypi),i,restyp(itypj),j,
2126      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2127      &        chi1,chi2,chip1,chip2,
2128      &        eps1,eps2rt**2,eps3rt**2,
2129      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2130      &        evdwij+e_augm
2131             endif
2132 C Calculate gradient components.
2133             e1=e1*eps1*eps2rt**2*eps3rt**2
2134             fac=-expon*(e1+evdwij)*rij_shift
2135             sigder=fac*sigder
2136             fac=rij*fac-2*expon*rrij*e_augm
2137             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2138 C Calculate the radial part of the gradient
2139             gg(1)=xj*fac
2140             gg(2)=yj*fac
2141             gg(3)=zj*fac
2142 C Calculate angular part of the gradient.
2143             call sc_grad
2144           enddo      ! j
2145         enddo        ! iint
2146       enddo          ! i
2147       end
2148 C-----------------------------------------------------------------------------
2149       subroutine sc_angular
2150 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2151 C om12. Called by ebp, egb, and egbv.
2152       implicit none
2153       include 'COMMON.CALC'
2154       include 'COMMON.IOUNITS'
2155       erij(1)=xj*rij
2156       erij(2)=yj*rij
2157       erij(3)=zj*rij
2158       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2159       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2160       om12=dxi*dxj+dyi*dyj+dzi*dzj
2161       chiom12=chi12*om12
2162 C Calculate eps1(om12) and its derivative in om12
2163       faceps1=1.0D0-om12*chiom12
2164       faceps1_inv=1.0D0/faceps1
2165       eps1=dsqrt(faceps1_inv)
2166 C Following variable is eps1*deps1/dom12
2167       eps1_om12=faceps1_inv*chiom12
2168 c diagnostics only
2169 c      faceps1_inv=om12
2170 c      eps1=om12
2171 c      eps1_om12=1.0d0
2172 c      write (iout,*) "om12",om12," eps1",eps1
2173 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2174 C and om12.
2175       om1om2=om1*om2
2176       chiom1=chi1*om1
2177       chiom2=chi2*om2
2178       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2179       sigsq=1.0D0-facsig*faceps1_inv
2180       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2181       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2182       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2183 c diagnostics only
2184 c      sigsq=1.0d0
2185 c      sigsq_om1=0.0d0
2186 c      sigsq_om2=0.0d0
2187 c      sigsq_om12=0.0d0
2188 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2189 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2190 c     &    " eps1",eps1
2191 C Calculate eps2 and its derivatives in om1, om2, and om12.
2192       chipom1=chip1*om1
2193       chipom2=chip2*om2
2194       chipom12=chip12*om12
2195       facp=1.0D0-om12*chipom12
2196       facp_inv=1.0D0/facp
2197       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2198 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2199 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2200 C Following variable is the square root of eps2
2201       eps2rt=1.0D0-facp1*facp_inv
2202 C Following three variables are the derivatives of the square root of eps
2203 C in om1, om2, and om12.
2204       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2205       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2206       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2207 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2208       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2209 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2210 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2211 c     &  " eps2rt_om12",eps2rt_om12
2212 C Calculate whole angle-dependent part of epsilon and contributions
2213 C to its derivatives
2214       return
2215       end
2216 C----------------------------------------------------------------------------
2217       subroutine sc_grad
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220       include 'COMMON.CHAIN'
2221       include 'COMMON.DERIV'
2222       include 'COMMON.CALC'
2223       include 'COMMON.IOUNITS'
2224       double precision dcosom1(3),dcosom2(3)
2225 cc      print *,'sss=',sss
2226       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2227       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2228       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2229      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2230 c diagnostics only
2231 c      eom1=0.0d0
2232 c      eom2=0.0d0
2233 c      eom12=evdwij*eps1_om12
2234 c end diagnostics
2235 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2236 c     &  " sigder",sigder
2237 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2238 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2239       do k=1,3
2240         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2241         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2242       enddo
2243       do k=1,3
2244         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2245       enddo
2246 c      write (iout,*) "gg",(gg(k),k=1,3)
2247       do k=1,3
2248         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2249      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2250      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2251         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2252      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2253      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2254 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2255 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2256 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2257 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2258       enddo
2259 C
2260 C Calculate the components of the gradient in DC and X
2261 C
2262 cgrad      do k=i,j-1
2263 cgrad        do l=1,3
2264 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2265 cgrad        enddo
2266 cgrad      enddo
2267       do l=1,3
2268         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2269         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2270       enddo
2271       return
2272       end
2273 C-----------------------------------------------------------------------
2274       subroutine e_softsphere(evdw)
2275 C
2276 C This subroutine calculates the interaction energy of nonbonded side chains
2277 C assuming the LJ potential of interaction.
2278 C
2279       implicit real*8 (a-h,o-z)
2280       include 'DIMENSIONS'
2281       parameter (accur=1.0d-10)
2282       include 'COMMON.GEO'
2283       include 'COMMON.VAR'
2284       include 'COMMON.LOCAL'
2285       include 'COMMON.CHAIN'
2286       include 'COMMON.DERIV'
2287       include 'COMMON.INTERACT'
2288       include 'COMMON.TORSION'
2289       include 'COMMON.SBRIDGE'
2290       include 'COMMON.NAMES'
2291       include 'COMMON.IOUNITS'
2292       include 'COMMON.CONTACTS'
2293       dimension gg(3)
2294 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2295       evdw=0.0D0
2296       do i=iatsc_s,iatsc_e
2297         itypi=iabs(itype(i))
2298         if (itypi.eq.ntyp1) cycle
2299         itypi1=iabs(itype(i+1))
2300         xi=c(1,nres+i)
2301         yi=c(2,nres+i)
2302         zi=c(3,nres+i)
2303 C
2304 C Calculate SC interaction energy.
2305 C
2306         do iint=1,nint_gr(i)
2307 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2308 cd   &                  'iend=',iend(i,iint)
2309           do j=istart(i,iint),iend(i,iint)
2310             itypj=iabs(itype(j))
2311             if (itypj.eq.ntyp1) cycle
2312             xj=c(1,nres+j)-xi
2313             yj=c(2,nres+j)-yi
2314             zj=c(3,nres+j)-zi
2315             rij=xj*xj+yj*yj+zj*zj
2316 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2317             r0ij=r0(itypi,itypj)
2318             r0ijsq=r0ij*r0ij
2319 c            print *,i,j,r0ij,dsqrt(rij)
2320             if (rij.lt.r0ijsq) then
2321               evdwij=0.25d0*(rij-r0ijsq)**2
2322               fac=rij-r0ijsq
2323             else
2324               evdwij=0.0d0
2325               fac=0.0d0
2326             endif
2327             evdw=evdw+evdwij
2328 C
2329 C Calculate the components of the gradient in DC and X
2330 C
2331             gg(1)=xj*fac
2332             gg(2)=yj*fac
2333             gg(3)=zj*fac
2334             do k=1,3
2335               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2336               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2337               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2338               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2339             enddo
2340 cgrad            do k=i,j-1
2341 cgrad              do l=1,3
2342 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2343 cgrad              enddo
2344 cgrad            enddo
2345           enddo ! j
2346         enddo ! iint
2347       enddo ! i
2348       return
2349       end
2350 C--------------------------------------------------------------------------
2351       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2352      &              eello_turn4)
2353 C
2354 C Soft-sphere potential of p-p interaction
2355 C
2356       implicit real*8 (a-h,o-z)
2357       include 'DIMENSIONS'
2358       include 'COMMON.CONTROL'
2359       include 'COMMON.IOUNITS'
2360       include 'COMMON.GEO'
2361       include 'COMMON.VAR'
2362       include 'COMMON.LOCAL'
2363       include 'COMMON.CHAIN'
2364       include 'COMMON.DERIV'
2365       include 'COMMON.INTERACT'
2366       include 'COMMON.CONTACTS'
2367       include 'COMMON.TORSION'
2368       include 'COMMON.VECTORS'
2369       include 'COMMON.FFIELD'
2370       dimension ggg(3)
2371 C      write(iout,*) 'In EELEC_soft_sphere'
2372       ees=0.0D0
2373       evdw1=0.0D0
2374       eel_loc=0.0d0
2375       eello_turn3=0.0d0
2376       eello_turn4=0.0d0
2377       ind=0
2378       do i=iatel_s,iatel_e
2379         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2380         dxi=dc(1,i)
2381         dyi=dc(2,i)
2382         dzi=dc(3,i)
2383         xmedi=c(1,i)+0.5d0*dxi
2384         ymedi=c(2,i)+0.5d0*dyi
2385         zmedi=c(3,i)+0.5d0*dzi
2386           xmedi=mod(xmedi,boxxsize)
2387           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2388           ymedi=mod(ymedi,boxysize)
2389           if (ymedi.lt.0) ymedi=ymedi+boxysize
2390           zmedi=mod(zmedi,boxzsize)
2391           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2392         num_conti=0
2393 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2394         do j=ielstart(i),ielend(i)
2395           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2396           ind=ind+1
2397           iteli=itel(i)
2398           itelj=itel(j)
2399           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2400           r0ij=rpp(iteli,itelj)
2401           r0ijsq=r0ij*r0ij
2402           dxj=dc(1,j)
2403           dyj=dc(2,j)
2404           dzj=dc(3,j)
2405           xj=c(1,j)+0.5D0*dxj
2406           yj=c(2,j)+0.5D0*dyj
2407           zj=c(3,j)+0.5D0*dzj
2408           xj=mod(xj,boxxsize)
2409           if (xj.lt.0) xj=xj+boxxsize
2410           yj=mod(yj,boxysize)
2411           if (yj.lt.0) yj=yj+boxysize
2412           zj=mod(zj,boxzsize)
2413           if (zj.lt.0) zj=zj+boxzsize
2414       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2415       xj_safe=xj
2416       yj_safe=yj
2417       zj_safe=zj
2418       isubchap=0
2419       do xshift=-1,1
2420       do yshift=-1,1
2421       do zshift=-1,1
2422           xj=xj_safe+xshift*boxxsize
2423           yj=yj_safe+yshift*boxysize
2424           zj=zj_safe+zshift*boxzsize
2425           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2426           if(dist_temp.lt.dist_init) then
2427             dist_init=dist_temp
2428             xj_temp=xj
2429             yj_temp=yj
2430             zj_temp=zj
2431             isubchap=1
2432           endif
2433        enddo
2434        enddo
2435        enddo
2436        if (isubchap.eq.1) then
2437           xj=xj_temp-xmedi
2438           yj=yj_temp-ymedi
2439           zj=zj_temp-zmedi
2440        else
2441           xj=xj_safe-xmedi
2442           yj=yj_safe-ymedi
2443           zj=zj_safe-zmedi
2444        endif
2445           rij=xj*xj+yj*yj+zj*zj
2446             sss=sscale(sqrt(rij))
2447             sssgrad=sscagrad(sqrt(rij))
2448           if (rij.lt.r0ijsq) then
2449             evdw1ij=0.25d0*(rij-r0ijsq)**2
2450             fac=rij-r0ijsq
2451           else
2452             evdw1ij=0.0d0
2453             fac=0.0d0
2454           endif
2455           evdw1=evdw1+evdw1ij*sss
2456 C
2457 C Calculate contributions to the Cartesian gradient.
2458 C
2459           ggg(1)=fac*xj*sssgrad
2460           ggg(2)=fac*yj*sssgrad
2461           ggg(3)=fac*zj*sssgrad
2462           do k=1,3
2463             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2464             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2465           enddo
2466 *
2467 * Loop over residues i+1 thru j-1.
2468 *
2469 cgrad          do k=i+1,j-1
2470 cgrad            do l=1,3
2471 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2472 cgrad            enddo
2473 cgrad          enddo
2474         enddo ! j
2475       enddo   ! i
2476 cgrad      do i=nnt,nct-1
2477 cgrad        do k=1,3
2478 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2479 cgrad        enddo
2480 cgrad        do j=i+1,nct-1
2481 cgrad          do k=1,3
2482 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2483 cgrad          enddo
2484 cgrad        enddo
2485 cgrad      enddo
2486       return
2487       end
2488 c------------------------------------------------------------------------------
2489       subroutine vec_and_deriv
2490       implicit real*8 (a-h,o-z)
2491       include 'DIMENSIONS'
2492 #ifdef MPI
2493       include 'mpif.h'
2494 #endif
2495       include 'COMMON.IOUNITS'
2496       include 'COMMON.GEO'
2497       include 'COMMON.VAR'
2498       include 'COMMON.LOCAL'
2499       include 'COMMON.CHAIN'
2500       include 'COMMON.VECTORS'
2501       include 'COMMON.SETUP'
2502       include 'COMMON.TIME1'
2503       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2504 C Compute the local reference systems. For reference system (i), the
2505 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2506 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2507 #ifdef PARVEC
2508       do i=ivec_start,ivec_end
2509 #else
2510       do i=1,nres-1
2511 #endif
2512           if (i.eq.nres-1) then
2513 C Case of the last full residue
2514 C Compute the Z-axis
2515             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2516             costh=dcos(pi-theta(nres))
2517             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2518             do k=1,3
2519               uz(k,i)=fac*uz(k,i)
2520             enddo
2521 C Compute the derivatives of uz
2522             uzder(1,1,1)= 0.0d0
2523             uzder(2,1,1)=-dc_norm(3,i-1)
2524             uzder(3,1,1)= dc_norm(2,i-1)
2525             uzder(1,2,1)= dc_norm(3,i-1)
2526             uzder(2,2,1)= 0.0d0
2527             uzder(3,2,1)=-dc_norm(1,i-1)
2528             uzder(1,3,1)=-dc_norm(2,i-1)
2529             uzder(2,3,1)= dc_norm(1,i-1)
2530             uzder(3,3,1)= 0.0d0
2531             uzder(1,1,2)= 0.0d0
2532             uzder(2,1,2)= dc_norm(3,i)
2533             uzder(3,1,2)=-dc_norm(2,i)
2534             uzder(1,2,2)=-dc_norm(3,i)
2535             uzder(2,2,2)= 0.0d0
2536             uzder(3,2,2)= dc_norm(1,i)
2537             uzder(1,3,2)= dc_norm(2,i)
2538             uzder(2,3,2)=-dc_norm(1,i)
2539             uzder(3,3,2)= 0.0d0
2540 C Compute the Y-axis
2541             facy=fac
2542             do k=1,3
2543               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2544             enddo
2545 C Compute the derivatives of uy
2546             do j=1,3
2547               do k=1,3
2548                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2549      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2550                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2551               enddo
2552               uyder(j,j,1)=uyder(j,j,1)-costh
2553               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2554             enddo
2555             do j=1,2
2556               do k=1,3
2557                 do l=1,3
2558                   uygrad(l,k,j,i)=uyder(l,k,j)
2559                   uzgrad(l,k,j,i)=uzder(l,k,j)
2560                 enddo
2561               enddo
2562             enddo
2563             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2564             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2565             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2566             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2567           else
2568 C Other residues
2569 C Compute the Z-axis
2570             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2571             costh=dcos(pi-theta(i+2))
2572             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2573             do k=1,3
2574               uz(k,i)=fac*uz(k,i)
2575             enddo
2576 C Compute the derivatives of uz
2577             uzder(1,1,1)= 0.0d0
2578             uzder(2,1,1)=-dc_norm(3,i+1)
2579             uzder(3,1,1)= dc_norm(2,i+1)
2580             uzder(1,2,1)= dc_norm(3,i+1)
2581             uzder(2,2,1)= 0.0d0
2582             uzder(3,2,1)=-dc_norm(1,i+1)
2583             uzder(1,3,1)=-dc_norm(2,i+1)
2584             uzder(2,3,1)= dc_norm(1,i+1)
2585             uzder(3,3,1)= 0.0d0
2586             uzder(1,1,2)= 0.0d0
2587             uzder(2,1,2)= dc_norm(3,i)
2588             uzder(3,1,2)=-dc_norm(2,i)
2589             uzder(1,2,2)=-dc_norm(3,i)
2590             uzder(2,2,2)= 0.0d0
2591             uzder(3,2,2)= dc_norm(1,i)
2592             uzder(1,3,2)= dc_norm(2,i)
2593             uzder(2,3,2)=-dc_norm(1,i)
2594             uzder(3,3,2)= 0.0d0
2595 C Compute the Y-axis
2596             facy=fac
2597             do k=1,3
2598               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2599             enddo
2600 C Compute the derivatives of uy
2601             do j=1,3
2602               do k=1,3
2603                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2604      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2605                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2606               enddo
2607               uyder(j,j,1)=uyder(j,j,1)-costh
2608               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2609             enddo
2610             do j=1,2
2611               do k=1,3
2612                 do l=1,3
2613                   uygrad(l,k,j,i)=uyder(l,k,j)
2614                   uzgrad(l,k,j,i)=uzder(l,k,j)
2615                 enddo
2616               enddo
2617             enddo
2618             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2619             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2620             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2621             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2622           endif
2623       enddo
2624       do i=1,nres-1
2625         vbld_inv_temp(1)=vbld_inv(i+1)
2626         if (i.lt.nres-1) then
2627           vbld_inv_temp(2)=vbld_inv(i+2)
2628           else
2629           vbld_inv_temp(2)=vbld_inv(i)
2630           endif
2631         do j=1,2
2632           do k=1,3
2633             do l=1,3
2634               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2635               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2636             enddo
2637           enddo
2638         enddo
2639       enddo
2640 #if defined(PARVEC) && defined(MPI)
2641       if (nfgtasks1.gt.1) then
2642         time00=MPI_Wtime()
2643 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2644 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2645 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2646         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2654      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2655         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2656      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2657      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2658         time_gather=time_gather+MPI_Wtime()-time00
2659       endif
2660 c      if (fg_rank.eq.0) then
2661 c        write (iout,*) "Arrays UY and UZ"
2662 c        do i=1,nres-1
2663 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2664 c     &     (uz(k,i),k=1,3)
2665 c        enddo
2666 c      endif
2667 #endif
2668       return
2669       end
2670 C-----------------------------------------------------------------------------
2671       subroutine check_vecgrad
2672       implicit real*8 (a-h,o-z)
2673       include 'DIMENSIONS'
2674       include 'COMMON.IOUNITS'
2675       include 'COMMON.GEO'
2676       include 'COMMON.VAR'
2677       include 'COMMON.LOCAL'
2678       include 'COMMON.CHAIN'
2679       include 'COMMON.VECTORS'
2680       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2681       dimension uyt(3,maxres),uzt(3,maxres)
2682       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2683       double precision delta /1.0d-7/
2684       call vec_and_deriv
2685 cd      do i=1,nres
2686 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2687 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2688 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2689 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2690 cd     &     (dc_norm(if90,i),if90=1,3)
2691 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2692 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2693 cd          write(iout,'(a)')
2694 cd      enddo
2695       do i=1,nres
2696         do j=1,2
2697           do k=1,3
2698             do l=1,3
2699               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2700               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2701             enddo
2702           enddo
2703         enddo
2704       enddo
2705       call vec_and_deriv
2706       do i=1,nres
2707         do j=1,3
2708           uyt(j,i)=uy(j,i)
2709           uzt(j,i)=uz(j,i)
2710         enddo
2711       enddo
2712       do i=1,nres
2713 cd        write (iout,*) 'i=',i
2714         do k=1,3
2715           erij(k)=dc_norm(k,i)
2716         enddo
2717         do j=1,3
2718           do k=1,3
2719             dc_norm(k,i)=erij(k)
2720           enddo
2721           dc_norm(j,i)=dc_norm(j,i)+delta
2722 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2723 c          do k=1,3
2724 c            dc_norm(k,i)=dc_norm(k,i)/fac
2725 c          enddo
2726 c          write (iout,*) (dc_norm(k,i),k=1,3)
2727 c          write (iout,*) (erij(k),k=1,3)
2728           call vec_and_deriv
2729           do k=1,3
2730             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2731             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2732             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2733             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2734           enddo
2735 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2736 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2737 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2738         enddo
2739         do k=1,3
2740           dc_norm(k,i)=erij(k)
2741         enddo
2742 cd        do k=1,3
2743 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2744 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2745 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2746 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2747 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2748 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2749 cd          write (iout,'(a)')
2750 cd        enddo
2751       enddo
2752       return
2753       end
2754 C--------------------------------------------------------------------------
2755       subroutine set_matrices
2756       implicit real*8 (a-h,o-z)
2757       include 'DIMENSIONS'
2758 #ifdef MPI
2759       include "mpif.h"
2760       include "COMMON.SETUP"
2761       integer IERR
2762       integer status(MPI_STATUS_SIZE)
2763 #endif
2764       include 'COMMON.IOUNITS'
2765       include 'COMMON.GEO'
2766       include 'COMMON.VAR'
2767       include 'COMMON.LOCAL'
2768       include 'COMMON.CHAIN'
2769       include 'COMMON.DERIV'
2770       include 'COMMON.INTERACT'
2771       include 'COMMON.CONTACTS'
2772       include 'COMMON.TORSION'
2773       include 'COMMON.VECTORS'
2774       include 'COMMON.FFIELD'
2775       double precision auxvec(2),auxmat(2,2)
2776 C
2777 C Compute the virtual-bond-torsional-angle dependent quantities needed
2778 C to calculate the el-loc multibody terms of various order.
2779 C
2780 c      write(iout,*) 'nphi=',nphi,nres
2781 #ifdef PARMAT
2782       do i=ivec_start+2,ivec_end+2
2783 #else
2784       do i=3,nres+1
2785 #endif
2786 #ifdef NEWCORR
2787         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2788           iti = itype2loc(itype(i-2))
2789         else
2790           iti=nloctyp
2791         endif
2792 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2793         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2794           iti1 = itype2loc(itype(i-1))
2795         else
2796           iti1=nloctyp
2797         endif
2798 c        write(iout,*),i
2799         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2800      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2801      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2802         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2803      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2804      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2805 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2806 c     &*(cos(theta(i)/2.0)
2807         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2808      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2809      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2810 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2811 c     &*(cos(theta(i)/2.0)
2812         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2813      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2814      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2815 c        if (ggb1(1,i).eq.0.0d0) then
2816 c        write(iout,*) 'i=',i,ggb1(1,i),
2817 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2818 c     &bnew1(2,1,iti)*cos(theta(i)),
2819 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2820 c        endif
2821         b1(2,i-2)=bnew1(1,2,iti)
2822         gtb1(2,i-2)=0.0
2823         b2(2,i-2)=bnew2(1,2,iti)
2824         gtb2(2,i-2)=0.0
2825         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2826         EE(1,2,i-2)=eeold(1,2,iti)
2827         EE(2,1,i-2)=eeold(2,1,iti)
2828         EE(2,2,i-2)=eeold(2,2,iti)
2829         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2830         gtEE(1,2,i-2)=0.0d0
2831         gtEE(2,2,i-2)=0.0d0
2832         gtEE(2,1,i-2)=0.0d0
2833 c        EE(2,2,iti)=0.0d0
2834 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2835 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2836 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2837 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2838        b1tilde(1,i-2)=b1(1,i-2)
2839        b1tilde(2,i-2)=-b1(2,i-2)
2840        b2tilde(1,i-2)=b2(1,i-2)
2841        b2tilde(2,i-2)=-b2(2,i-2)
2842 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2843 c       write(iout,*)  'b1=',b1(1,i-2)
2844 c       write (iout,*) 'theta=', theta(i-1)
2845        enddo
2846 #else
2847         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2848           iti = itype2loc(itype(i-2))
2849         else
2850           iti=nloctyp
2851         endif
2852 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2853         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2854           iti1 = itype2loc(itype(i-1))
2855         else
2856           iti1=nloctyp
2857         endif
2858         b1(1,i-2)=b(3,iti)
2859         b1(2,i-2)=b(5,iti)
2860         b2(1,i-2)=b(2,iti)
2861         b2(2,i-2)=b(4,iti)
2862        b1tilde(1,i-2)=b1(1,i-2)
2863        b1tilde(2,i-2)=-b1(2,i-2)
2864        b2tilde(1,i-2)=b2(1,i-2)
2865        b2tilde(2,i-2)=-b2(2,i-2)
2866         EE(1,2,i-2)=eeold(1,2,iti)
2867         EE(2,1,i-2)=eeold(2,1,iti)
2868         EE(2,2,i-2)=eeold(2,2,iti)
2869         EE(1,1,i-2)=eeold(1,1,iti)
2870       enddo
2871 #endif
2872 #ifdef PARMAT
2873       do i=ivec_start+2,ivec_end+2
2874 #else
2875       do i=3,nres+1
2876 #endif
2877         if (i .lt. nres+1) then
2878           sin1=dsin(phi(i))
2879           cos1=dcos(phi(i))
2880           sintab(i-2)=sin1
2881           costab(i-2)=cos1
2882           obrot(1,i-2)=cos1
2883           obrot(2,i-2)=sin1
2884           sin2=dsin(2*phi(i))
2885           cos2=dcos(2*phi(i))
2886           sintab2(i-2)=sin2
2887           costab2(i-2)=cos2
2888           obrot2(1,i-2)=cos2
2889           obrot2(2,i-2)=sin2
2890           Ug(1,1,i-2)=-cos1
2891           Ug(1,2,i-2)=-sin1
2892           Ug(2,1,i-2)=-sin1
2893           Ug(2,2,i-2)= cos1
2894           Ug2(1,1,i-2)=-cos2
2895           Ug2(1,2,i-2)=-sin2
2896           Ug2(2,1,i-2)=-sin2
2897           Ug2(2,2,i-2)= cos2
2898         else
2899           costab(i-2)=1.0d0
2900           sintab(i-2)=0.0d0
2901           obrot(1,i-2)=1.0d0
2902           obrot(2,i-2)=0.0d0
2903           obrot2(1,i-2)=0.0d0
2904           obrot2(2,i-2)=0.0d0
2905           Ug(1,1,i-2)=1.0d0
2906           Ug(1,2,i-2)=0.0d0
2907           Ug(2,1,i-2)=0.0d0
2908           Ug(2,2,i-2)=1.0d0
2909           Ug2(1,1,i-2)=0.0d0
2910           Ug2(1,2,i-2)=0.0d0
2911           Ug2(2,1,i-2)=0.0d0
2912           Ug2(2,2,i-2)=0.0d0
2913         endif
2914         if (i .gt. 3 .and. i .lt. nres+1) then
2915           obrot_der(1,i-2)=-sin1
2916           obrot_der(2,i-2)= cos1
2917           Ugder(1,1,i-2)= sin1
2918           Ugder(1,2,i-2)=-cos1
2919           Ugder(2,1,i-2)=-cos1
2920           Ugder(2,2,i-2)=-sin1
2921           dwacos2=cos2+cos2
2922           dwasin2=sin2+sin2
2923           obrot2_der(1,i-2)=-dwasin2
2924           obrot2_der(2,i-2)= dwacos2
2925           Ug2der(1,1,i-2)= dwasin2
2926           Ug2der(1,2,i-2)=-dwacos2
2927           Ug2der(2,1,i-2)=-dwacos2
2928           Ug2der(2,2,i-2)=-dwasin2
2929         else
2930           obrot_der(1,i-2)=0.0d0
2931           obrot_der(2,i-2)=0.0d0
2932           Ugder(1,1,i-2)=0.0d0
2933           Ugder(1,2,i-2)=0.0d0
2934           Ugder(2,1,i-2)=0.0d0
2935           Ugder(2,2,i-2)=0.0d0
2936           obrot2_der(1,i-2)=0.0d0
2937           obrot2_der(2,i-2)=0.0d0
2938           Ug2der(1,1,i-2)=0.0d0
2939           Ug2der(1,2,i-2)=0.0d0
2940           Ug2der(2,1,i-2)=0.0d0
2941           Ug2der(2,2,i-2)=0.0d0
2942         endif
2943 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2944         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2945           iti = itype2loc(itype(i-2))
2946         else
2947           iti=nloctyp
2948         endif
2949 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2950         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2951           iti1 = itype2loc(itype(i-1))
2952         else
2953           iti1=nloctyp
2954         endif
2955 cd        write (iout,*) '*******i',i,' iti1',iti
2956 cd        write (iout,*) 'b1',b1(:,iti)
2957 cd        write (iout,*) 'b2',b2(:,iti)
2958 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2959 c        if (i .gt. iatel_s+2) then
2960         if (i .gt. nnt+2) then
2961           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2962 #ifdef NEWCORR
2963           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2964 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2965 #endif
2966 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2967 c     &    EE(1,2,iti),EE(2,2,i)
2968           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2969           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2970 c          write(iout,*) "Macierz EUG",
2971 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2972 c     &    eug(2,2,i-2)
2973           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2974      &    then
2975           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2976           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2977           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2978           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2979           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2980           endif
2981         else
2982           do k=1,2
2983             Ub2(k,i-2)=0.0d0
2984             Ctobr(k,i-2)=0.0d0
2985             Dtobr2(k,i-2)=0.0d0
2986             do l=1,2
2987               EUg(l,k,i-2)=0.0d0
2988               CUg(l,k,i-2)=0.0d0
2989               DUg(l,k,i-2)=0.0d0
2990               DtUg2(l,k,i-2)=0.0d0
2991             enddo
2992           enddo
2993         endif
2994         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2995         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2996         do k=1,2
2997           muder(k,i-2)=Ub2der(k,i-2)
2998         enddo
2999 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3000         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3001           if (itype(i-1).le.ntyp) then
3002             iti1 = itype2loc(itype(i-1))
3003           else
3004             iti1=nloctyp
3005           endif
3006         else
3007           iti1=nloctyp
3008         endif
3009         do k=1,2
3010           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3011         enddo
3012 #ifdef MUOUT
3013         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3014      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3015      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3016      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3017      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3018      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3019 #endif
3020 cd        write (iout,*) 'mu1',mu1(:,i-2)
3021 cd        write (iout,*) 'mu2',mu2(:,i-2)
3022         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3023      &  then
3024         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3025         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3026         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3027         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3028         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3029 C Vectors and matrices dependent on a single virtual-bond dihedral.
3030         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3031         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3032         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3033         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3034         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3035         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3036         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3037         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3038         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3039         endif
3040       enddo
3041 C Matrices dependent on two consecutive virtual-bond dihedrals.
3042 C The order of matrices is from left to right.
3043       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3044      &then
3045 c      do i=max0(ivec_start,2),ivec_end
3046       do i=2,nres-1
3047         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3048         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3049         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3050         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3051         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3052         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3053         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3054         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3055       enddo
3056       endif
3057 #if defined(MPI) && defined(PARMAT)
3058 #ifdef DEBUG
3059 c      if (fg_rank.eq.0) then
3060         write (iout,*) "Arrays UG and UGDER before GATHER"
3061         do i=1,nres-1
3062           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3063      &     ((ug(l,k,i),l=1,2),k=1,2),
3064      &     ((ugder(l,k,i),l=1,2),k=1,2)
3065         enddo
3066         write (iout,*) "Arrays UG2 and UG2DER"
3067         do i=1,nres-1
3068           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3069      &     ((ug2(l,k,i),l=1,2),k=1,2),
3070      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3071         enddo
3072         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3073         do i=1,nres-1
3074           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3075      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3076      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3077         enddo
3078         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3079         do i=1,nres-1
3080           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3081      &     costab(i),sintab(i),costab2(i),sintab2(i)
3082         enddo
3083         write (iout,*) "Array MUDER"
3084         do i=1,nres-1
3085           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3086         enddo
3087 c      endif
3088 #endif
3089       if (nfgtasks.gt.1) then
3090         time00=MPI_Wtime()
3091 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3092 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3093 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3094 #ifdef MATGATHER
3095         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3096      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3097      &   FG_COMM1,IERR)
3098         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3099      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3102      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3103      &   FG_COMM1,IERR)
3104         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3105      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3114      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3115      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3116         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3117      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3118      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3119         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3120      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3121      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3122         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3123      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3124      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3125         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3126      &  then
3127         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3128      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3129      &   FG_COMM1,IERR)
3130         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3131      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3132      &   FG_COMM1,IERR)
3133         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3134      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3135      &   FG_COMM1,IERR)
3136        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3137      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3138      &   FG_COMM1,IERR)
3139         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3140      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3141      &   FG_COMM1,IERR)
3142         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3143      &   ivec_count(fg_rank1),
3144      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3145      &   FG_COMM1,IERR)
3146         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3147      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3148      &   FG_COMM1,IERR)
3149         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3150      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3151      &   FG_COMM1,IERR)
3152         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3153      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3154      &   FG_COMM1,IERR)
3155         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3156      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3157      &   FG_COMM1,IERR)
3158         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3159      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3160      &   FG_COMM1,IERR)
3161         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3162      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3163      &   FG_COMM1,IERR)
3164         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3165      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3166      &   FG_COMM1,IERR)
3167         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3168      &   ivec_count(fg_rank1),
3169      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3170      &   FG_COMM1,IERR)
3171         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3172      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3173      &   FG_COMM1,IERR)
3174        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3175      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3176      &   FG_COMM1,IERR)
3177         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3178      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3179      &   FG_COMM1,IERR)
3180        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3181      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3182      &   FG_COMM1,IERR)
3183         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3184      &   ivec_count(fg_rank1),
3185      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3186      &   FG_COMM1,IERR)
3187         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3188      &   ivec_count(fg_rank1),
3189      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3190      &   FG_COMM1,IERR)
3191         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3192      &   ivec_count(fg_rank1),
3193      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3194      &   MPI_MAT2,FG_COMM1,IERR)
3195         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3196      &   ivec_count(fg_rank1),
3197      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3198      &   MPI_MAT2,FG_COMM1,IERR)
3199         endif
3200 #else
3201 c Passes matrix info through the ring
3202       isend=fg_rank1
3203       irecv=fg_rank1-1
3204       if (irecv.lt.0) irecv=nfgtasks1-1
3205       iprev=irecv
3206       inext=fg_rank1+1
3207       if (inext.ge.nfgtasks1) inext=0
3208       do i=1,nfgtasks1-1
3209 c        write (iout,*) "isend",isend," irecv",irecv
3210 c        call flush(iout)
3211         lensend=lentyp(isend)
3212         lenrecv=lentyp(irecv)
3213 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3214 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3215 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3216 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3217 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3218 c        write (iout,*) "Gather ROTAT1"
3219 c        call flush(iout)
3220 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3221 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3222 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3223 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3224 c        write (iout,*) "Gather ROTAT2"
3225 c        call flush(iout)
3226         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3227      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3228      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3229      &   iprev,4400+irecv,FG_COMM,status,IERR)
3230 c        write (iout,*) "Gather ROTAT_OLD"
3231 c        call flush(iout)
3232         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3233      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3234      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3235      &   iprev,5500+irecv,FG_COMM,status,IERR)
3236 c        write (iout,*) "Gather PRECOMP11"
3237 c        call flush(iout)
3238         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3239      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3240      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3241      &   iprev,6600+irecv,FG_COMM,status,IERR)
3242 c        write (iout,*) "Gather PRECOMP12"
3243 c        call flush(iout)
3244         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3245      &  then
3246         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3247      &   MPI_ROTAT2(lensend),inext,7700+isend,
3248      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3249      &   iprev,7700+irecv,FG_COMM,status,IERR)
3250 c        write (iout,*) "Gather PRECOMP21"
3251 c        call flush(iout)
3252         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3253      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3254      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3255      &   iprev,8800+irecv,FG_COMM,status,IERR)
3256 c        write (iout,*) "Gather PRECOMP22"
3257 c        call flush(iout)
3258         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3259      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3260      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3261      &   MPI_PRECOMP23(lenrecv),
3262      &   iprev,9900+irecv,FG_COMM,status,IERR)
3263 c        write (iout,*) "Gather PRECOMP23"
3264 c        call flush(iout)
3265         endif
3266         isend=irecv
3267         irecv=irecv-1
3268         if (irecv.lt.0) irecv=nfgtasks1-1
3269       enddo
3270 #endif
3271         time_gather=time_gather+MPI_Wtime()-time00
3272       endif
3273 #ifdef DEBUG
3274 c      if (fg_rank.eq.0) then
3275         write (iout,*) "Arrays UG and UGDER"
3276         do i=1,nres-1
3277           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3278      &     ((ug(l,k,i),l=1,2),k=1,2),
3279      &     ((ugder(l,k,i),l=1,2),k=1,2)
3280         enddo
3281         write (iout,*) "Arrays UG2 and UG2DER"
3282         do i=1,nres-1
3283           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3284      &     ((ug2(l,k,i),l=1,2),k=1,2),
3285      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3286         enddo
3287         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3288         do i=1,nres-1
3289           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3290      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3291      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3292         enddo
3293         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3294         do i=1,nres-1
3295           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3296      &     costab(i),sintab(i),costab2(i),sintab2(i)
3297         enddo
3298         write (iout,*) "Array MUDER"
3299         do i=1,nres-1
3300           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3301         enddo
3302 c      endif
3303 #endif
3304 #endif
3305 cd      do i=1,nres
3306 cd        iti = itype2loc(itype(i))
3307 cd        write (iout,*) i
3308 cd        do j=1,2
3309 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3310 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3311 cd        enddo
3312 cd      enddo
3313       return
3314       end
3315 C--------------------------------------------------------------------------
3316       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3317 C
3318 C This subroutine calculates the average interaction energy and its gradient
3319 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3320 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3321 C The potential depends both on the distance of peptide-group centers and on
3322 C the orientation of the CA-CA virtual bonds.
3323 C
3324       implicit real*8 (a-h,o-z)
3325 #ifdef MPI
3326       include 'mpif.h'
3327 #endif
3328       include 'DIMENSIONS'
3329       include 'COMMON.CONTROL'
3330       include 'COMMON.SETUP'
3331       include 'COMMON.IOUNITS'
3332       include 'COMMON.GEO'
3333       include 'COMMON.VAR'
3334       include 'COMMON.LOCAL'
3335       include 'COMMON.CHAIN'
3336       include 'COMMON.DERIV'
3337       include 'COMMON.INTERACT'
3338       include 'COMMON.CONTACTS'
3339       include 'COMMON.TORSION'
3340       include 'COMMON.VECTORS'
3341       include 'COMMON.FFIELD'
3342       include 'COMMON.TIME1'
3343       include 'COMMON.SPLITELE'
3344       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3345      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3346       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3347      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3348       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3349      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3350      &    num_conti,j1,j2
3351 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3352 #ifdef MOMENT
3353       double precision scal_el /1.0d0/
3354 #else
3355       double precision scal_el /0.5d0/
3356 #endif
3357 C 12/13/98
3358 C 13-go grudnia roku pamietnego...
3359       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3360      &                   0.0d0,1.0d0,0.0d0,
3361      &                   0.0d0,0.0d0,1.0d0/
3362 cd      write(iout,*) 'In EELEC'
3363 cd      do i=1,nloctyp
3364 cd        write(iout,*) 'Type',i
3365 cd        write(iout,*) 'B1',B1(:,i)
3366 cd        write(iout,*) 'B2',B2(:,i)
3367 cd        write(iout,*) 'CC',CC(:,:,i)
3368 cd        write(iout,*) 'DD',DD(:,:,i)
3369 cd        write(iout,*) 'EE',EE(:,:,i)
3370 cd      enddo
3371 cd      call check_vecgrad
3372 cd      stop
3373       if (icheckgrad.eq.1) then
3374         do i=1,nres-1
3375           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3376           do k=1,3
3377             dc_norm(k,i)=dc(k,i)*fac
3378           enddo
3379 c          write (iout,*) 'i',i,' fac',fac
3380         enddo
3381       endif
3382       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3383      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3384      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3385 c        call vec_and_deriv
3386 #ifdef TIMING
3387         time01=MPI_Wtime()
3388 #endif
3389         call set_matrices
3390 #ifdef TIMING
3391         time_mat=time_mat+MPI_Wtime()-time01
3392 #endif
3393       endif
3394 cd      do i=1,nres-1
3395 cd        write (iout,*) 'i=',i
3396 cd        do k=1,3
3397 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3398 cd        enddo
3399 cd        do k=1,3
3400 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3401 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3402 cd        enddo
3403 cd      enddo
3404       t_eelecij=0.0d0
3405       ees=0.0D0
3406       evdw1=0.0D0
3407       eel_loc=0.0d0
3408       eello_turn3=0.0d0
3409       eello_turn4=0.0d0
3410       ind=0
3411       do i=1,nres
3412         num_cont_hb(i)=0
3413       enddo
3414 cd      print '(a)','Enter EELEC'
3415 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3416       do i=1,nres
3417         gel_loc_loc(i)=0.0d0
3418         gcorr_loc(i)=0.0d0
3419       enddo
3420 c
3421 c
3422 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3423 C
3424 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3425 C
3426 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3427       do i=iturn3_start,iturn3_end
3428 c        if (i.le.1) cycle
3429 C        write(iout,*) "tu jest i",i
3430         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3431 C changes suggested by Ana to avoid out of bounds
3432 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3433 c     & .or.((i+4).gt.nres)
3434 c     & .or.((i-1).le.0)
3435 C end of changes by Ana
3436      &  .or. itype(i+2).eq.ntyp1
3437      &  .or. itype(i+3).eq.ntyp1) cycle
3438 C Adam: Instructions below will switch off existing interactions
3439 c        if(i.gt.1)then
3440 c          if(itype(i-1).eq.ntyp1)cycle
3441 c        end if
3442 c        if(i.LT.nres-3)then
3443 c          if (itype(i+4).eq.ntyp1) cycle
3444 c        end if
3445         dxi=dc(1,i)
3446         dyi=dc(2,i)
3447         dzi=dc(3,i)
3448         dx_normi=dc_norm(1,i)
3449         dy_normi=dc_norm(2,i)
3450         dz_normi=dc_norm(3,i)
3451         xmedi=c(1,i)+0.5d0*dxi
3452         ymedi=c(2,i)+0.5d0*dyi
3453         zmedi=c(3,i)+0.5d0*dzi
3454           xmedi=mod(xmedi,boxxsize)
3455           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3456           ymedi=mod(ymedi,boxysize)
3457           if (ymedi.lt.0) ymedi=ymedi+boxysize
3458           zmedi=mod(zmedi,boxzsize)
3459           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3460         num_conti=0
3461         call eelecij(i,i+2,ees,evdw1,eel_loc)
3462         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3463         num_cont_hb(i)=num_conti
3464       enddo
3465       do i=iturn4_start,iturn4_end
3466         if (i.lt.1) cycle
3467         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3468 C changes suggested by Ana to avoid out of bounds
3469 c     & .or.((i+5).gt.nres)
3470 c     & .or.((i-1).le.0)
3471 C end of changes suggested by Ana
3472      &    .or. itype(i+3).eq.ntyp1
3473      &    .or. itype(i+4).eq.ntyp1
3474 c     &    .or. itype(i+5).eq.ntyp1
3475 c     &    .or. itype(i).eq.ntyp1
3476 c     &    .or. itype(i-1).eq.ntyp1
3477      &                             ) cycle
3478         dxi=dc(1,i)
3479         dyi=dc(2,i)
3480         dzi=dc(3,i)
3481         dx_normi=dc_norm(1,i)
3482         dy_normi=dc_norm(2,i)
3483         dz_normi=dc_norm(3,i)
3484         xmedi=c(1,i)+0.5d0*dxi
3485         ymedi=c(2,i)+0.5d0*dyi
3486         zmedi=c(3,i)+0.5d0*dzi
3487 C Return atom into box, boxxsize is size of box in x dimension
3488 c  194   continue
3489 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3490 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3491 C Condition for being inside the proper box
3492 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3493 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3494 c        go to 194
3495 c        endif
3496 c  195   continue
3497 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3498 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3499 C Condition for being inside the proper box
3500 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3501 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3502 c        go to 195
3503 c        endif
3504 c  196   continue
3505 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3506 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3507 C Condition for being inside the proper box
3508 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3509 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3510 c        go to 196
3511 c        endif
3512           xmedi=mod(xmedi,boxxsize)
3513           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3514           ymedi=mod(ymedi,boxysize)
3515           if (ymedi.lt.0) ymedi=ymedi+boxysize
3516           zmedi=mod(zmedi,boxzsize)
3517           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3518
3519         num_conti=num_cont_hb(i)
3520 c        write(iout,*) "JESTEM W PETLI"
3521         call eelecij(i,i+3,ees,evdw1,eel_loc)
3522         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3523      &   call eturn4(i,eello_turn4)
3524         num_cont_hb(i)=num_conti
3525       enddo   ! i
3526 C Loop over all neighbouring boxes
3527 C      do xshift=-1,1
3528 C      do yshift=-1,1
3529 C      do zshift=-1,1
3530 c
3531 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3532 c
3533 CTU KURWA
3534       do i=iatel_s,iatel_e
3535 C        do i=75,75
3536 c        if (i.le.1) cycle
3537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3538 C changes suggested by Ana to avoid out of bounds
3539 c     & .or.((i+2).gt.nres)
3540 c     & .or.((i-1).le.0)
3541 C end of changes by Ana
3542 c     &  .or. itype(i+2).eq.ntyp1
3543 c     &  .or. itype(i-1).eq.ntyp1
3544      &                ) cycle
3545         dxi=dc(1,i)
3546         dyi=dc(2,i)
3547         dzi=dc(3,i)
3548         dx_normi=dc_norm(1,i)
3549         dy_normi=dc_norm(2,i)
3550         dz_normi=dc_norm(3,i)
3551         xmedi=c(1,i)+0.5d0*dxi
3552         ymedi=c(2,i)+0.5d0*dyi
3553         zmedi=c(3,i)+0.5d0*dzi
3554           xmedi=mod(xmedi,boxxsize)
3555           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3556           ymedi=mod(ymedi,boxysize)
3557           if (ymedi.lt.0) ymedi=ymedi+boxysize
3558           zmedi=mod(zmedi,boxzsize)
3559           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3560 C          xmedi=xmedi+xshift*boxxsize
3561 C          ymedi=ymedi+yshift*boxysize
3562 C          zmedi=zmedi+zshift*boxzsize
3563
3564 C Return tom into box, boxxsize is size of box in x dimension
3565 c  164   continue
3566 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3567 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3568 C Condition for being inside the proper box
3569 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3570 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3571 c        go to 164
3572 c        endif
3573 c  165   continue
3574 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3575 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3576 C Condition for being inside the proper box
3577 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3578 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3579 c        go to 165
3580 c        endif
3581 c  166   continue
3582 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3583 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3584 cC Condition for being inside the proper box
3585 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3586 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3587 c        go to 166
3588 c        endif
3589
3590 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3591         num_conti=num_cont_hb(i)
3592 C I TU KURWA
3593         do j=ielstart(i),ielend(i)
3594 C          do j=16,17
3595 C          write (iout,*) i,j
3596          if (j.le.1) cycle
3597           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3598 C changes suggested by Ana to avoid out of bounds
3599 c     & .or.((j+2).gt.nres)
3600 c     & .or.((j-1).le.0)
3601 C end of changes by Ana
3602 c     & .or.itype(j+2).eq.ntyp1
3603 c     & .or.itype(j-1).eq.ntyp1
3604      &) cycle
3605           call eelecij(i,j,ees,evdw1,eel_loc)
3606         enddo ! j
3607         num_cont_hb(i)=num_conti
3608       enddo   ! i
3609 C     enddo   ! zshift
3610 C      enddo   ! yshift
3611 C      enddo   ! xshift
3612
3613 c      write (iout,*) "Number of loop steps in EELEC:",ind
3614 cd      do i=1,nres
3615 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3616 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3617 cd      enddo
3618 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3619 ccc      eel_loc=eel_loc+eello_turn3
3620 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3621       return
3622       end
3623 C-------------------------------------------------------------------------------
3624       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3625       implicit real*8 (a-h,o-z)
3626       include 'DIMENSIONS'
3627 #ifdef MPI
3628       include "mpif.h"
3629 #endif
3630       include 'COMMON.CONTROL'
3631       include 'COMMON.IOUNITS'
3632       include 'COMMON.GEO'
3633       include 'COMMON.VAR'
3634       include 'COMMON.LOCAL'
3635       include 'COMMON.CHAIN'
3636       include 'COMMON.DERIV'
3637       include 'COMMON.INTERACT'
3638       include 'COMMON.CONTACTS'
3639       include 'COMMON.TORSION'
3640       include 'COMMON.VECTORS'
3641       include 'COMMON.FFIELD'
3642       include 'COMMON.TIME1'
3643       include 'COMMON.SPLITELE'
3644       include 'COMMON.SHIELD'
3645       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3646      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3647       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3648      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3649      &    gmuij2(4),gmuji2(4)
3650       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3651      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3652      &    num_conti,j1,j2
3653 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3654 #ifdef MOMENT
3655       double precision scal_el /1.0d0/
3656 #else
3657       double precision scal_el /0.5d0/
3658 #endif
3659 C 12/13/98
3660 C 13-go grudnia roku pamietnego...
3661       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3662      &                   0.0d0,1.0d0,0.0d0,
3663      &                   0.0d0,0.0d0,1.0d0/
3664        integer xshift,yshift,zshift
3665 c          time00=MPI_Wtime()
3666 cd      write (iout,*) "eelecij",i,j
3667 c          ind=ind+1
3668           iteli=itel(i)
3669           itelj=itel(j)
3670           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3671           aaa=app(iteli,itelj)
3672           bbb=bpp(iteli,itelj)
3673           ael6i=ael6(iteli,itelj)
3674           ael3i=ael3(iteli,itelj)
3675           dxj=dc(1,j)
3676           dyj=dc(2,j)
3677           dzj=dc(3,j)
3678           dx_normj=dc_norm(1,j)
3679           dy_normj=dc_norm(2,j)
3680           dz_normj=dc_norm(3,j)
3681 C          xj=c(1,j)+0.5D0*dxj-xmedi
3682 C          yj=c(2,j)+0.5D0*dyj-ymedi
3683 C          zj=c(3,j)+0.5D0*dzj-zmedi
3684           xj=c(1,j)+0.5D0*dxj
3685           yj=c(2,j)+0.5D0*dyj
3686           zj=c(3,j)+0.5D0*dzj
3687           xj=mod(xj,boxxsize)
3688           if (xj.lt.0) xj=xj+boxxsize
3689           yj=mod(yj,boxysize)
3690           if (yj.lt.0) yj=yj+boxysize
3691           zj=mod(zj,boxzsize)
3692           if (zj.lt.0) zj=zj+boxzsize
3693           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3694       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3695       xj_safe=xj
3696       yj_safe=yj
3697       zj_safe=zj
3698       isubchap=0
3699       do xshift=-1,1
3700       do yshift=-1,1
3701       do zshift=-1,1
3702           xj=xj_safe+xshift*boxxsize
3703           yj=yj_safe+yshift*boxysize
3704           zj=zj_safe+zshift*boxzsize
3705           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3706           if(dist_temp.lt.dist_init) then
3707             dist_init=dist_temp
3708             xj_temp=xj
3709             yj_temp=yj
3710             zj_temp=zj
3711             isubchap=1
3712           endif
3713        enddo
3714        enddo
3715        enddo
3716        if (isubchap.eq.1) then
3717           xj=xj_temp-xmedi
3718           yj=yj_temp-ymedi
3719           zj=zj_temp-zmedi
3720        else
3721           xj=xj_safe-xmedi
3722           yj=yj_safe-ymedi
3723           zj=zj_safe-zmedi
3724        endif
3725 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3726 c  174   continue
3727 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3728 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3729 C Condition for being inside the proper box
3730 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3731 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3732 c        go to 174
3733 c        endif
3734 c  175   continue
3735 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3736 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3737 C Condition for being inside the proper box
3738 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3739 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3740 c        go to 175
3741 c        endif
3742 c  176   continue
3743 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3744 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3745 C Condition for being inside the proper box
3746 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3747 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3748 c        go to 176
3749 c        endif
3750 C        endif !endPBC condintion
3751 C        xj=xj-xmedi
3752 C        yj=yj-ymedi
3753 C        zj=zj-zmedi
3754           rij=xj*xj+yj*yj+zj*zj
3755
3756             sss=sscale(sqrt(rij))
3757             sssgrad=sscagrad(sqrt(rij))
3758 c            if (sss.gt.0.0d0) then
3759           rrmij=1.0D0/rij
3760           rij=dsqrt(rij)
3761           rmij=1.0D0/rij
3762           r3ij=rrmij*rmij
3763           r6ij=r3ij*r3ij
3764           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3765           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3766           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3767           fac=cosa-3.0D0*cosb*cosg
3768           ev1=aaa*r6ij*r6ij
3769 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3770           if (j.eq.i+2) ev1=scal_el*ev1
3771           ev2=bbb*r6ij
3772           fac3=ael6i*r6ij
3773           fac4=ael3i*r3ij
3774           evdwij=(ev1+ev2)
3775           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3776           el2=fac4*fac
3777 C MARYSIA
3778 C          eesij=(el1+el2)
3779 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3780           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3781           if (shield_mode.gt.0) then
3782 C          fac_shield(i)=0.4
3783 C          fac_shield(j)=0.6
3784           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3785           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3786           eesij=(el1+el2)
3787           ees=ees+eesij
3788           else
3789           fac_shield(i)=1.0
3790           fac_shield(j)=1.0
3791           eesij=(el1+el2)
3792           ees=ees+eesij
3793           endif
3794           evdw1=evdw1+evdwij*sss
3795 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3796 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3797 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3798 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3799
3800           if (energy_dec) then
3801               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3802      &'evdw1',i,j,evdwij
3803      &,iteli,itelj,aaa,evdw1
3804               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3805      &fac_shield(i),fac_shield(j)
3806           endif
3807
3808 C
3809 C Calculate contributions to the Cartesian gradient.
3810 C
3811 #ifdef SPLITELE
3812           facvdw=-6*rrmij*(ev1+evdwij)*sss
3813           facel=-3*rrmij*(el1+eesij)
3814           fac1=fac
3815           erij(1)=xj*rmij
3816           erij(2)=yj*rmij
3817           erij(3)=zj*rmij
3818
3819 *
3820 * Radial derivatives. First process both termini of the fragment (i,j)
3821 *
3822           ggg(1)=facel*xj
3823           ggg(2)=facel*yj
3824           ggg(3)=facel*zj
3825           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3826      &  (shield_mode.gt.0)) then
3827 C          print *,i,j
3828           do ilist=1,ishield_list(i)
3829            iresshield=shield_list(ilist,i)
3830            do k=1,3
3831            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3832      &      *2.0
3833            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3834      &              rlocshield
3835      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3836             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3837 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3838 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3839 C             if (iresshield.gt.i) then
3840 C               do ishi=i+1,iresshield-1
3841 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3842 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3843 C
3844 C              enddo
3845 C             else
3846 C               do ishi=iresshield,i
3847 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3848 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3849 C
3850 C               enddo
3851 C              endif
3852            enddo
3853           enddo
3854           do ilist=1,ishield_list(j)
3855            iresshield=shield_list(ilist,j)
3856            do k=1,3
3857            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3858      &     *2.0
3859            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3860      &              rlocshield
3861      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3862            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3863
3864 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3865 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3866 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3867 C             if (iresshield.gt.j) then
3868 C               do ishi=j+1,iresshield-1
3869 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3870 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3871 C
3872 C               enddo
3873 C            else
3874 C               do ishi=iresshield,j
3875 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3876 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3877 C               enddo
3878 C              endif
3879            enddo
3880           enddo
3881
3882           do k=1,3
3883             gshieldc(k,i)=gshieldc(k,i)+
3884      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3885             gshieldc(k,j)=gshieldc(k,j)+
3886      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3887             gshieldc(k,i-1)=gshieldc(k,i-1)+
3888      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3889             gshieldc(k,j-1)=gshieldc(k,j-1)+
3890      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3891
3892            enddo
3893            endif
3894 c          do k=1,3
3895 c            ghalf=0.5D0*ggg(k)
3896 c            gelc(k,i)=gelc(k,i)+ghalf
3897 c            gelc(k,j)=gelc(k,j)+ghalf
3898 c          enddo
3899 c 9/28/08 AL Gradient compotents will be summed only at the end
3900 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3901           do k=1,3
3902             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3903 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3904             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3905 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3906 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3907 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3908 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3909 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3910           enddo
3911 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3912
3913 *
3914 * Loop over residues i+1 thru j-1.
3915 *
3916 cgrad          do k=i+1,j-1
3917 cgrad            do l=1,3
3918 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3919 cgrad            enddo
3920 cgrad          enddo
3921           if (sss.gt.0.0) then
3922           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3923           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3924           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3925           else
3926           ggg(1)=0.0
3927           ggg(2)=0.0
3928           ggg(3)=0.0
3929           endif
3930 c          do k=1,3
3931 c            ghalf=0.5D0*ggg(k)
3932 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3933 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3934 c          enddo
3935 c 9/28/08 AL Gradient compotents will be summed only at the end
3936           do k=1,3
3937             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3939           enddo
3940 *
3941 * Loop over residues i+1 thru j-1.
3942 *
3943 cgrad          do k=i+1,j-1
3944 cgrad            do l=1,3
3945 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3946 cgrad            enddo
3947 cgrad          enddo
3948 #else
3949 C MARYSIA
3950           facvdw=(ev1+evdwij)*sss
3951           facel=(el1+eesij)
3952           fac1=fac
3953           fac=-3*rrmij*(facvdw+facvdw+facel)
3954           erij(1)=xj*rmij
3955           erij(2)=yj*rmij
3956           erij(3)=zj*rmij
3957 *
3958 * Radial derivatives. First process both termini of the fragment (i,j)
3959 *
3960           ggg(1)=fac*xj
3961 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3962           ggg(2)=fac*yj
3963 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3964           ggg(3)=fac*zj
3965 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3966 c          do k=1,3
3967 c            ghalf=0.5D0*ggg(k)
3968 c            gelc(k,i)=gelc(k,i)+ghalf
3969 c            gelc(k,j)=gelc(k,j)+ghalf
3970 c          enddo
3971 c 9/28/08 AL Gradient compotents will be summed only at the end
3972           do k=1,3
3973             gelc_long(k,j)=gelc(k,j)+ggg(k)
3974             gelc_long(k,i)=gelc(k,i)-ggg(k)
3975           enddo
3976 *
3977 * Loop over residues i+1 thru j-1.
3978 *
3979 cgrad          do k=i+1,j-1
3980 cgrad            do l=1,3
3981 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3982 cgrad            enddo
3983 cgrad          enddo
3984 c 9/28/08 AL Gradient compotents will be summed only at the end
3985           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3986           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3987           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3988           do k=1,3
3989             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3990             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3991           enddo
3992 #endif
3993 *
3994 * Angular part
3995 *
3996           ecosa=2.0D0*fac3*fac1+fac4
3997           fac4=-3.0D0*fac4
3998           fac3=-6.0D0*fac3
3999           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4000           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4001           do k=1,3
4002             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4003             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4004           enddo
4005 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4006 cd   &          (dcosg(k),k=1,3)
4007           do k=1,3
4008             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4009      &      fac_shield(i)**2*fac_shield(j)**2
4010           enddo
4011 c          do k=1,3
4012 c            ghalf=0.5D0*ggg(k)
4013 c            gelc(k,i)=gelc(k,i)+ghalf
4014 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4015 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4016 c            gelc(k,j)=gelc(k,j)+ghalf
4017 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4018 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4019 c          enddo
4020 cgrad          do k=i+1,j-1
4021 cgrad            do l=1,3
4022 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4023 cgrad            enddo
4024 cgrad          enddo
4025 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4026           do k=1,3
4027             gelc(k,i)=gelc(k,i)
4028      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4029      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4030      &           *fac_shield(i)**2*fac_shield(j)**2
4031             gelc(k,j)=gelc(k,j)
4032      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4033      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4034      &           *fac_shield(i)**2*fac_shield(j)**2
4035             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4036             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4037           enddo
4038 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4039
4040 C MARYSIA
4041 c          endif !sscale
4042           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4043      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4044      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4045 C
4046 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4047 C   energy of a peptide unit is assumed in the form of a second-order
4048 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4049 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4050 C   are computed for EVERY pair of non-contiguous peptide groups.
4051 C
4052
4053           if (j.lt.nres-1) then
4054             j1=j+1
4055             j2=j-1
4056           else
4057             j1=j-1
4058             j2=j-2
4059           endif
4060           kkk=0
4061           lll=0
4062           do k=1,2
4063             do l=1,2
4064               kkk=kkk+1
4065               muij(kkk)=mu(k,i)*mu(l,j)
4066 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4067 #ifdef NEWCORR
4068              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4069 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4070              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4071              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4072 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4073              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4074 #endif
4075             enddo
4076           enddo
4077 cd         write (iout,*) 'EELEC: i',i,' j',j
4078 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4079 cd          write(iout,*) 'muij',muij
4080           ury=scalar(uy(1,i),erij)
4081           urz=scalar(uz(1,i),erij)
4082           vry=scalar(uy(1,j),erij)
4083           vrz=scalar(uz(1,j),erij)
4084           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4085           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4086           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4087           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4088           fac=dsqrt(-ael6i)*r3ij
4089           a22=a22*fac
4090           a23=a23*fac
4091           a32=a32*fac
4092           a33=a33*fac
4093 cd          write (iout,'(4i5,4f10.5)')
4094 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4095 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4096 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4097 cd     &      uy(:,j),uz(:,j)
4098 cd          write (iout,'(4f10.5)')
4099 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4100 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4101 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4102 cd           write (iout,'(9f10.5/)')
4103 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4104 C Derivatives of the elements of A in virtual-bond vectors
4105           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4106           do k=1,3
4107             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4108             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4109             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4110             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4111             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4112             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4113             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4114             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4115             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4116             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4117             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4118             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4119           enddo
4120 C Compute radial contributions to the gradient
4121           facr=-3.0d0*rrmij
4122           a22der=a22*facr
4123           a23der=a23*facr
4124           a32der=a32*facr
4125           a33der=a33*facr
4126           agg(1,1)=a22der*xj
4127           agg(2,1)=a22der*yj
4128           agg(3,1)=a22der*zj
4129           agg(1,2)=a23der*xj
4130           agg(2,2)=a23der*yj
4131           agg(3,2)=a23der*zj
4132           agg(1,3)=a32der*xj
4133           agg(2,3)=a32der*yj
4134           agg(3,3)=a32der*zj
4135           agg(1,4)=a33der*xj
4136           agg(2,4)=a33der*yj
4137           agg(3,4)=a33der*zj
4138 C Add the contributions coming from er
4139           fac3=-3.0d0*fac
4140           do k=1,3
4141             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4142             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4143             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4144             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4145           enddo
4146           do k=1,3
4147 C Derivatives in DC(i)
4148 cgrad            ghalf1=0.5d0*agg(k,1)
4149 cgrad            ghalf2=0.5d0*agg(k,2)
4150 cgrad            ghalf3=0.5d0*agg(k,3)
4151 cgrad            ghalf4=0.5d0*agg(k,4)
4152             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4153      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4154             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4155      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4156             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4157      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4158             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4159      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4160 C Derivatives in DC(i+1)
4161             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4162      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4163             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4164      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4165             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4166      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4167             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4168      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4169 C Derivatives in DC(j)
4170             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4171      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4172             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4173      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4174             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4175      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4176             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4177      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4178 C Derivatives in DC(j+1) or DC(nres-1)
4179             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4180      &      -3.0d0*vryg(k,3)*ury)
4181             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4182      &      -3.0d0*vrzg(k,3)*ury)
4183             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4184      &      -3.0d0*vryg(k,3)*urz)
4185             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4186      &      -3.0d0*vrzg(k,3)*urz)
4187 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4188 cgrad              do l=1,4
4189 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4190 cgrad              enddo
4191 cgrad            endif
4192           enddo
4193           acipa(1,1)=a22
4194           acipa(1,2)=a23
4195           acipa(2,1)=a32
4196           acipa(2,2)=a33
4197           a22=-a22
4198           a23=-a23
4199           do l=1,2
4200             do k=1,3
4201               agg(k,l)=-agg(k,l)
4202               aggi(k,l)=-aggi(k,l)
4203               aggi1(k,l)=-aggi1(k,l)
4204               aggj(k,l)=-aggj(k,l)
4205               aggj1(k,l)=-aggj1(k,l)
4206             enddo
4207           enddo
4208           if (j.lt.nres-1) then
4209             a22=-a22
4210             a32=-a32
4211             do l=1,3,2
4212               do k=1,3
4213                 agg(k,l)=-agg(k,l)
4214                 aggi(k,l)=-aggi(k,l)
4215                 aggi1(k,l)=-aggi1(k,l)
4216                 aggj(k,l)=-aggj(k,l)
4217                 aggj1(k,l)=-aggj1(k,l)
4218               enddo
4219             enddo
4220           else
4221             a22=-a22
4222             a23=-a23
4223             a32=-a32
4224             a33=-a33
4225             do l=1,4
4226               do k=1,3
4227                 agg(k,l)=-agg(k,l)
4228                 aggi(k,l)=-aggi(k,l)
4229                 aggi1(k,l)=-aggi1(k,l)
4230                 aggj(k,l)=-aggj(k,l)
4231                 aggj1(k,l)=-aggj1(k,l)
4232               enddo
4233             enddo
4234           endif
4235           ENDIF ! WCORR
4236           IF (wel_loc.gt.0.0d0) THEN
4237 C Contribution to the local-electrostatic energy coming from the i-j pair
4238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4239      &     +a33*muij(4)
4240           if (shield_mode.eq.0) then
4241            fac_shield(i)=1.0
4242            fac_shield(j)=1.0
4243 C          else
4244 C           fac_shield(i)=0.4
4245 C           fac_shield(j)=0.6
4246           endif
4247           eel_loc_ij=eel_loc_ij
4248      &    *fac_shield(i)*fac_shield(j)
4249 C Now derivative over eel_loc
4250           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4251      &  (shield_mode.gt.0)) then
4252 C          print *,i,j
4253
4254           do ilist=1,ishield_list(i)
4255            iresshield=shield_list(ilist,i)
4256            do k=1,3
4257            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4258      &                                          /fac_shield(i)
4259 C     &      *2.0
4260            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4261      &              rlocshield
4262      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4263             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4264      &      +rlocshield
4265            enddo
4266           enddo
4267           do ilist=1,ishield_list(j)
4268            iresshield=shield_list(ilist,j)
4269            do k=1,3
4270            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4271      &                                       /fac_shield(j)
4272 C     &     *2.0
4273            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4274      &              rlocshield
4275      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4276            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4277      &             +rlocshield
4278
4279            enddo
4280           enddo
4281
4282           do k=1,3
4283             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4284      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4285             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4286      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4287             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4288      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4289             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4290      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4291            enddo
4292            endif
4293
4294
4295 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4296 c     &                     ' eel_loc_ij',eel_loc_ij
4297 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4298 C Calculate patrial derivative for theta angle
4299 #ifdef NEWCORR
4300          geel_loc_ij=(a22*gmuij1(1)
4301      &     +a23*gmuij1(2)
4302      &     +a32*gmuij1(3)
4303      &     +a33*gmuij1(4))
4304      &    *fac_shield(i)*fac_shield(j)
4305 c         write(iout,*) "derivative over thatai"
4306 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4307 c     &   a33*gmuij1(4)
4308          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4309      &      geel_loc_ij*wel_loc
4310 c         write(iout,*) "derivative over thatai-1"
4311 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4312 c     &   a33*gmuij2(4)
4313          geel_loc_ij=
4314      &     a22*gmuij2(1)
4315      &     +a23*gmuij2(2)
4316      &     +a32*gmuij2(3)
4317      &     +a33*gmuij2(4)
4318          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4319      &      geel_loc_ij*wel_loc
4320      &    *fac_shield(i)*fac_shield(j)
4321
4322 c  Derivative over j residue
4323          geel_loc_ji=a22*gmuji1(1)
4324      &     +a23*gmuji1(2)
4325      &     +a32*gmuji1(3)
4326      &     +a33*gmuji1(4)
4327 c         write(iout,*) "derivative over thataj"
4328 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4329 c     &   a33*gmuji1(4)
4330
4331         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4332      &      geel_loc_ji*wel_loc
4333      &    *fac_shield(i)*fac_shield(j)
4334
4335          geel_loc_ji=
4336      &     +a22*gmuji2(1)
4337      &     +a23*gmuji2(2)
4338      &     +a32*gmuji2(3)
4339      &     +a33*gmuji2(4)
4340 c         write(iout,*) "derivative over thataj-1"
4341 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4342 c     &   a33*gmuji2(4)
4343          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4344      &      geel_loc_ji*wel_loc
4345      &    *fac_shield(i)*fac_shield(j)
4346 #endif
4347 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4348
4349           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4350      &            'eelloc',i,j,eel_loc_ij
4351 c           if (eel_loc_ij.ne.0)
4352 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4353 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4354
4355           eel_loc=eel_loc+eel_loc_ij
4356 C Partial derivatives in virtual-bond dihedral angles gamma
4357           if (i.gt.1)
4358      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4359      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4360      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4361      &    *fac_shield(i)*fac_shield(j)
4362
4363           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4364      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4365      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4366      &    *fac_shield(i)*fac_shield(j)
4367 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4368           do l=1,3
4369             ggg(l)=(agg(l,1)*muij(1)+
4370      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4371      &    *fac_shield(i)*fac_shield(j)
4372             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4373             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4374 cgrad            ghalf=0.5d0*ggg(l)
4375 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4376 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4377           enddo
4378 cgrad          do k=i+1,j2
4379 cgrad            do l=1,3
4380 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4381 cgrad            enddo
4382 cgrad          enddo
4383 C Remaining derivatives of eello
4384           do l=1,3
4385             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4386      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4387      &    *fac_shield(i)*fac_shield(j)
4388
4389             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4390      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4391      &    *fac_shield(i)*fac_shield(j)
4392
4393             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4394      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4395      &    *fac_shield(i)*fac_shield(j)
4396
4397             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4398      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4399      &    *fac_shield(i)*fac_shield(j)
4400
4401           enddo
4402           ENDIF
4403 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4404 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4405           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4406      &       .and. num_conti.le.maxconts) then
4407 c            write (iout,*) i,j," entered corr"
4408 C
4409 C Calculate the contact function. The ith column of the array JCONT will
4410 C contain the numbers of atoms that make contacts with the atom I (of numbers
4411 C greater than I). The arrays FACONT and GACONT will contain the values of
4412 C the contact function and its derivative.
4413 c           r0ij=1.02D0*rpp(iteli,itelj)
4414 c           r0ij=1.11D0*rpp(iteli,itelj)
4415             r0ij=2.20D0*rpp(iteli,itelj)
4416 c           r0ij=1.55D0*rpp(iteli,itelj)
4417             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4418             if (fcont.gt.0.0D0) then
4419               num_conti=num_conti+1
4420               if (num_conti.gt.maxconts) then
4421                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4422      &                         ' will skip next contacts for this conf.'
4423               else
4424                 jcont_hb(num_conti,i)=j
4425 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4426 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4427                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4428      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4429 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4430 C  terms.
4431                 d_cont(num_conti,i)=rij
4432 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4433 C     --- Electrostatic-interaction matrix ---
4434                 a_chuj(1,1,num_conti,i)=a22
4435                 a_chuj(1,2,num_conti,i)=a23
4436                 a_chuj(2,1,num_conti,i)=a32
4437                 a_chuj(2,2,num_conti,i)=a33
4438 C     --- Gradient of rij
4439                 do kkk=1,3
4440                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4441                 enddo
4442                 kkll=0
4443                 do k=1,2
4444                   do l=1,2
4445                     kkll=kkll+1
4446                     do m=1,3
4447                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4448                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4449                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4450                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4451                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4452                     enddo
4453                   enddo
4454                 enddo
4455                 ENDIF
4456                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4457 C Calculate contact energies
4458                 cosa4=4.0D0*cosa
4459                 wij=cosa-3.0D0*cosb*cosg
4460                 cosbg1=cosb+cosg
4461                 cosbg2=cosb-cosg
4462 c               fac3=dsqrt(-ael6i)/r0ij**3
4463                 fac3=dsqrt(-ael6i)*r3ij
4464 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4465                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4466                 if (ees0tmp.gt.0) then
4467                   ees0pij=dsqrt(ees0tmp)
4468                 else
4469                   ees0pij=0
4470                 endif
4471 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4472                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4473                 if (ees0tmp.gt.0) then
4474                   ees0mij=dsqrt(ees0tmp)
4475                 else
4476                   ees0mij=0
4477                 endif
4478 c               ees0mij=0.0D0
4479                 if (shield_mode.eq.0) then
4480                 fac_shield(i)=1.0d0
4481                 fac_shield(j)=1.0d0
4482                 else
4483                 ees0plist(num_conti,i)=j
4484 C                fac_shield(i)=0.4d0
4485 C                fac_shield(j)=0.6d0
4486                 endif
4487                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4488      &          *fac_shield(i)*fac_shield(j)
4489                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4490      &          *fac_shield(i)*fac_shield(j)
4491 C Diagnostics. Comment out or remove after debugging!
4492 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4493 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4494 c               ees0m(num_conti,i)=0.0D0
4495 C End diagnostics.
4496 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4497 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4498 C Angular derivatives of the contact function
4499                 ees0pij1=fac3/ees0pij
4500                 ees0mij1=fac3/ees0mij
4501                 fac3p=-3.0D0*fac3*rrmij
4502                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4503                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4504 c               ees0mij1=0.0D0
4505                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4506                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4507                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4508                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4509                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4510                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4511                 ecosap=ecosa1+ecosa2
4512                 ecosbp=ecosb1+ecosb2
4513                 ecosgp=ecosg1+ecosg2
4514                 ecosam=ecosa1-ecosa2
4515                 ecosbm=ecosb1-ecosb2
4516                 ecosgm=ecosg1-ecosg2
4517 C Diagnostics
4518 c               ecosap=ecosa1
4519 c               ecosbp=ecosb1
4520 c               ecosgp=ecosg1
4521 c               ecosam=0.0D0
4522 c               ecosbm=0.0D0
4523 c               ecosgm=0.0D0
4524 C End diagnostics
4525                 facont_hb(num_conti,i)=fcont
4526                 fprimcont=fprimcont/rij
4527 cd              facont_hb(num_conti,i)=1.0D0
4528 C Following line is for diagnostics.
4529 cd              fprimcont=0.0D0
4530                 do k=1,3
4531                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4532                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4533                 enddo
4534                 do k=1,3
4535                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4536                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4537                 enddo
4538                 gggp(1)=gggp(1)+ees0pijp*xj
4539                 gggp(2)=gggp(2)+ees0pijp*yj
4540                 gggp(3)=gggp(3)+ees0pijp*zj
4541                 gggm(1)=gggm(1)+ees0mijp*xj
4542                 gggm(2)=gggm(2)+ees0mijp*yj
4543                 gggm(3)=gggm(3)+ees0mijp*zj
4544 C Derivatives due to the contact function
4545                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4546                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4547                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4548                 do k=1,3
4549 c
4550 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4551 c          following the change of gradient-summation algorithm.
4552 c
4553 cgrad                  ghalfp=0.5D0*gggp(k)
4554 cgrad                  ghalfm=0.5D0*gggm(k)
4555                   gacontp_hb1(k,num_conti,i)=!ghalfp
4556      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4557      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4558      &          *fac_shield(i)*fac_shield(j)
4559
4560                   gacontp_hb2(k,num_conti,i)=!ghalfp
4561      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4562      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4563      &          *fac_shield(i)*fac_shield(j)
4564
4565                   gacontp_hb3(k,num_conti,i)=gggp(k)
4566      &          *fac_shield(i)*fac_shield(j)
4567
4568                   gacontm_hb1(k,num_conti,i)=!ghalfm
4569      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4570      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4571      &          *fac_shield(i)*fac_shield(j)
4572
4573                   gacontm_hb2(k,num_conti,i)=!ghalfm
4574      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4575      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4576      &          *fac_shield(i)*fac_shield(j)
4577
4578                   gacontm_hb3(k,num_conti,i)=gggm(k)
4579      &          *fac_shield(i)*fac_shield(j)
4580
4581                 enddo
4582 C Diagnostics. Comment out or remove after debugging!
4583 cdiag           do k=1,3
4584 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4585 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4586 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4587 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4588 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4589 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4590 cdiag           enddo
4591               ENDIF ! wcorr
4592               endif  ! num_conti.le.maxconts
4593             endif  ! fcont.gt.0
4594           endif    ! j.gt.i+1
4595           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4596             do k=1,4
4597               do l=1,3
4598                 ghalf=0.5d0*agg(l,k)
4599                 aggi(l,k)=aggi(l,k)+ghalf
4600                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4601                 aggj(l,k)=aggj(l,k)+ghalf
4602               enddo
4603             enddo
4604             if (j.eq.nres-1 .and. i.lt.j-2) then
4605               do k=1,4
4606                 do l=1,3
4607                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4608                 enddo
4609               enddo
4610             endif
4611           endif
4612 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4613       return
4614       end
4615 C-----------------------------------------------------------------------------
4616       subroutine eturn3(i,eello_turn3)
4617 C Third- and fourth-order contributions from turns
4618       implicit real*8 (a-h,o-z)
4619       include 'DIMENSIONS'
4620       include 'COMMON.IOUNITS'
4621       include 'COMMON.GEO'
4622       include 'COMMON.VAR'
4623       include 'COMMON.LOCAL'
4624       include 'COMMON.CHAIN'
4625       include 'COMMON.DERIV'
4626       include 'COMMON.INTERACT'
4627       include 'COMMON.CONTACTS'
4628       include 'COMMON.TORSION'
4629       include 'COMMON.VECTORS'
4630       include 'COMMON.FFIELD'
4631       include 'COMMON.CONTROL'
4632       include 'COMMON.SHIELD'
4633       dimension ggg(3)
4634       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4635      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4636      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4637      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4638      &  auxgmat2(2,2),auxgmatt2(2,2)
4639       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4640      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4641       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4642      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4643      &    num_conti,j1,j2
4644       j=i+2
4645 c      write (iout,*) "eturn3",i,j,j1,j2
4646       a_temp(1,1)=a22
4647       a_temp(1,2)=a23
4648       a_temp(2,1)=a32
4649       a_temp(2,2)=a33
4650 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4651 C
4652 C               Third-order contributions
4653 C
4654 C                 (i+2)o----(i+3)
4655 C                      | |
4656 C                      | |
4657 C                 (i+1)o----i
4658 C
4659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4660 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4661         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4662 c auxalary matices for theta gradient
4663 c auxalary matrix for i+1 and constant i+2
4664         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4665 c auxalary matrix for i+2 and constant i+1
4666         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4667         call transpose2(auxmat(1,1),auxmat1(1,1))
4668         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4669         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4670         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4671         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4672         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4673         if (shield_mode.eq.0) then
4674         fac_shield(i)=1.0
4675         fac_shield(j)=1.0
4676 C        else
4677 C        fac_shield(i)=0.4
4678 C        fac_shield(j)=0.6
4679         endif
4680         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4681      &  *fac_shield(i)*fac_shield(j)
4682         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4683      &  *fac_shield(i)*fac_shield(j)
4684 C Derivatives in theta
4685         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4686      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4687      &   *fac_shield(i)*fac_shield(j)
4688         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4689      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4690      &   *fac_shield(i)*fac_shield(j)
4691
4692
4693 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4694 C Derivatives in shield mode
4695           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4696      &  (shield_mode.gt.0)) then
4697 C          print *,i,j
4698
4699           do ilist=1,ishield_list(i)
4700            iresshield=shield_list(ilist,i)
4701            do k=1,3
4702            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4703 C     &      *2.0
4704            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4705      &              rlocshield
4706      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4707             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4708      &      +rlocshield
4709            enddo
4710           enddo
4711           do ilist=1,ishield_list(j)
4712            iresshield=shield_list(ilist,j)
4713            do k=1,3
4714            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4715 C     &     *2.0
4716            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4717      &              rlocshield
4718      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4719            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4720      &             +rlocshield
4721
4722            enddo
4723           enddo
4724
4725           do k=1,3
4726             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4727      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4728             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4729      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4730             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4731      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4732             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4733      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4734            enddo
4735            endif
4736
4737 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4738 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4739 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4740 cd     &    ' eello_turn3_num',4*eello_turn3_num
4741 C Derivatives in gamma(i)
4742         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4743         call transpose2(auxmat2(1,1),auxmat3(1,1))
4744         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4745         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4746      &   *fac_shield(i)*fac_shield(j)
4747 C Derivatives in gamma(i+1)
4748         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4749         call transpose2(auxmat2(1,1),auxmat3(1,1))
4750         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4751         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4752      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4753      &   *fac_shield(i)*fac_shield(j)
4754 C Cartesian derivatives
4755         do l=1,3
4756 c            ghalf1=0.5d0*agg(l,1)
4757 c            ghalf2=0.5d0*agg(l,2)
4758 c            ghalf3=0.5d0*agg(l,3)
4759 c            ghalf4=0.5d0*agg(l,4)
4760           a_temp(1,1)=aggi(l,1)!+ghalf1
4761           a_temp(1,2)=aggi(l,2)!+ghalf2
4762           a_temp(2,1)=aggi(l,3)!+ghalf3
4763           a_temp(2,2)=aggi(l,4)!+ghalf4
4764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4765           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4767      &   *fac_shield(i)*fac_shield(j)
4768
4769           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4770           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4771           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4772           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4773           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4774           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4775      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4776      &   *fac_shield(i)*fac_shield(j)
4777           a_temp(1,1)=aggj(l,1)!+ghalf1
4778           a_temp(1,2)=aggj(l,2)!+ghalf2
4779           a_temp(2,1)=aggj(l,3)!+ghalf3
4780           a_temp(2,2)=aggj(l,4)!+ghalf4
4781           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4782           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4783      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4784      &   *fac_shield(i)*fac_shield(j)
4785           a_temp(1,1)=aggj1(l,1)
4786           a_temp(1,2)=aggj1(l,2)
4787           a_temp(2,1)=aggj1(l,3)
4788           a_temp(2,2)=aggj1(l,4)
4789           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4790           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4791      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4792      &   *fac_shield(i)*fac_shield(j)
4793         enddo
4794       return
4795       end
4796 C-------------------------------------------------------------------------------
4797       subroutine eturn4(i,eello_turn4)
4798 C Third- and fourth-order contributions from turns
4799       implicit real*8 (a-h,o-z)
4800       include 'DIMENSIONS'
4801       include 'COMMON.IOUNITS'
4802       include 'COMMON.GEO'
4803       include 'COMMON.VAR'
4804       include 'COMMON.LOCAL'
4805       include 'COMMON.CHAIN'
4806       include 'COMMON.DERIV'
4807       include 'COMMON.INTERACT'
4808       include 'COMMON.CONTACTS'
4809       include 'COMMON.TORSION'
4810       include 'COMMON.VECTORS'
4811       include 'COMMON.FFIELD'
4812       include 'COMMON.CONTROL'
4813       include 'COMMON.SHIELD'
4814       dimension ggg(3)
4815       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4816      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4817      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4818      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4819      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4820      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4821      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4822       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4823      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4824       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4825      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4826      &    num_conti,j1,j2
4827       j=i+3
4828 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4829 C
4830 C               Fourth-order contributions
4831 C
4832 C                 (i+3)o----(i+4)
4833 C                     /  |
4834 C               (i+2)o   |
4835 C                     \  |
4836 C                 (i+1)o----i
4837 C
4838 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4839 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4840 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4841 c        write(iout,*)"WCHODZE W PROGRAM"
4842         a_temp(1,1)=a22
4843         a_temp(1,2)=a23
4844         a_temp(2,1)=a32
4845         a_temp(2,2)=a33
4846         iti1=itype2loc(itype(i+1))
4847         iti2=itype2loc(itype(i+2))
4848         iti3=itype2loc(itype(i+3))
4849 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4850         call transpose2(EUg(1,1,i+1),e1t(1,1))
4851         call transpose2(Eug(1,1,i+2),e2t(1,1))
4852         call transpose2(Eug(1,1,i+3),e3t(1,1))
4853 C Ematrix derivative in theta
4854         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4855         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4856         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4857         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4858 c       eta1 in derivative theta
4859         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4860         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4861 c       auxgvec is derivative of Ub2 so i+3 theta
4862         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4863 c       auxalary matrix of E i+1
4864         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4865 c        s1=0.0
4866 c        gs1=0.0
4867         s1=scalar2(b1(1,i+2),auxvec(1))
4868 c derivative of theta i+2 with constant i+3
4869         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4870 c derivative of theta i+2 with constant i+2
4871         gs32=scalar2(b1(1,i+2),auxgvec(1))
4872 c derivative of E matix in theta of i+1
4873         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4874
4875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4876 c       ea31 in derivative theta
4877         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4878         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4879 c auxilary matrix auxgvec of Ub2 with constant E matirx
4880         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4881 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4882         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4883
4884 c        s2=0.0
4885 c        gs2=0.0
4886         s2=scalar2(b1(1,i+1),auxvec(1))
4887 c derivative of theta i+1 with constant i+3
4888         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4889 c derivative of theta i+2 with constant i+1
4890         gs21=scalar2(b1(1,i+1),auxgvec(1))
4891 c derivative of theta i+3 with constant i+1
4892         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4893 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4894 c     &  gtb1(1,i+1)
4895         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4896 c two derivatives over diffetent matrices
4897 c gtae3e2 is derivative over i+3
4898         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4899 c ae3gte2 is derivative over i+2
4900         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4901         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4902 c three possible derivative over theta E matices
4903 c i+1
4904         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4905 c i+2
4906         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4907 c i+3
4908         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4909         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4910
4911         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4912         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4913         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4914         if (shield_mode.eq.0) then
4915         fac_shield(i)=1.0
4916         fac_shield(j)=1.0
4917 C        else
4918 C        fac_shield(i)=0.6
4919 C        fac_shield(j)=0.4
4920         endif
4921         eello_turn4=eello_turn4-(s1+s2+s3)
4922      &  *fac_shield(i)*fac_shield(j)
4923         eello_t4=-(s1+s2+s3)
4924      &  *fac_shield(i)*fac_shield(j)
4925 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4926         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4927      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4928 C Now derivative over shield:
4929           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4930      &  (shield_mode.gt.0)) then
4931 C          print *,i,j
4932
4933           do ilist=1,ishield_list(i)
4934            iresshield=shield_list(ilist,i)
4935            do k=1,3
4936            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4937 C     &      *2.0
4938            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4939      &              rlocshield
4940      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4941             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4942      &      +rlocshield
4943            enddo
4944           enddo
4945           do ilist=1,ishield_list(j)
4946            iresshield=shield_list(ilist,j)
4947            do k=1,3
4948            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4949 C     &     *2.0
4950            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4951      &              rlocshield
4952      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4953            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4954      &             +rlocshield
4955
4956            enddo
4957           enddo
4958
4959           do k=1,3
4960             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4961      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4962             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4963      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4964             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4965      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4966             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4967      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4968            enddo
4969            endif
4970
4971
4972
4973
4974
4975
4976 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4977 cd     &    ' eello_turn4_num',8*eello_turn4_num
4978 #ifdef NEWCORR
4979         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4980      &                  -(gs13+gsE13+gsEE1)*wturn4
4981      &  *fac_shield(i)*fac_shield(j)
4982         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4983      &                    -(gs23+gs21+gsEE2)*wturn4
4984      &  *fac_shield(i)*fac_shield(j)
4985
4986         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4987      &                    -(gs32+gsE31+gsEE3)*wturn4
4988      &  *fac_shield(i)*fac_shield(j)
4989
4990 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4991 c     &   gs2
4992 #endif
4993         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4994      &      'eturn4',i,j,-(s1+s2+s3)
4995 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4996 c     &    ' eello_turn4_num',8*eello_turn4_num
4997 C Derivatives in gamma(i)
4998         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4999         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5000         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5001         s1=scalar2(b1(1,i+2),auxvec(1))
5002         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5003         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5004         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5005      &  *fac_shield(i)*fac_shield(j)
5006 C Derivatives in gamma(i+1)
5007         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5008         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5009         s2=scalar2(b1(1,i+1),auxvec(1))
5010         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5011         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5012         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5013         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5014      &  *fac_shield(i)*fac_shield(j)
5015 C Derivatives in gamma(i+2)
5016         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5017         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5018         s1=scalar2(b1(1,i+2),auxvec(1))
5019         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5020         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5021         s2=scalar2(b1(1,i+1),auxvec(1))
5022         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5023         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5024         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5025         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5026      &  *fac_shield(i)*fac_shield(j)
5027 C Cartesian derivatives
5028 C Derivatives of this turn contributions in DC(i+2)
5029         if (j.lt.nres-1) then
5030           do l=1,3
5031             a_temp(1,1)=agg(l,1)
5032             a_temp(1,2)=agg(l,2)
5033             a_temp(2,1)=agg(l,3)
5034             a_temp(2,2)=agg(l,4)
5035             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5036             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5037             s1=scalar2(b1(1,i+2),auxvec(1))
5038             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5039             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5040             s2=scalar2(b1(1,i+1),auxvec(1))
5041             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5042             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5043             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5044             ggg(l)=-(s1+s2+s3)
5045             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5046      &  *fac_shield(i)*fac_shield(j)
5047           enddo
5048         endif
5049 C Remaining derivatives of this turn contribution
5050         do l=1,3
5051           a_temp(1,1)=aggi(l,1)
5052           a_temp(1,2)=aggi(l,2)
5053           a_temp(2,1)=aggi(l,3)
5054           a_temp(2,2)=aggi(l,4)
5055           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5056           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5057           s1=scalar2(b1(1,i+2),auxvec(1))
5058           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5059           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5060           s2=scalar2(b1(1,i+1),auxvec(1))
5061           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5062           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5063           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5064           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5065      &  *fac_shield(i)*fac_shield(j)
5066           a_temp(1,1)=aggi1(l,1)
5067           a_temp(1,2)=aggi1(l,2)
5068           a_temp(2,1)=aggi1(l,3)
5069           a_temp(2,2)=aggi1(l,4)
5070           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5071           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5072           s1=scalar2(b1(1,i+2),auxvec(1))
5073           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5074           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5075           s2=scalar2(b1(1,i+1),auxvec(1))
5076           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5077           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5078           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5079           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5080      &  *fac_shield(i)*fac_shield(j)
5081           a_temp(1,1)=aggj(l,1)
5082           a_temp(1,2)=aggj(l,2)
5083           a_temp(2,1)=aggj(l,3)
5084           a_temp(2,2)=aggj(l,4)
5085           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5086           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5087           s1=scalar2(b1(1,i+2),auxvec(1))
5088           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5089           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5090           s2=scalar2(b1(1,i+1),auxvec(1))
5091           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5092           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5093           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5094           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5095      &  *fac_shield(i)*fac_shield(j)
5096           a_temp(1,1)=aggj1(l,1)
5097           a_temp(1,2)=aggj1(l,2)
5098           a_temp(2,1)=aggj1(l,3)
5099           a_temp(2,2)=aggj1(l,4)
5100           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5101           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5102           s1=scalar2(b1(1,i+2),auxvec(1))
5103           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5104           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5105           s2=scalar2(b1(1,i+1),auxvec(1))
5106           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5107           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5108           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5109 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5110           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5111      &  *fac_shield(i)*fac_shield(j)
5112         enddo
5113       return
5114       end
5115 C-----------------------------------------------------------------------------
5116       subroutine vecpr(u,v,w)
5117       implicit real*8(a-h,o-z)
5118       dimension u(3),v(3),w(3)
5119       w(1)=u(2)*v(3)-u(3)*v(2)
5120       w(2)=-u(1)*v(3)+u(3)*v(1)
5121       w(3)=u(1)*v(2)-u(2)*v(1)
5122       return
5123       end
5124 C-----------------------------------------------------------------------------
5125       subroutine unormderiv(u,ugrad,unorm,ungrad)
5126 C This subroutine computes the derivatives of a normalized vector u, given
5127 C the derivatives computed without normalization conditions, ugrad. Returns
5128 C ungrad.
5129       implicit none
5130       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5131       double precision vec(3)
5132       double precision scalar
5133       integer i,j
5134 c      write (2,*) 'ugrad',ugrad
5135 c      write (2,*) 'u',u
5136       do i=1,3
5137         vec(i)=scalar(ugrad(1,i),u(1))
5138       enddo
5139 c      write (2,*) 'vec',vec
5140       do i=1,3
5141         do j=1,3
5142           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5143         enddo
5144       enddo
5145 c      write (2,*) 'ungrad',ungrad
5146       return
5147       end
5148 C-----------------------------------------------------------------------------
5149       subroutine escp_soft_sphere(evdw2,evdw2_14)
5150 C
5151 C This subroutine calculates the excluded-volume interaction energy between
5152 C peptide-group centers and side chains and its gradient in virtual-bond and
5153 C side-chain vectors.
5154 C
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.GEO'
5158       include 'COMMON.VAR'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.CHAIN'
5161       include 'COMMON.DERIV'
5162       include 'COMMON.INTERACT'
5163       include 'COMMON.FFIELD'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.CONTROL'
5166       dimension ggg(3)
5167       evdw2=0.0D0
5168       evdw2_14=0.0d0
5169       r0_scp=4.5d0
5170 cd    print '(a)','Enter ESCP'
5171 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5172 C      do xshift=-1,1
5173 C      do yshift=-1,1
5174 C      do zshift=-1,1
5175       do i=iatscp_s,iatscp_e
5176         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5177         iteli=itel(i)
5178         xi=0.5D0*(c(1,i)+c(1,i+1))
5179         yi=0.5D0*(c(2,i)+c(2,i+1))
5180         zi=0.5D0*(c(3,i)+c(3,i+1))
5181 C Return atom into box, boxxsize is size of box in x dimension
5182 c  134   continue
5183 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5184 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5185 C Condition for being inside the proper box
5186 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5187 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5188 c        go to 134
5189 c        endif
5190 c  135   continue
5191 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5192 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5193 C Condition for being inside the proper box
5194 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5195 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5196 c        go to 135
5197 c c       endif
5198 c  136   continue
5199 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5200 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5201 cC Condition for being inside the proper box
5202 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5203 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5204 c        go to 136
5205 c        endif
5206           xi=mod(xi,boxxsize)
5207           if (xi.lt.0) xi=xi+boxxsize
5208           yi=mod(yi,boxysize)
5209           if (yi.lt.0) yi=yi+boxysize
5210           zi=mod(zi,boxzsize)
5211           if (zi.lt.0) zi=zi+boxzsize
5212 C          xi=xi+xshift*boxxsize
5213 C          yi=yi+yshift*boxysize
5214 C          zi=zi+zshift*boxzsize
5215         do iint=1,nscp_gr(i)
5216
5217         do j=iscpstart(i,iint),iscpend(i,iint)
5218           if (itype(j).eq.ntyp1) cycle
5219           itypj=iabs(itype(j))
5220 C Uncomment following three lines for SC-p interactions
5221 c         xj=c(1,nres+j)-xi
5222 c         yj=c(2,nres+j)-yi
5223 c         zj=c(3,nres+j)-zi
5224 C Uncomment following three lines for Ca-p interactions
5225           xj=c(1,j)
5226           yj=c(2,j)
5227           zj=c(3,j)
5228 c  174   continue
5229 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5230 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5231 C Condition for being inside the proper box
5232 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5233 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5234 c        go to 174
5235 c        endif
5236 c  175   continue
5237 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5238 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5239 cC Condition for being inside the proper box
5240 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5241 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5242 c        go to 175
5243 c        endif
5244 c  176   continue
5245 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5246 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5247 C Condition for being inside the proper box
5248 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5249 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5250 c        go to 176
5251           xj=mod(xj,boxxsize)
5252           if (xj.lt.0) xj=xj+boxxsize
5253           yj=mod(yj,boxysize)
5254           if (yj.lt.0) yj=yj+boxysize
5255           zj=mod(zj,boxzsize)
5256           if (zj.lt.0) zj=zj+boxzsize
5257       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5258       xj_safe=xj
5259       yj_safe=yj
5260       zj_safe=zj
5261       subchap=0
5262       do xshift=-1,1
5263       do yshift=-1,1
5264       do zshift=-1,1
5265           xj=xj_safe+xshift*boxxsize
5266           yj=yj_safe+yshift*boxysize
5267           zj=zj_safe+zshift*boxzsize
5268           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5269           if(dist_temp.lt.dist_init) then
5270             dist_init=dist_temp
5271             xj_temp=xj
5272             yj_temp=yj
5273             zj_temp=zj
5274             subchap=1
5275           endif
5276        enddo
5277        enddo
5278        enddo
5279        if (subchap.eq.1) then
5280           xj=xj_temp-xi
5281           yj=yj_temp-yi
5282           zj=zj_temp-zi
5283        else
5284           xj=xj_safe-xi
5285           yj=yj_safe-yi
5286           zj=zj_safe-zi
5287        endif
5288 c c       endif
5289 C          xj=xj-xi
5290 C          yj=yj-yi
5291 C          zj=zj-zi
5292           rij=xj*xj+yj*yj+zj*zj
5293
5294           r0ij=r0_scp
5295           r0ijsq=r0ij*r0ij
5296           if (rij.lt.r0ijsq) then
5297             evdwij=0.25d0*(rij-r0ijsq)**2
5298             fac=rij-r0ijsq
5299           else
5300             evdwij=0.0d0
5301             fac=0.0d0
5302           endif
5303           evdw2=evdw2+evdwij
5304 C
5305 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5306 C
5307           ggg(1)=xj*fac
5308           ggg(2)=yj*fac
5309           ggg(3)=zj*fac
5310 cgrad          if (j.lt.i) then
5311 cd          write (iout,*) 'j<i'
5312 C Uncomment following three lines for SC-p interactions
5313 c           do k=1,3
5314 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5315 c           enddo
5316 cgrad          else
5317 cd          write (iout,*) 'j>i'
5318 cgrad            do k=1,3
5319 cgrad              ggg(k)=-ggg(k)
5320 C Uncomment following line for SC-p interactions
5321 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5322 cgrad            enddo
5323 cgrad          endif
5324 cgrad          do k=1,3
5325 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5326 cgrad          enddo
5327 cgrad          kstart=min0(i+1,j)
5328 cgrad          kend=max0(i-1,j-1)
5329 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5330 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5331 cgrad          do k=kstart,kend
5332 cgrad            do l=1,3
5333 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5334 cgrad            enddo
5335 cgrad          enddo
5336           do k=1,3
5337             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5338             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5339           enddo
5340         enddo
5341
5342         enddo ! iint
5343       enddo ! i
5344 C      enddo !zshift
5345 C      enddo !yshift
5346 C      enddo !xshift
5347       return
5348       end
5349 C-----------------------------------------------------------------------------
5350       subroutine escp(evdw2,evdw2_14)
5351 C
5352 C This subroutine calculates the excluded-volume interaction energy between
5353 C peptide-group centers and side chains and its gradient in virtual-bond and
5354 C side-chain vectors.
5355 C
5356       implicit real*8 (a-h,o-z)
5357       include 'DIMENSIONS'
5358       include 'COMMON.GEO'
5359       include 'COMMON.VAR'
5360       include 'COMMON.LOCAL'
5361       include 'COMMON.CHAIN'
5362       include 'COMMON.DERIV'
5363       include 'COMMON.INTERACT'
5364       include 'COMMON.FFIELD'
5365       include 'COMMON.IOUNITS'
5366       include 'COMMON.CONTROL'
5367       include 'COMMON.SPLITELE'
5368       dimension ggg(3)
5369       evdw2=0.0D0
5370       evdw2_14=0.0d0
5371 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5372 cd    print '(a)','Enter ESCP'
5373 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5374 C      do xshift=-1,1
5375 C      do yshift=-1,1
5376 C      do zshift=-1,1
5377       do i=iatscp_s,iatscp_e
5378         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5379         iteli=itel(i)
5380         xi=0.5D0*(c(1,i)+c(1,i+1))
5381         yi=0.5D0*(c(2,i)+c(2,i+1))
5382         zi=0.5D0*(c(3,i)+c(3,i+1))
5383           xi=mod(xi,boxxsize)
5384           if (xi.lt.0) xi=xi+boxxsize
5385           yi=mod(yi,boxysize)
5386           if (yi.lt.0) yi=yi+boxysize
5387           zi=mod(zi,boxzsize)
5388           if (zi.lt.0) zi=zi+boxzsize
5389 c          xi=xi+xshift*boxxsize
5390 c          yi=yi+yshift*boxysize
5391 c          zi=zi+zshift*boxzsize
5392 c        print *,xi,yi,zi,'polozenie i'
5393 C Return atom into box, boxxsize is size of box in x dimension
5394 c  134   continue
5395 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5396 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5397 C Condition for being inside the proper box
5398 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5399 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5400 c        go to 134
5401 c        endif
5402 c  135   continue
5403 c          print *,xi,boxxsize,"pierwszy"
5404
5405 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5406 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5407 C Condition for being inside the proper box
5408 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5409 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5410 c        go to 135
5411 c        endif
5412 c  136   continue
5413 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5414 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5415 C Condition for being inside the proper box
5416 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5417 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5418 c        go to 136
5419 c        endif
5420         do iint=1,nscp_gr(i)
5421
5422         do j=iscpstart(i,iint),iscpend(i,iint)
5423           itypj=iabs(itype(j))
5424           if (itypj.eq.ntyp1) cycle
5425 C Uncomment following three lines for SC-p interactions
5426 c         xj=c(1,nres+j)-xi
5427 c         yj=c(2,nres+j)-yi
5428 c         zj=c(3,nres+j)-zi
5429 C Uncomment following three lines for Ca-p interactions
5430           xj=c(1,j)
5431           yj=c(2,j)
5432           zj=c(3,j)
5433           xj=mod(xj,boxxsize)
5434           if (xj.lt.0) xj=xj+boxxsize
5435           yj=mod(yj,boxysize)
5436           if (yj.lt.0) yj=yj+boxysize
5437           zj=mod(zj,boxzsize)
5438           if (zj.lt.0) zj=zj+boxzsize
5439 c  174   continue
5440 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5441 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5442 C Condition for being inside the proper box
5443 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5444 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5445 c        go to 174
5446 c        endif
5447 c  175   continue
5448 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5449 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5450 cC Condition for being inside the proper box
5451 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5452 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5453 c        go to 175
5454 c        endif
5455 c  176   continue
5456 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5457 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5458 C Condition for being inside the proper box
5459 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5460 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5461 c        go to 176
5462 c        endif
5463 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5464       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5465       xj_safe=xj
5466       yj_safe=yj
5467       zj_safe=zj
5468       subchap=0
5469       do xshift=-1,1
5470       do yshift=-1,1
5471       do zshift=-1,1
5472           xj=xj_safe+xshift*boxxsize
5473           yj=yj_safe+yshift*boxysize
5474           zj=zj_safe+zshift*boxzsize
5475           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5476           if(dist_temp.lt.dist_init) then
5477             dist_init=dist_temp
5478             xj_temp=xj
5479             yj_temp=yj
5480             zj_temp=zj
5481             subchap=1
5482           endif
5483        enddo
5484        enddo
5485        enddo
5486        if (subchap.eq.1) then
5487           xj=xj_temp-xi
5488           yj=yj_temp-yi
5489           zj=zj_temp-zi
5490        else
5491           xj=xj_safe-xi
5492           yj=yj_safe-yi
5493           zj=zj_safe-zi
5494        endif
5495 c          print *,xj,yj,zj,'polozenie j'
5496           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5497 c          print *,rrij
5498           sss=sscale(1.0d0/(dsqrt(rrij)))
5499 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5500 c          if (sss.eq.0) print *,'czasem jest OK'
5501           if (sss.le.0.0d0) cycle
5502           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5503           fac=rrij**expon2
5504           e1=fac*fac*aad(itypj,iteli)
5505           e2=fac*bad(itypj,iteli)
5506           if (iabs(j-i) .le. 2) then
5507             e1=scal14*e1
5508             e2=scal14*e2
5509             evdw2_14=evdw2_14+(e1+e2)*sss
5510           endif
5511           evdwij=e1+e2
5512           evdw2=evdw2+evdwij*sss
5513           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5514      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5515      &       bad(itypj,iteli)
5516 C
5517 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5518 C
5519           fac=-(evdwij+e1)*rrij*sss
5520           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5521           ggg(1)=xj*fac
5522           ggg(2)=yj*fac
5523           ggg(3)=zj*fac
5524 cgrad          if (j.lt.i) then
5525 cd          write (iout,*) 'j<i'
5526 C Uncomment following three lines for SC-p interactions
5527 c           do k=1,3
5528 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5529 c           enddo
5530 cgrad          else
5531 cd          write (iout,*) 'j>i'
5532 cgrad            do k=1,3
5533 cgrad              ggg(k)=-ggg(k)
5534 C Uncomment following line for SC-p interactions
5535 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5536 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5537 cgrad            enddo
5538 cgrad          endif
5539 cgrad          do k=1,3
5540 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5541 cgrad          enddo
5542 cgrad          kstart=min0(i+1,j)
5543 cgrad          kend=max0(i-1,j-1)
5544 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5545 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5546 cgrad          do k=kstart,kend
5547 cgrad            do l=1,3
5548 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5549 cgrad            enddo
5550 cgrad          enddo
5551           do k=1,3
5552             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5553             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5554           enddo
5555 c        endif !endif for sscale cutoff
5556         enddo ! j
5557
5558         enddo ! iint
5559       enddo ! i
5560 c      enddo !zshift
5561 c      enddo !yshift
5562 c      enddo !xshift
5563       do i=1,nct
5564         do j=1,3
5565           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5566           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5567           gradx_scp(j,i)=expon*gradx_scp(j,i)
5568         enddo
5569       enddo
5570 C******************************************************************************
5571 C
5572 C                              N O T E !!!
5573 C
5574 C To save time the factor EXPON has been extracted from ALL components
5575 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5576 C use!
5577 C
5578 C******************************************************************************
5579       return
5580       end
5581 C--------------------------------------------------------------------------
5582       subroutine edis(ehpb)
5583 C
5584 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5585 C
5586       implicit real*8 (a-h,o-z)
5587       include 'DIMENSIONS'
5588       include 'COMMON.SBRIDGE'
5589       include 'COMMON.CHAIN'
5590       include 'COMMON.DERIV'
5591       include 'COMMON.VAR'
5592       include 'COMMON.INTERACT'
5593       include 'COMMON.IOUNITS'
5594       include 'COMMON.CONTROL'
5595       dimension ggg(3)
5596       ehpb=0.0D0
5597       do i=1,3
5598        ggg(i)=0.0d0
5599       enddo
5600 C      write (iout,*) ,"link_end",link_end,constr_dist
5601 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5602 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5603       if (link_end.eq.0) return
5604       do i=link_start,link_end
5605 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5606 C CA-CA distance used in regularization of structure.
5607         ii=ihpb(i)
5608         jj=jhpb(i)
5609 C iii and jjj point to the residues for which the distance is assigned.
5610         if (ii.gt.nres) then
5611           iii=ii-nres
5612           jjj=jj-nres
5613         else
5614           iii=ii
5615           jjj=jj
5616         endif
5617 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5618 c     &    dhpb(i),dhpb1(i),forcon(i)
5619 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5620 C    distance and angle dependent SS bond potential.
5621 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5622 C     & iabs(itype(jjj)).eq.1) then
5623 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5624 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5625         if (.not.dyn_ss .and. i.le.nss) then
5626 C 15/02/13 CC dynamic SSbond - additional check
5627          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5628      & iabs(itype(jjj)).eq.1) then
5629           call ssbond_ene(iii,jjj,eij)
5630           ehpb=ehpb+2*eij
5631          endif
5632 cd          write (iout,*) "eij",eij
5633 cd   &   ' waga=',waga,' fac=',fac
5634         else if (ii.gt.nres .and. jj.gt.nres) then
5635 c Restraints from contact prediction
5636           dd=dist(ii,jj)
5637           if (constr_dist.eq.11) then
5638             ehpb=ehpb+fordepth(i)**4.0d0
5639      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5640             fac=fordepth(i)**4.0d0
5641      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5642           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5643      &    ehpb,fordepth(i),dd
5644            else
5645           if (dhpb1(i).gt.0.0d0) then
5646             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5647             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5648 c            write (iout,*) "beta nmr",
5649 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5650           else
5651             dd=dist(ii,jj)
5652             rdis=dd-dhpb(i)
5653 C Get the force constant corresponding to this distance.
5654             waga=forcon(i)
5655 C Calculate the contribution to energy.
5656             ehpb=ehpb+waga*rdis*rdis
5657 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5658 C
5659 C Evaluate gradient.
5660 C
5661             fac=waga*rdis/dd
5662           endif
5663           endif
5664           do j=1,3
5665             ggg(j)=fac*(c(j,jj)-c(j,ii))
5666           enddo
5667           do j=1,3
5668             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5669             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5670           enddo
5671           do k=1,3
5672             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5673             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5674           enddo
5675         else
5676 C Calculate the distance between the two points and its difference from the
5677 C target distance.
5678           dd=dist(ii,jj)
5679           if (constr_dist.eq.11) then
5680             ehpb=ehpb+fordepth(i)**4.0d0
5681      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5682             fac=fordepth(i)**4.0d0
5683      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5684           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5685      &    ehpb,fordepth(i),dd
5686            else
5687           if (dhpb1(i).gt.0.0d0) then
5688             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5689             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5690 c            write (iout,*) "alph nmr",
5691 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5692           else
5693             rdis=dd-dhpb(i)
5694 C Get the force constant corresponding to this distance.
5695             waga=forcon(i)
5696 C Calculate the contribution to energy.
5697             ehpb=ehpb+waga*rdis*rdis
5698 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5699 C
5700 C Evaluate gradient.
5701 C
5702             fac=waga*rdis/dd
5703           endif
5704           endif
5705             do j=1,3
5706               ggg(j)=fac*(c(j,jj)-c(j,ii))
5707             enddo
5708 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5709 C If this is a SC-SC distance, we need to calculate the contributions to the
5710 C Cartesian gradient in the SC vectors (ghpbx).
5711           if (iii.lt.ii) then
5712           do j=1,3
5713             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5714             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5715           enddo
5716           endif
5717 cgrad        do j=iii,jjj-1
5718 cgrad          do k=1,3
5719 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5720 cgrad          enddo
5721 cgrad        enddo
5722           do k=1,3
5723             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5724             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5725           enddo
5726         endif
5727       enddo
5728       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5729       return
5730       end
5731 C--------------------------------------------------------------------------
5732       subroutine ssbond_ene(i,j,eij)
5733 C
5734 C Calculate the distance and angle dependent SS-bond potential energy
5735 C using a free-energy function derived based on RHF/6-31G** ab initio
5736 C calculations of diethyl disulfide.
5737 C
5738 C A. Liwo and U. Kozlowska, 11/24/03
5739 C
5740       implicit real*8 (a-h,o-z)
5741       include 'DIMENSIONS'
5742       include 'COMMON.SBRIDGE'
5743       include 'COMMON.CHAIN'
5744       include 'COMMON.DERIV'
5745       include 'COMMON.LOCAL'
5746       include 'COMMON.INTERACT'
5747       include 'COMMON.VAR'
5748       include 'COMMON.IOUNITS'
5749       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5750       itypi=iabs(itype(i))
5751       xi=c(1,nres+i)
5752       yi=c(2,nres+i)
5753       zi=c(3,nres+i)
5754       dxi=dc_norm(1,nres+i)
5755       dyi=dc_norm(2,nres+i)
5756       dzi=dc_norm(3,nres+i)
5757 c      dsci_inv=dsc_inv(itypi)
5758       dsci_inv=vbld_inv(nres+i)
5759       itypj=iabs(itype(j))
5760 c      dscj_inv=dsc_inv(itypj)
5761       dscj_inv=vbld_inv(nres+j)
5762       xj=c(1,nres+j)-xi
5763       yj=c(2,nres+j)-yi
5764       zj=c(3,nres+j)-zi
5765       dxj=dc_norm(1,nres+j)
5766       dyj=dc_norm(2,nres+j)
5767       dzj=dc_norm(3,nres+j)
5768       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5769       rij=dsqrt(rrij)
5770       erij(1)=xj*rij
5771       erij(2)=yj*rij
5772       erij(3)=zj*rij
5773       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5774       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5775       om12=dxi*dxj+dyi*dyj+dzi*dzj
5776       do k=1,3
5777         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5778         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5779       enddo
5780       rij=1.0d0/rij
5781       deltad=rij-d0cm
5782       deltat1=1.0d0-om1
5783       deltat2=1.0d0+om2
5784       deltat12=om2-om1+2.0d0
5785       cosphi=om12-om1*om2
5786       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5787      &  +akct*deltad*deltat12
5788      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5789 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5790 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5791 c     &  " deltat12",deltat12," eij",eij
5792       ed=2*akcm*deltad+akct*deltat12
5793       pom1=akct*deltad
5794       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5795       eom1=-2*akth*deltat1-pom1-om2*pom2
5796       eom2= 2*akth*deltat2+pom1-om1*pom2
5797       eom12=pom2
5798       do k=1,3
5799         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5800         ghpbx(k,i)=ghpbx(k,i)-ggk
5801      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5802      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5803         ghpbx(k,j)=ghpbx(k,j)+ggk
5804      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5805      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5806         ghpbc(k,i)=ghpbc(k,i)-ggk
5807         ghpbc(k,j)=ghpbc(k,j)+ggk
5808       enddo
5809 C
5810 C Calculate the components of the gradient in DC and X
5811 C
5812 cgrad      do k=i,j-1
5813 cgrad        do l=1,3
5814 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5815 cgrad        enddo
5816 cgrad      enddo
5817       return
5818       end
5819 C--------------------------------------------------------------------------
5820       subroutine ebond(estr)
5821 c
5822 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5823 c
5824       implicit real*8 (a-h,o-z)
5825       include 'DIMENSIONS'
5826       include 'COMMON.LOCAL'
5827       include 'COMMON.GEO'
5828       include 'COMMON.INTERACT'
5829       include 'COMMON.DERIV'
5830       include 'COMMON.VAR'
5831       include 'COMMON.CHAIN'
5832       include 'COMMON.IOUNITS'
5833       include 'COMMON.NAMES'
5834       include 'COMMON.FFIELD'
5835       include 'COMMON.CONTROL'
5836       include 'COMMON.SETUP'
5837       double precision u(3),ud(3)
5838       estr=0.0d0
5839       estr1=0.0d0
5840       do i=ibondp_start,ibondp_end
5841         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5842 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5843 c          do j=1,3
5844 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5845 c     &      *dc(j,i-1)/vbld(i)
5846 c          enddo
5847 c          if (energy_dec) write(iout,*)
5848 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5849 c        else
5850 C       Checking if it involves dummy (NH3+ or COO-) group
5851          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5852 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5853         diff = vbld(i)-vbldpDUM
5854         if (energy_dec) write(iout,*) "dum_bond",i,diff
5855          else
5856 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5857         diff = vbld(i)-vbldp0
5858          endif
5859         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5860      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5861         estr=estr+diff*diff
5862         do j=1,3
5863           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5864         enddo
5865 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5866 c        endif
5867       enddo
5868
5869       estr=0.5d0*AKP*estr+estr1
5870 c
5871 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5872 c
5873       do i=ibond_start,ibond_end
5874         iti=iabs(itype(i))
5875         if (iti.ne.10 .and. iti.ne.ntyp1) then
5876           nbi=nbondterm(iti)
5877           if (nbi.eq.1) then
5878             diff=vbld(i+nres)-vbldsc0(1,iti)
5879             if (energy_dec)  write (iout,*)
5880      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5881      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5882             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5883             do j=1,3
5884               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5885             enddo
5886           else
5887             do j=1,nbi
5888               diff=vbld(i+nres)-vbldsc0(j,iti)
5889               ud(j)=aksc(j,iti)*diff
5890               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5891             enddo
5892             uprod=u(1)
5893             do j=2,nbi
5894               uprod=uprod*u(j)
5895             enddo
5896             usum=0.0d0
5897             usumsqder=0.0d0
5898             do j=1,nbi
5899               uprod1=1.0d0
5900               uprod2=1.0d0
5901               do k=1,nbi
5902                 if (k.ne.j) then
5903                   uprod1=uprod1*u(k)
5904                   uprod2=uprod2*u(k)*u(k)
5905                 endif
5906               enddo
5907               usum=usum+uprod1
5908               usumsqder=usumsqder+ud(j)*uprod2
5909             enddo
5910             estr=estr+uprod/usum
5911             do j=1,3
5912              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5913             enddo
5914           endif
5915         endif
5916       enddo
5917       return
5918       end
5919 #ifdef CRYST_THETA
5920 C--------------------------------------------------------------------------
5921       subroutine ebend(etheta,ethetacnstr)
5922 C
5923 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5924 C angles gamma and its derivatives in consecutive thetas and gammas.
5925 C
5926       implicit real*8 (a-h,o-z)
5927       include 'DIMENSIONS'
5928       include 'COMMON.LOCAL'
5929       include 'COMMON.GEO'
5930       include 'COMMON.INTERACT'
5931       include 'COMMON.DERIV'
5932       include 'COMMON.VAR'
5933       include 'COMMON.CHAIN'
5934       include 'COMMON.IOUNITS'
5935       include 'COMMON.NAMES'
5936       include 'COMMON.FFIELD'
5937       include 'COMMON.CONTROL'
5938       include 'COMMON.TORCNSTR'
5939       common /calcthet/ term1,term2,termm,diffak,ratak,
5940      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5941      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5942       double precision y(2),z(2)
5943       delta=0.02d0*pi
5944 c      time11=dexp(-2*time)
5945 c      time12=1.0d0
5946       etheta=0.0D0
5947 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5948       do i=ithet_start,ithet_end
5949         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5950      &  .or.itype(i).eq.ntyp1) cycle
5951 C Zero the energy function and its derivative at 0 or pi.
5952         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5953         it=itype(i-1)
5954         ichir1=isign(1,itype(i-2))
5955         ichir2=isign(1,itype(i))
5956          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5957          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5958          if (itype(i-1).eq.10) then
5959           itype1=isign(10,itype(i-2))
5960           ichir11=isign(1,itype(i-2))
5961           ichir12=isign(1,itype(i-2))
5962           itype2=isign(10,itype(i))
5963           ichir21=isign(1,itype(i))
5964           ichir22=isign(1,itype(i))
5965          endif
5966
5967         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5968 #ifdef OSF
5969           phii=phi(i)
5970           if (phii.ne.phii) phii=150.0
5971 #else
5972           phii=phi(i)
5973 #endif
5974           y(1)=dcos(phii)
5975           y(2)=dsin(phii)
5976         else
5977           y(1)=0.0D0
5978           y(2)=0.0D0
5979         endif
5980         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5981 #ifdef OSF
5982           phii1=phi(i+1)
5983           if (phii1.ne.phii1) phii1=150.0
5984           phii1=pinorm(phii1)
5985           z(1)=cos(phii1)
5986 #else
5987           phii1=phi(i+1)
5988 #endif
5989           z(1)=dcos(phii1)
5990           z(2)=dsin(phii1)
5991         else
5992           z(1)=0.0D0
5993           z(2)=0.0D0
5994         endif
5995 C Calculate the "mean" value of theta from the part of the distribution
5996 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5997 C In following comments this theta will be referred to as t_c.
5998         thet_pred_mean=0.0d0
5999         do k=1,2
6000             athetk=athet(k,it,ichir1,ichir2)
6001             bthetk=bthet(k,it,ichir1,ichir2)
6002           if (it.eq.10) then
6003              athetk=athet(k,itype1,ichir11,ichir12)
6004              bthetk=bthet(k,itype2,ichir21,ichir22)
6005           endif
6006          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6007 c         write(iout,*) 'chuj tu', y(k),z(k)
6008         enddo
6009         dthett=thet_pred_mean*ssd
6010         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6011 C Derivatives of the "mean" values in gamma1 and gamma2.
6012         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6013      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6014          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6015      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6016          if (it.eq.10) then
6017       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6018      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6019         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6020      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6021          endif
6022         if (theta(i).gt.pi-delta) then
6023           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6024      &         E_tc0)
6025           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6026           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6027           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6028      &        E_theta)
6029           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6030      &        E_tc)
6031         else if (theta(i).lt.delta) then
6032           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6033           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6034           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6035      &        E_theta)
6036           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6037           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6038      &        E_tc)
6039         else
6040           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6041      &        E_theta,E_tc)
6042         endif
6043         etheta=etheta+ethetai
6044         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6045      &      'ebend',i,ethetai,theta(i),itype(i)
6046         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6047         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6048         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6049       enddo
6050       ethetacnstr=0.0d0
6051 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6052       do i=ithetaconstr_start,ithetaconstr_end
6053         itheta=itheta_constr(i)
6054         thetiii=theta(itheta)
6055         difi=pinorm(thetiii-theta_constr0(i))
6056         if (difi.gt.theta_drange(i)) then
6057           difi=difi-theta_drange(i)
6058           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6059           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6060      &    +for_thet_constr(i)*difi**3
6061         else if (difi.lt.-drange(i)) then
6062           difi=difi+drange(i)
6063           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6064           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6065      &    +for_thet_constr(i)*difi**3
6066         else
6067           difi=0.0
6068         endif
6069        if (energy_dec) then
6070         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6071      &    i,itheta,rad2deg*thetiii,
6072      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6073      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6074      &    gloc(itheta+nphi-2,icg)
6075         endif
6076       enddo
6077
6078 C Ufff.... We've done all this!!!
6079       return
6080       end
6081 C---------------------------------------------------------------------------
6082       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6083      &     E_tc)
6084       implicit real*8 (a-h,o-z)
6085       include 'DIMENSIONS'
6086       include 'COMMON.LOCAL'
6087       include 'COMMON.IOUNITS'
6088       common /calcthet/ term1,term2,termm,diffak,ratak,
6089      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6090      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6091 C Calculate the contributions to both Gaussian lobes.
6092 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6093 C The "polynomial part" of the "standard deviation" of this part of
6094 C the distributioni.
6095 ccc        write (iout,*) thetai,thet_pred_mean
6096         sig=polthet(3,it)
6097         do j=2,0,-1
6098           sig=sig*thet_pred_mean+polthet(j,it)
6099         enddo
6100 C Derivative of the "interior part" of the "standard deviation of the"
6101 C gamma-dependent Gaussian lobe in t_c.
6102         sigtc=3*polthet(3,it)
6103         do j=2,1,-1
6104           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6105         enddo
6106         sigtc=sig*sigtc
6107 C Set the parameters of both Gaussian lobes of the distribution.
6108 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6109         fac=sig*sig+sigc0(it)
6110         sigcsq=fac+fac
6111         sigc=1.0D0/sigcsq
6112 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6113         sigsqtc=-4.0D0*sigcsq*sigtc
6114 c       print *,i,sig,sigtc,sigsqtc
6115 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6116         sigtc=-sigtc/(fac*fac)
6117 C Following variable is sigma(t_c)**(-2)
6118         sigcsq=sigcsq*sigcsq
6119         sig0i=sig0(it)
6120         sig0inv=1.0D0/sig0i**2
6121         delthec=thetai-thet_pred_mean
6122         delthe0=thetai-theta0i
6123         term1=-0.5D0*sigcsq*delthec*delthec
6124         term2=-0.5D0*sig0inv*delthe0*delthe0
6125 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6126 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6127 C NaNs in taking the logarithm. We extract the largest exponent which is added
6128 C to the energy (this being the log of the distribution) at the end of energy
6129 C term evaluation for this virtual-bond angle.
6130         if (term1.gt.term2) then
6131           termm=term1
6132           term2=dexp(term2-termm)
6133           term1=1.0d0
6134         else
6135           termm=term2
6136           term1=dexp(term1-termm)
6137           term2=1.0d0
6138         endif
6139 C The ratio between the gamma-independent and gamma-dependent lobes of
6140 C the distribution is a Gaussian function of thet_pred_mean too.
6141         diffak=gthet(2,it)-thet_pred_mean
6142         ratak=diffak/gthet(3,it)**2
6143         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6144 C Let's differentiate it in thet_pred_mean NOW.
6145         aktc=ak*ratak
6146 C Now put together the distribution terms to make complete distribution.
6147         termexp=term1+ak*term2
6148         termpre=sigc+ak*sig0i
6149 C Contribution of the bending energy from this theta is just the -log of
6150 C the sum of the contributions from the two lobes and the pre-exponential
6151 C factor. Simple enough, isn't it?
6152         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6153 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6154 C NOW the derivatives!!!
6155 C 6/6/97 Take into account the deformation.
6156         E_theta=(delthec*sigcsq*term1
6157      &       +ak*delthe0*sig0inv*term2)/termexp
6158         E_tc=((sigtc+aktc*sig0i)/termpre
6159      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6160      &       aktc*term2)/termexp)
6161       return
6162       end
6163 c-----------------------------------------------------------------------------
6164       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6165       implicit real*8 (a-h,o-z)
6166       include 'DIMENSIONS'
6167       include 'COMMON.LOCAL'
6168       include 'COMMON.IOUNITS'
6169       common /calcthet/ term1,term2,termm,diffak,ratak,
6170      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6171      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6172       delthec=thetai-thet_pred_mean
6173       delthe0=thetai-theta0i
6174 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6175       t3 = thetai-thet_pred_mean
6176       t6 = t3**2
6177       t9 = term1
6178       t12 = t3*sigcsq
6179       t14 = t12+t6*sigsqtc
6180       t16 = 1.0d0
6181       t21 = thetai-theta0i
6182       t23 = t21**2
6183       t26 = term2
6184       t27 = t21*t26
6185       t32 = termexp
6186       t40 = t32**2
6187       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6188      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6189      & *(-t12*t9-ak*sig0inv*t27)
6190       return
6191       end
6192 #else
6193 C--------------------------------------------------------------------------
6194       subroutine ebend(etheta,ethetacnstr)
6195 C
6196 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6197 C angles gamma and its derivatives in consecutive thetas and gammas.
6198 C ab initio-derived potentials from
6199 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6200 C
6201       implicit real*8 (a-h,o-z)
6202       include 'DIMENSIONS'
6203       include 'COMMON.LOCAL'
6204       include 'COMMON.GEO'
6205       include 'COMMON.INTERACT'
6206       include 'COMMON.DERIV'
6207       include 'COMMON.VAR'
6208       include 'COMMON.CHAIN'
6209       include 'COMMON.IOUNITS'
6210       include 'COMMON.NAMES'
6211       include 'COMMON.FFIELD'
6212       include 'COMMON.CONTROL'
6213       include 'COMMON.TORCNSTR'
6214       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6215      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6216      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6217      & sinph1ph2(maxdouble,maxdouble)
6218       logical lprn /.false./, lprn1 /.false./
6219       etheta=0.0D0
6220       do i=ithet_start,ithet_end
6221 c        print *,i,itype(i-1),itype(i),itype(i-2)
6222         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6223      &  .or.itype(i).eq.ntyp1) cycle
6224 C        print *,i,theta(i)
6225         if (iabs(itype(i+1)).eq.20) iblock=2
6226         if (iabs(itype(i+1)).ne.20) iblock=1
6227         dethetai=0.0d0
6228         dephii=0.0d0
6229         dephii1=0.0d0
6230         theti2=0.5d0*theta(i)
6231         ityp2=ithetyp((itype(i-1)))
6232         do k=1,nntheterm
6233           coskt(k)=dcos(k*theti2)
6234           sinkt(k)=dsin(k*theti2)
6235         enddo
6236 C        print *,ethetai
6237         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6238 #ifdef OSF
6239           phii=phi(i)
6240           if (phii.ne.phii) phii=150.0
6241 #else
6242           phii=phi(i)
6243 #endif
6244           ityp1=ithetyp((itype(i-2)))
6245 C propagation of chirality for glycine type
6246           do k=1,nsingle
6247             cosph1(k)=dcos(k*phii)
6248             sinph1(k)=dsin(k*phii)
6249           enddo
6250         else
6251           phii=0.0d0
6252           do k=1,nsingle
6253           ityp1=ithetyp((itype(i-2)))
6254             cosph1(k)=0.0d0
6255             sinph1(k)=0.0d0
6256           enddo
6257         endif
6258         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6259 #ifdef OSF
6260           phii1=phi(i+1)
6261           if (phii1.ne.phii1) phii1=150.0
6262           phii1=pinorm(phii1)
6263 #else
6264           phii1=phi(i+1)
6265 #endif
6266           ityp3=ithetyp((itype(i)))
6267           do k=1,nsingle
6268             cosph2(k)=dcos(k*phii1)
6269             sinph2(k)=dsin(k*phii1)
6270           enddo
6271         else
6272           phii1=0.0d0
6273           ityp3=ithetyp((itype(i)))
6274           do k=1,nsingle
6275             cosph2(k)=0.0d0
6276             sinph2(k)=0.0d0
6277           enddo
6278         endif
6279         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6280         do k=1,ndouble
6281           do l=1,k-1
6282             ccl=cosph1(l)*cosph2(k-l)
6283             ssl=sinph1(l)*sinph2(k-l)
6284             scl=sinph1(l)*cosph2(k-l)
6285             csl=cosph1(l)*sinph2(k-l)
6286             cosph1ph2(l,k)=ccl-ssl
6287             cosph1ph2(k,l)=ccl+ssl
6288             sinph1ph2(l,k)=scl+csl
6289             sinph1ph2(k,l)=scl-csl
6290           enddo
6291         enddo
6292         if (lprn) then
6293         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6294      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6295         write (iout,*) "coskt and sinkt"
6296         do k=1,nntheterm
6297           write (iout,*) k,coskt(k),sinkt(k)
6298         enddo
6299         endif
6300         do k=1,ntheterm
6301           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6302           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6303      &      *coskt(k)
6304           if (lprn)
6305      &    write (iout,*) "k",k,"
6306      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6307      &     " ethetai",ethetai
6308         enddo
6309         if (lprn) then
6310         write (iout,*) "cosph and sinph"
6311         do k=1,nsingle
6312           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6313         enddo
6314         write (iout,*) "cosph1ph2 and sinph2ph2"
6315         do k=2,ndouble
6316           do l=1,k-1
6317             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6318      &         sinph1ph2(l,k),sinph1ph2(k,l)
6319           enddo
6320         enddo
6321         write(iout,*) "ethetai",ethetai
6322         endif
6323 C       print *,ethetai
6324         do m=1,ntheterm2
6325           do k=1,nsingle
6326             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6327      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6328      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6329      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6330             ethetai=ethetai+sinkt(m)*aux
6331             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6332             dephii=dephii+k*sinkt(m)*(
6333      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6334      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6335             dephii1=dephii1+k*sinkt(m)*(
6336      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6337      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6338             if (lprn)
6339      &      write (iout,*) "m",m," k",k," bbthet",
6340      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6341      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6342      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6343      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6344 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6345           enddo
6346         enddo
6347 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6348 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6349 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6350 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6351         if (lprn)
6352      &  write(iout,*) "ethetai",ethetai
6353 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6354         do m=1,ntheterm3
6355           do k=2,ndouble
6356             do l=1,k-1
6357               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6358      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6359      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6360      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6361               ethetai=ethetai+sinkt(m)*aux
6362               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6363               dephii=dephii+l*sinkt(m)*(
6364      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6365      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6366      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6367      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6368               dephii1=dephii1+(k-l)*sinkt(m)*(
6369      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6370      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6371      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6372      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6373               if (lprn) then
6374               write (iout,*) "m",m," k",k," l",l," ffthet",
6375      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6376      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6377      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6378      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6379      &            " ethetai",ethetai
6380               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6381      &            cosph1ph2(k,l)*sinkt(m),
6382      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6383               endif
6384             enddo
6385           enddo
6386         enddo
6387 10      continue
6388 c        lprn1=.true.
6389 C        print *,ethetai
6390         if (lprn1)
6391      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6392      &   i,theta(i)*rad2deg,phii*rad2deg,
6393      &   phii1*rad2deg,ethetai
6394 c        lprn1=.false.
6395         etheta=etheta+ethetai
6396         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6397         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6398         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6399       enddo
6400 C now constrains
6401       ethetacnstr=0.0d0
6402 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6403       do i=ithetaconstr_start,ithetaconstr_end
6404         itheta=itheta_constr(i)
6405         thetiii=theta(itheta)
6406         difi=pinorm(thetiii-theta_constr0(i))
6407         if (difi.gt.theta_drange(i)) then
6408           difi=difi-theta_drange(i)
6409           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6410           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6411      &    +for_thet_constr(i)*difi**3
6412         else if (difi.lt.-drange(i)) then
6413           difi=difi+drange(i)
6414           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6415           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6416      &    +for_thet_constr(i)*difi**3
6417         else
6418           difi=0.0
6419         endif
6420        if (energy_dec) then
6421         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6422      &    i,itheta,rad2deg*thetiii,
6423      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6424      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6425      &    gloc(itheta+nphi-2,icg)
6426         endif
6427       enddo
6428
6429       return
6430       end
6431 #endif
6432 #ifdef CRYST_SC
6433 c-----------------------------------------------------------------------------
6434       subroutine esc(escloc)
6435 C Calculate the local energy of a side chain and its derivatives in the
6436 C corresponding virtual-bond valence angles THETA and the spherical angles
6437 C ALPHA and OMEGA.
6438       implicit real*8 (a-h,o-z)
6439       include 'DIMENSIONS'
6440       include 'COMMON.GEO'
6441       include 'COMMON.LOCAL'
6442       include 'COMMON.VAR'
6443       include 'COMMON.INTERACT'
6444       include 'COMMON.DERIV'
6445       include 'COMMON.CHAIN'
6446       include 'COMMON.IOUNITS'
6447       include 'COMMON.NAMES'
6448       include 'COMMON.FFIELD'
6449       include 'COMMON.CONTROL'
6450       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6451      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6452       common /sccalc/ time11,time12,time112,theti,it,nlobit
6453       delta=0.02d0*pi
6454       escloc=0.0D0
6455 c     write (iout,'(a)') 'ESC'
6456       do i=loc_start,loc_end
6457         it=itype(i)
6458         if (it.eq.ntyp1) cycle
6459         if (it.eq.10) goto 1
6460         nlobit=nlob(iabs(it))
6461 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6462 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6463         theti=theta(i+1)-pipol
6464         x(1)=dtan(theti)
6465         x(2)=alph(i)
6466         x(3)=omeg(i)
6467
6468         if (x(2).gt.pi-delta) then
6469           xtemp(1)=x(1)
6470           xtemp(2)=pi-delta
6471           xtemp(3)=x(3)
6472           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6473           xtemp(2)=pi
6474           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6475           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6476      &        escloci,dersc(2))
6477           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6478      &        ddersc0(1),dersc(1))
6479           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6480      &        ddersc0(3),dersc(3))
6481           xtemp(2)=pi-delta
6482           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6483           xtemp(2)=pi
6484           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6485           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6486      &            dersc0(2),esclocbi,dersc02)
6487           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6488      &            dersc12,dersc01)
6489           call splinthet(x(2),0.5d0*delta,ss,ssd)
6490           dersc0(1)=dersc01
6491           dersc0(2)=dersc02
6492           dersc0(3)=0.0d0
6493           do k=1,3
6494             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6495           enddo
6496           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6497 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6498 c    &             esclocbi,ss,ssd
6499           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6500 c         escloci=esclocbi
6501 c         write (iout,*) escloci
6502         else if (x(2).lt.delta) then
6503           xtemp(1)=x(1)
6504           xtemp(2)=delta
6505           xtemp(3)=x(3)
6506           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6507           xtemp(2)=0.0d0
6508           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6509           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6510      &        escloci,dersc(2))
6511           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6512      &        ddersc0(1),dersc(1))
6513           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6514      &        ddersc0(3),dersc(3))
6515           xtemp(2)=delta
6516           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6517           xtemp(2)=0.0d0
6518           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6519           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6520      &            dersc0(2),esclocbi,dersc02)
6521           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6522      &            dersc12,dersc01)
6523           dersc0(1)=dersc01
6524           dersc0(2)=dersc02
6525           dersc0(3)=0.0d0
6526           call splinthet(x(2),0.5d0*delta,ss,ssd)
6527           do k=1,3
6528             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6529           enddo
6530           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6531 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6532 c    &             esclocbi,ss,ssd
6533           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6534 c         write (iout,*) escloci
6535         else
6536           call enesc(x,escloci,dersc,ddummy,.false.)
6537         endif
6538
6539         escloc=escloc+escloci
6540         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6541      &     'escloc',i,escloci
6542 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6543
6544         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6545      &   wscloc*dersc(1)
6546         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6547         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6548     1   continue
6549       enddo
6550       return
6551       end
6552 C---------------------------------------------------------------------------
6553       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6554       implicit real*8 (a-h,o-z)
6555       include 'DIMENSIONS'
6556       include 'COMMON.GEO'
6557       include 'COMMON.LOCAL'
6558       include 'COMMON.IOUNITS'
6559       common /sccalc/ time11,time12,time112,theti,it,nlobit
6560       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6561       double precision contr(maxlob,-1:1)
6562       logical mixed
6563 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6564         escloc_i=0.0D0
6565         do j=1,3
6566           dersc(j)=0.0D0
6567           if (mixed) ddersc(j)=0.0d0
6568         enddo
6569         x3=x(3)
6570
6571 C Because of periodicity of the dependence of the SC energy in omega we have
6572 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6573 C To avoid underflows, first compute & store the exponents.
6574
6575         do iii=-1,1
6576
6577           x(3)=x3+iii*dwapi
6578
6579           do j=1,nlobit
6580             do k=1,3
6581               z(k)=x(k)-censc(k,j,it)
6582             enddo
6583             do k=1,3
6584               Axk=0.0D0
6585               do l=1,3
6586                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6587               enddo
6588               Ax(k,j,iii)=Axk
6589             enddo
6590             expfac=0.0D0
6591             do k=1,3
6592               expfac=expfac+Ax(k,j,iii)*z(k)
6593             enddo
6594             contr(j,iii)=expfac
6595           enddo ! j
6596
6597         enddo ! iii
6598
6599         x(3)=x3
6600 C As in the case of ebend, we want to avoid underflows in exponentiation and
6601 C subsequent NaNs and INFs in energy calculation.
6602 C Find the largest exponent
6603         emin=contr(1,-1)
6604         do iii=-1,1
6605           do j=1,nlobit
6606             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6607           enddo
6608         enddo
6609         emin=0.5D0*emin
6610 cd      print *,'it=',it,' emin=',emin
6611
6612 C Compute the contribution to SC energy and derivatives
6613         do iii=-1,1
6614
6615           do j=1,nlobit
6616 #ifdef OSF
6617             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6618             if(adexp.ne.adexp) adexp=1.0
6619             expfac=dexp(adexp)
6620 #else
6621             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6622 #endif
6623 cd          print *,'j=',j,' expfac=',expfac
6624             escloc_i=escloc_i+expfac
6625             do k=1,3
6626               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6627             enddo
6628             if (mixed) then
6629               do k=1,3,2
6630                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6631      &            +gaussc(k,2,j,it))*expfac
6632               enddo
6633             endif
6634           enddo
6635
6636         enddo ! iii
6637
6638         dersc(1)=dersc(1)/cos(theti)**2
6639         ddersc(1)=ddersc(1)/cos(theti)**2
6640         ddersc(3)=ddersc(3)
6641
6642         escloci=-(dlog(escloc_i)-emin)
6643         do j=1,3
6644           dersc(j)=dersc(j)/escloc_i
6645         enddo
6646         if (mixed) then
6647           do j=1,3,2
6648             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6649           enddo
6650         endif
6651       return
6652       end
6653 C------------------------------------------------------------------------------
6654       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6655       implicit real*8 (a-h,o-z)
6656       include 'DIMENSIONS'
6657       include 'COMMON.GEO'
6658       include 'COMMON.LOCAL'
6659       include 'COMMON.IOUNITS'
6660       common /sccalc/ time11,time12,time112,theti,it,nlobit
6661       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6662       double precision contr(maxlob)
6663       logical mixed
6664
6665       escloc_i=0.0D0
6666
6667       do j=1,3
6668         dersc(j)=0.0D0
6669       enddo
6670
6671       do j=1,nlobit
6672         do k=1,2
6673           z(k)=x(k)-censc(k,j,it)
6674         enddo
6675         z(3)=dwapi
6676         do k=1,3
6677           Axk=0.0D0
6678           do l=1,3
6679             Axk=Axk+gaussc(l,k,j,it)*z(l)
6680           enddo
6681           Ax(k,j)=Axk
6682         enddo
6683         expfac=0.0D0
6684         do k=1,3
6685           expfac=expfac+Ax(k,j)*z(k)
6686         enddo
6687         contr(j)=expfac
6688       enddo ! j
6689
6690 C As in the case of ebend, we want to avoid underflows in exponentiation and
6691 C subsequent NaNs and INFs in energy calculation.
6692 C Find the largest exponent
6693       emin=contr(1)
6694       do j=1,nlobit
6695         if (emin.gt.contr(j)) emin=contr(j)
6696       enddo
6697       emin=0.5D0*emin
6698
6699 C Compute the contribution to SC energy and derivatives
6700
6701       dersc12=0.0d0
6702       do j=1,nlobit
6703         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6704         escloc_i=escloc_i+expfac
6705         do k=1,2
6706           dersc(k)=dersc(k)+Ax(k,j)*expfac
6707         enddo
6708         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6709      &            +gaussc(1,2,j,it))*expfac
6710         dersc(3)=0.0d0
6711       enddo
6712
6713       dersc(1)=dersc(1)/cos(theti)**2
6714       dersc12=dersc12/cos(theti)**2
6715       escloci=-(dlog(escloc_i)-emin)
6716       do j=1,2
6717         dersc(j)=dersc(j)/escloc_i
6718       enddo
6719       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6720       return
6721       end
6722 #else
6723 c----------------------------------------------------------------------------------
6724       subroutine esc(escloc)
6725 C Calculate the local energy of a side chain and its derivatives in the
6726 C corresponding virtual-bond valence angles THETA and the spherical angles
6727 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6728 C added by Urszula Kozlowska. 07/11/2007
6729 C
6730       implicit real*8 (a-h,o-z)
6731       include 'DIMENSIONS'
6732       include 'COMMON.GEO'
6733       include 'COMMON.LOCAL'
6734       include 'COMMON.VAR'
6735       include 'COMMON.SCROT'
6736       include 'COMMON.INTERACT'
6737       include 'COMMON.DERIV'
6738       include 'COMMON.CHAIN'
6739       include 'COMMON.IOUNITS'
6740       include 'COMMON.NAMES'
6741       include 'COMMON.FFIELD'
6742       include 'COMMON.CONTROL'
6743       include 'COMMON.VECTORS'
6744       double precision x_prime(3),y_prime(3),z_prime(3)
6745      &    , sumene,dsc_i,dp2_i,x(65),
6746      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6747      &    de_dxx,de_dyy,de_dzz,de_dt
6748       double precision s1_t,s1_6_t,s2_t,s2_6_t
6749       double precision
6750      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6751      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6752      & dt_dCi(3),dt_dCi1(3)
6753       common /sccalc/ time11,time12,time112,theti,it,nlobit
6754       delta=0.02d0*pi
6755       escloc=0.0D0
6756       do i=loc_start,loc_end
6757         if (itype(i).eq.ntyp1) cycle
6758         costtab(i+1) =dcos(theta(i+1))
6759         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6760         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6761         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6762         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6763         cosfac=dsqrt(cosfac2)
6764         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6765         sinfac=dsqrt(sinfac2)
6766         it=iabs(itype(i))
6767         if (it.eq.10) goto 1
6768 c
6769 C  Compute the axes of tghe local cartesian coordinates system; store in
6770 c   x_prime, y_prime and z_prime
6771 c
6772         do j=1,3
6773           x_prime(j) = 0.00
6774           y_prime(j) = 0.00
6775           z_prime(j) = 0.00
6776         enddo
6777 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6778 C     &   dc_norm(3,i+nres)
6779         do j = 1,3
6780           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6781           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6782         enddo
6783         do j = 1,3
6784           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6785         enddo
6786 c       write (2,*) "i",i
6787 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6788 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6789 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6790 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6791 c      & " xy",scalar(x_prime(1),y_prime(1)),
6792 c      & " xz",scalar(x_prime(1),z_prime(1)),
6793 c      & " yy",scalar(y_prime(1),y_prime(1)),
6794 c      & " yz",scalar(y_prime(1),z_prime(1)),
6795 c      & " zz",scalar(z_prime(1),z_prime(1))
6796 c
6797 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6798 C to local coordinate system. Store in xx, yy, zz.
6799 c
6800         xx=0.0d0
6801         yy=0.0d0
6802         zz=0.0d0
6803         do j = 1,3
6804           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6805           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6806           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6807         enddo
6808
6809         xxtab(i)=xx
6810         yytab(i)=yy
6811         zztab(i)=zz
6812 C
6813 C Compute the energy of the ith side cbain
6814 C
6815 c        write (2,*) "xx",xx," yy",yy," zz",zz
6816         it=iabs(itype(i))
6817         do j = 1,65
6818           x(j) = sc_parmin(j,it)
6819         enddo
6820 #ifdef CHECK_COORD
6821 Cc diagnostics - remove later
6822         xx1 = dcos(alph(2))
6823         yy1 = dsin(alph(2))*dcos(omeg(2))
6824         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6825         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6826      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6827      &    xx1,yy1,zz1
6828 C,"  --- ", xx_w,yy_w,zz_w
6829 c end diagnostics
6830 #endif
6831         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6832      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6833      &   + x(10)*yy*zz
6834         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6835      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6836      & + x(20)*yy*zz
6837         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6838      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6839      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6840      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6841      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6842      &  +x(40)*xx*yy*zz
6843         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6844      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6845      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6846      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6847      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6848      &  +x(60)*xx*yy*zz
6849         dsc_i   = 0.743d0+x(61)
6850         dp2_i   = 1.9d0+x(62)
6851         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6852      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6853         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6854      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6855         s1=(1+x(63))/(0.1d0 + dscp1)
6856         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6857         s2=(1+x(65))/(0.1d0 + dscp2)
6858         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6859         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6860      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6861 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6862 c     &   sumene4,
6863 c     &   dscp1,dscp2,sumene
6864 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6865         escloc = escloc + sumene
6866 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6867 c     & ,zz,xx,yy
6868 c#define DEBUG
6869 #ifdef DEBUG
6870 C
6871 C This section to check the numerical derivatives of the energy of ith side
6872 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6873 C #define DEBUG in the code to turn it on.
6874 C
6875         write (2,*) "sumene               =",sumene
6876         aincr=1.0d-7
6877         xxsave=xx
6878         xx=xx+aincr
6879         write (2,*) xx,yy,zz
6880         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6881         de_dxx_num=(sumenep-sumene)/aincr
6882         xx=xxsave
6883         write (2,*) "xx+ sumene from enesc=",sumenep
6884         yysave=yy
6885         yy=yy+aincr
6886         write (2,*) xx,yy,zz
6887         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6888         de_dyy_num=(sumenep-sumene)/aincr
6889         yy=yysave
6890         write (2,*) "yy+ sumene from enesc=",sumenep
6891         zzsave=zz
6892         zz=zz+aincr
6893         write (2,*) xx,yy,zz
6894         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6895         de_dzz_num=(sumenep-sumene)/aincr
6896         zz=zzsave
6897         write (2,*) "zz+ sumene from enesc=",sumenep
6898         costsave=cost2tab(i+1)
6899         sintsave=sint2tab(i+1)
6900         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6901         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6902         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6903         de_dt_num=(sumenep-sumene)/aincr
6904         write (2,*) " t+ sumene from enesc=",sumenep
6905         cost2tab(i+1)=costsave
6906         sint2tab(i+1)=sintsave
6907 C End of diagnostics section.
6908 #endif
6909 C
6910 C Compute the gradient of esc
6911 C
6912 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6913         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6914         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6915         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6916         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6917         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6918         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6919         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6920         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6921         pom1=(sumene3*sint2tab(i+1)+sumene1)
6922      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6923         pom2=(sumene4*cost2tab(i+1)+sumene2)
6924      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6925         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6926         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6927      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6928      &  +x(40)*yy*zz
6929         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6930         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6931      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6932      &  +x(60)*yy*zz
6933         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6934      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6935      &        +(pom1+pom2)*pom_dx
6936 #ifdef DEBUG
6937         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6938 #endif
6939 C
6940         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6941         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6942      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6943      &  +x(40)*xx*zz
6944         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6945         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6946      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6947      &  +x(59)*zz**2 +x(60)*xx*zz
6948         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6949      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6950      &        +(pom1-pom2)*pom_dy
6951 #ifdef DEBUG
6952         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6953 #endif
6954 C
6955         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6956      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6957      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6958      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6959      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6960      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6961      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6962      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6963 #ifdef DEBUG
6964         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6965 #endif
6966 C
6967         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6968      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6969      &  +pom1*pom_dt1+pom2*pom_dt2
6970 #ifdef DEBUG
6971         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6972 #endif
6973 c#undef DEBUG
6974 c
6975 C
6976        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6977        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6978        cosfac2xx=cosfac2*xx
6979        sinfac2yy=sinfac2*yy
6980        do k = 1,3
6981          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6982      &      vbld_inv(i+1)
6983          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6984      &      vbld_inv(i)
6985          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6986          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6987 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6988 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6989 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6990 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6991          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6992          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6993          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6994          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6995          dZZ_Ci1(k)=0.0d0
6996          dZZ_Ci(k)=0.0d0
6997          do j=1,3
6998            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6999      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7000            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7001      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7002          enddo
7003
7004          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7005          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7006          dZZ_XYZ(k)=vbld_inv(i+nres)*
7007      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7008 c
7009          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7010          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7011        enddo
7012
7013        do k=1,3
7014          dXX_Ctab(k,i)=dXX_Ci(k)
7015          dXX_C1tab(k,i)=dXX_Ci1(k)
7016          dYY_Ctab(k,i)=dYY_Ci(k)
7017          dYY_C1tab(k,i)=dYY_Ci1(k)
7018          dZZ_Ctab(k,i)=dZZ_Ci(k)
7019          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7020          dXX_XYZtab(k,i)=dXX_XYZ(k)
7021          dYY_XYZtab(k,i)=dYY_XYZ(k)
7022          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7023        enddo
7024
7025        do k = 1,3
7026 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7027 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7028 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7029 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7030 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7031 c     &    dt_dci(k)
7032 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7033 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7034          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7035      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7036          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7037      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7038          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7039      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7040        enddo
7041 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7042 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7043
7044 C to check gradient call subroutine check_grad
7045
7046     1 continue
7047       enddo
7048       return
7049       end
7050 c------------------------------------------------------------------------------
7051       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7052       implicit none
7053       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7054      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7055       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7056      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7057      &   + x(10)*yy*zz
7058       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7059      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7060      & + x(20)*yy*zz
7061       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7062      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7063      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7064      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7065      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7066      &  +x(40)*xx*yy*zz
7067       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7068      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7069      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7070      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7071      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7072      &  +x(60)*xx*yy*zz
7073       dsc_i   = 0.743d0+x(61)
7074       dp2_i   = 1.9d0+x(62)
7075       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7076      &          *(xx*cost2+yy*sint2))
7077       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7078      &          *(xx*cost2-yy*sint2))
7079       s1=(1+x(63))/(0.1d0 + dscp1)
7080       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7081       s2=(1+x(65))/(0.1d0 + dscp2)
7082       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7083       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7084      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7085       enesc=sumene
7086       return
7087       end
7088 #endif
7089 c------------------------------------------------------------------------------
7090       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7091 C
7092 C This procedure calculates two-body contact function g(rij) and its derivative:
7093 C
7094 C           eps0ij                                     !       x < -1
7095 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7096 C            0                                         !       x > 1
7097 C
7098 C where x=(rij-r0ij)/delta
7099 C
7100 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7101 C
7102       implicit none
7103       double precision rij,r0ij,eps0ij,fcont,fprimcont
7104       double precision x,x2,x4,delta
7105 c     delta=0.02D0*r0ij
7106 c      delta=0.2D0*r0ij
7107       x=(rij-r0ij)/delta
7108       if (x.lt.-1.0D0) then
7109         fcont=eps0ij
7110         fprimcont=0.0D0
7111       else if (x.le.1.0D0) then
7112         x2=x*x
7113         x4=x2*x2
7114         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7115         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7116       else
7117         fcont=0.0D0
7118         fprimcont=0.0D0
7119       endif
7120       return
7121       end
7122 c------------------------------------------------------------------------------
7123       subroutine splinthet(theti,delta,ss,ssder)
7124       implicit real*8 (a-h,o-z)
7125       include 'DIMENSIONS'
7126       include 'COMMON.VAR'
7127       include 'COMMON.GEO'
7128       thetup=pi-delta
7129       thetlow=delta
7130       if (theti.gt.pipol) then
7131         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7132       else
7133         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7134         ssder=-ssder
7135       endif
7136       return
7137       end
7138 c------------------------------------------------------------------------------
7139       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7140       implicit none
7141       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7142       double precision ksi,ksi2,ksi3,a1,a2,a3
7143       a1=fprim0*delta/(f1-f0)
7144       a2=3.0d0-2.0d0*a1
7145       a3=a1-2.0d0
7146       ksi=(x-x0)/delta
7147       ksi2=ksi*ksi
7148       ksi3=ksi2*ksi
7149       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7150       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7151       return
7152       end
7153 c------------------------------------------------------------------------------
7154       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7155       implicit none
7156       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7157       double precision ksi,ksi2,ksi3,a1,a2,a3
7158       ksi=(x-x0)/delta
7159       ksi2=ksi*ksi
7160       ksi3=ksi2*ksi
7161       a1=fprim0x*delta
7162       a2=3*(f1x-f0x)-2*fprim0x*delta
7163       a3=fprim0x*delta-2*(f1x-f0x)
7164       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7165       return
7166       end
7167 C-----------------------------------------------------------------------------
7168 #ifdef CRYST_TOR
7169 C-----------------------------------------------------------------------------
7170       subroutine etor(etors,edihcnstr)
7171       implicit real*8 (a-h,o-z)
7172       include 'DIMENSIONS'
7173       include 'COMMON.VAR'
7174       include 'COMMON.GEO'
7175       include 'COMMON.LOCAL'
7176       include 'COMMON.TORSION'
7177       include 'COMMON.INTERACT'
7178       include 'COMMON.DERIV'
7179       include 'COMMON.CHAIN'
7180       include 'COMMON.NAMES'
7181       include 'COMMON.IOUNITS'
7182       include 'COMMON.FFIELD'
7183       include 'COMMON.TORCNSTR'
7184       include 'COMMON.CONTROL'
7185       logical lprn
7186 C Set lprn=.true. for debugging
7187       lprn=.false.
7188 c      lprn=.true.
7189       etors=0.0D0
7190       do i=iphi_start,iphi_end
7191       etors_ii=0.0D0
7192         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7193      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7194         itori=itortyp(itype(i-2))
7195         itori1=itortyp(itype(i-1))
7196         phii=phi(i)
7197         gloci=0.0D0
7198 C Proline-Proline pair is a special case...
7199         if (itori.eq.3 .and. itori1.eq.3) then
7200           if (phii.gt.-dwapi3) then
7201             cosphi=dcos(3*phii)
7202             fac=1.0D0/(1.0D0-cosphi)
7203             etorsi=v1(1,3,3)*fac
7204             etorsi=etorsi+etorsi
7205             etors=etors+etorsi-v1(1,3,3)
7206             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7207             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7208           endif
7209           do j=1,3
7210             v1ij=v1(j+1,itori,itori1)
7211             v2ij=v2(j+1,itori,itori1)
7212             cosphi=dcos(j*phii)
7213             sinphi=dsin(j*phii)
7214             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7215             if (energy_dec) etors_ii=etors_ii+
7216      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7217             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7218           enddo
7219         else
7220           do j=1,nterm_old
7221             v1ij=v1(j,itori,itori1)
7222             v2ij=v2(j,itori,itori1)
7223             cosphi=dcos(j*phii)
7224             sinphi=dsin(j*phii)
7225             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7226             if (energy_dec) etors_ii=etors_ii+
7227      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7228             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7229           enddo
7230         endif
7231         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7232              'etor',i,etors_ii
7233         if (lprn)
7234      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7235      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7236      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7237         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7238 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7239       enddo
7240 ! 6/20/98 - dihedral angle constraints
7241       edihcnstr=0.0d0
7242       do i=1,ndih_constr
7243         itori=idih_constr(i)
7244         phii=phi(itori)
7245         difi=phii-phi0(i)
7246         if (difi.gt.drange(i)) then
7247           difi=difi-drange(i)
7248           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7249           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7250         else if (difi.lt.-drange(i)) then
7251           difi=difi+drange(i)
7252           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7253           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7254         endif
7255 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7256 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7257       enddo
7258 !      write (iout,*) 'edihcnstr',edihcnstr
7259       return
7260       end
7261 c------------------------------------------------------------------------------
7262       subroutine etor_d(etors_d)
7263       etors_d=0.0d0
7264       return
7265       end
7266 c----------------------------------------------------------------------------
7267 #else
7268       subroutine etor(etors,edihcnstr)
7269       implicit real*8 (a-h,o-z)
7270       include 'DIMENSIONS'
7271       include 'COMMON.VAR'
7272       include 'COMMON.GEO'
7273       include 'COMMON.LOCAL'
7274       include 'COMMON.TORSION'
7275       include 'COMMON.INTERACT'
7276       include 'COMMON.DERIV'
7277       include 'COMMON.CHAIN'
7278       include 'COMMON.NAMES'
7279       include 'COMMON.IOUNITS'
7280       include 'COMMON.FFIELD'
7281       include 'COMMON.TORCNSTR'
7282       include 'COMMON.CONTROL'
7283       logical lprn
7284 C Set lprn=.true. for debugging
7285       lprn=.false.
7286 c     lprn=.true.
7287       etors=0.0D0
7288       do i=iphi_start,iphi_end
7289 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7290 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7291 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7292 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7293         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7294      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7295 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7296 C For introducing the NH3+ and COO- group please check the etor_d for reference
7297 C and guidance
7298         etors_ii=0.0D0
7299          if (iabs(itype(i)).eq.20) then
7300          iblock=2
7301          else
7302          iblock=1
7303          endif
7304         itori=itortyp(itype(i-2))
7305         itori1=itortyp(itype(i-1))
7306         phii=phi(i)
7307         gloci=0.0D0
7308 C Regular cosine and sine terms
7309         do j=1,nterm(itori,itori1,iblock)
7310           v1ij=v1(j,itori,itori1,iblock)
7311           v2ij=v2(j,itori,itori1,iblock)
7312           cosphi=dcos(j*phii)
7313           sinphi=dsin(j*phii)
7314           etors=etors+v1ij*cosphi+v2ij*sinphi
7315           if (energy_dec) etors_ii=etors_ii+
7316      &                v1ij*cosphi+v2ij*sinphi
7317           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7318         enddo
7319 C Lorentz terms
7320 C                         v1
7321 C  E = SUM ----------------------------------- - v1
7322 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7323 C
7324         cosphi=dcos(0.5d0*phii)
7325         sinphi=dsin(0.5d0*phii)
7326         do j=1,nlor(itori,itori1,iblock)
7327           vl1ij=vlor1(j,itori,itori1)
7328           vl2ij=vlor2(j,itori,itori1)
7329           vl3ij=vlor3(j,itori,itori1)
7330           pom=vl2ij*cosphi+vl3ij*sinphi
7331           pom1=1.0d0/(pom*pom+1.0d0)
7332           etors=etors+vl1ij*pom1
7333           if (energy_dec) etors_ii=etors_ii+
7334      &                vl1ij*pom1
7335           pom=-pom*pom1*pom1
7336           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7337         enddo
7338 C Subtract the constant term
7339         etors=etors-v0(itori,itori1,iblock)
7340           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7341      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7342         if (lprn)
7343      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7344      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7345      &  (v1(j,itori,itori1,iblock),j=1,6),
7346      &  (v2(j,itori,itori1,iblock),j=1,6)
7347         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7348 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7349       enddo
7350 ! 6/20/98 - dihedral angle constraints
7351       edihcnstr=0.0d0
7352 c      do i=1,ndih_constr
7353       do i=idihconstr_start,idihconstr_end
7354         itori=idih_constr(i)
7355         phii=phi(itori)
7356         difi=pinorm(phii-phi0(i))
7357         if (difi.gt.drange(i)) then
7358           difi=difi-drange(i)
7359           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7360           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7361         else if (difi.lt.-drange(i)) then
7362           difi=difi+drange(i)
7363           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7364           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7365         else
7366           difi=0.0
7367         endif
7368        if (energy_dec) then
7369         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7370      &    i,itori,rad2deg*phii,
7371      &    rad2deg*phi0(i),  rad2deg*drange(i),
7372      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7373         endif
7374       enddo
7375 cd       write (iout,*) 'edihcnstr',edihcnstr
7376       return
7377       end
7378 c----------------------------------------------------------------------------
7379       subroutine etor_d(etors_d)
7380 C 6/23/01 Compute double torsional energy
7381       implicit real*8 (a-h,o-z)
7382       include 'DIMENSIONS'
7383       include 'COMMON.VAR'
7384       include 'COMMON.GEO'
7385       include 'COMMON.LOCAL'
7386       include 'COMMON.TORSION'
7387       include 'COMMON.INTERACT'
7388       include 'COMMON.DERIV'
7389       include 'COMMON.CHAIN'
7390       include 'COMMON.NAMES'
7391       include 'COMMON.IOUNITS'
7392       include 'COMMON.FFIELD'
7393       include 'COMMON.TORCNSTR'
7394       logical lprn
7395 C Set lprn=.true. for debugging
7396       lprn=.false.
7397 c     lprn=.true.
7398       etors_d=0.0D0
7399 c      write(iout,*) "a tu??"
7400       do i=iphid_start,iphid_end
7401 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7402 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7403 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7404 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7405 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7406          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7407      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7408      &  (itype(i+1).eq.ntyp1)) cycle
7409 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7410         itori=itortyp(itype(i-2))
7411         itori1=itortyp(itype(i-1))
7412         itori2=itortyp(itype(i))
7413         phii=phi(i)
7414         phii1=phi(i+1)
7415         gloci1=0.0D0
7416         gloci2=0.0D0
7417         iblock=1
7418         if (iabs(itype(i+1)).eq.20) iblock=2
7419 C Iblock=2 Proline type
7420 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7421 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7422 C        if (itype(i+1).eq.ntyp1) iblock=3
7423 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7424 C IS or IS NOT need for this
7425 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7426 C        is (itype(i-3).eq.ntyp1) ntblock=2
7427 C        ntblock is N-terminal blocking group
7428
7429 C Regular cosine and sine terms
7430         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7431 C Example of changes for NH3+ blocking group
7432 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7433 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7434           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7435           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7436           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7437           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7438           cosphi1=dcos(j*phii)
7439           sinphi1=dsin(j*phii)
7440           cosphi2=dcos(j*phii1)
7441           sinphi2=dsin(j*phii1)
7442           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7443      &     v2cij*cosphi2+v2sij*sinphi2
7444           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7445           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7446         enddo
7447         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7448           do l=1,k-1
7449             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7450             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7451             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7452             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7453             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7454             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7455             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7456             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7457             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7458      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7459             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7460      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7461             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7462      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7463           enddo
7464         enddo
7465         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7466         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7467       enddo
7468       return
7469       end
7470 #endif
7471 C----------------------------------------------------------------------------------
7472 C The rigorous attempt to derive energy function
7473       subroutine etor_kcc(etors,edihcnstr)
7474       implicit real*8 (a-h,o-z)
7475       include 'DIMENSIONS'
7476       include 'COMMON.VAR'
7477       include 'COMMON.GEO'
7478       include 'COMMON.LOCAL'
7479       include 'COMMON.TORSION'
7480       include 'COMMON.INTERACT'
7481       include 'COMMON.DERIV'
7482       include 'COMMON.CHAIN'
7483       include 'COMMON.NAMES'
7484       include 'COMMON.IOUNITS'
7485       include 'COMMON.FFIELD'
7486       include 'COMMON.TORCNSTR'
7487       include 'COMMON.CONTROL'
7488       logical lprn
7489 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7490 C Set lprn=.true. for debugging
7491       lprn=.false.
7492 c     lprn=.true.
7493 C      print *,"wchodze kcc"
7494       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7495       if (tor_mode.ne.2) then
7496       etors=0.0D0
7497       endif
7498       do i=iphi_start,iphi_end
7499 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7500 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7501 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7502 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7503         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7504      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7505         itori=itortyp_kcc(itype(i-2))
7506         itori1=itortyp_kcc(itype(i-1))
7507         phii=phi(i)
7508         glocig=0.0D0
7509         glocit1=0.0d0
7510         glocit2=0.0d0
7511         sumnonchebyshev=0.0d0
7512         sumchebyshev=0.0d0
7513 C to avoid multiple devision by 2
7514 c        theti22=0.5d0*theta(i)
7515 C theta 12 is the theta_1 /2
7516 C theta 22 is theta_2 /2
7517 c        theti12=0.5d0*theta(i-1)
7518 C and appropriate sinus function
7519         sinthet1=dsin(theta(i-1))
7520         sinthet2=dsin(theta(i))
7521         costhet1=dcos(theta(i-1))
7522         costhet2=dcos(theta(i))
7523 c Cosines of halves thetas
7524         costheti12=0.5d0*(1.0d0+costhet1)
7525         costheti22=0.5d0*(1.0d0+costhet2)
7526 C to speed up lets store its mutliplication
7527         sint1t2=sinthet2*sinthet1
7528         sint1t2n=1.0d0
7529 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7530 C +d_n*sin(n*gamma)) *
7531 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7532 C we have two sum 1) Non-Chebyshev which is with n and gamma
7533         etori=0.0d0
7534         do j=1,nterm_kcc(itori,itori1)
7535
7536           nval=nterm_kcc_Tb(itori,itori1)
7537           v1ij=v1_kcc(j,itori,itori1)
7538           v2ij=v2_kcc(j,itori,itori1)
7539 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7540 C v1ij is c_n and d_n in euation above
7541           cosphi=dcos(j*phii)
7542           sinphi=dsin(j*phii)
7543           sint1t2n1=sint1t2n
7544           sint1t2n=sint1t2n*sint1t2
7545           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7546      &        costheti12)
7547           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7548      &        v11_chyb(1,j,itori,itori1),costheti12)
7549 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7550 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7551           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7552      &        costheti22)
7553           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7554      &        v21_chyb(1,j,itori,itori1),costheti22)
7555 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7556 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7557           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7558      &        costheti12)
7559           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7560      &        v12_chyb(1,j,itori,itori1),costheti12)
7561 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7562 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7563           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7564      &        costheti22)
7565           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7566      &        v22_chyb(1,j,itori,itori1),costheti22)
7567 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7568 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7569 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7570 C          if (energy_dec) etors_ii=etors_ii+
7571 C     &                v1ij*cosphi+v2ij*sinphi
7572 C glocig is the gradient local i site in gamma
7573           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7574           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7575           etori=etori+sint1t2n*(actval1+actval2)
7576           glocig=glocig+
7577      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7578      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7579 C now gradient over theta_1
7580           glocit1=glocit1+
7581      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7582      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7583           glocit2=glocit2+
7584      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7585      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7586
7587 C now the Czebyshev polinominal sum
7588 c        do k=1,nterm_kcc_Tb(itori,itori1)
7589 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7590 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7591 C         thybt1(k)=0.0
7592 C         thybt2(k)=0.0
7593 c        enddo
7594 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7595 C     &         gradtschebyshev
7596 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7597 C     &         dcos(theti22)**2),
7598 C     &         dsin(theti22)
7599
7600 C now overal sumation
7601 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7602         enddo ! j
7603         etors=etors+etori
7604 C derivative over gamma
7605         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7606 C derivative over theta1
7607         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7608 C now derivative over theta2
7609         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7610         if (lprn)
7611      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7612      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7613       enddo
7614 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7615 ! 6/20/98 - dihedral angle constraints
7616       if (tor_mode.ne.2) then
7617       edihcnstr=0.0d0
7618 c      do i=1,ndih_constr
7619       do i=idihconstr_start,idihconstr_end
7620         itori=idih_constr(i)
7621         phii=phi(itori)
7622         difi=pinorm(phii-phi0(i))
7623         if (difi.gt.drange(i)) then
7624           difi=difi-drange(i)
7625           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7626           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7627         else if (difi.lt.-drange(i)) then
7628           difi=difi+drange(i)
7629           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7630           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7631         else
7632           difi=0.0
7633         endif
7634        enddo
7635        endif
7636       return
7637       end
7638
7639 C The rigorous attempt to derive energy function
7640       subroutine ebend_kcc(etheta,ethetacnstr)
7641
7642       implicit real*8 (a-h,o-z)
7643       include 'DIMENSIONS'
7644       include 'COMMON.VAR'
7645       include 'COMMON.GEO'
7646       include 'COMMON.LOCAL'
7647       include 'COMMON.TORSION'
7648       include 'COMMON.INTERACT'
7649       include 'COMMON.DERIV'
7650       include 'COMMON.CHAIN'
7651       include 'COMMON.NAMES'
7652       include 'COMMON.IOUNITS'
7653       include 'COMMON.FFIELD'
7654       include 'COMMON.TORCNSTR'
7655       include 'COMMON.CONTROL'
7656       logical lprn
7657       double precision thybt1(maxtermkcc)
7658 C Set lprn=.true. for debugging
7659       lprn=.false.
7660 c     lprn=.true.
7661 C      print *,"wchodze kcc"
7662       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7663       if (tor_mode.ne.2) etheta=0.0D0
7664       do i=ithet_start,ithet_end
7665 c        print *,i,itype(i-1),itype(i),itype(i-2)
7666         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7667      &  .or.itype(i).eq.ntyp1) cycle
7668          iti=itortyp_kcc(itype(i-1))
7669         sinthet=dsin(theta(i)/2.0d0)
7670         costhet=dcos(theta(i)/2.0d0)
7671          do j=1,nbend_kcc_Tb(iti)
7672           thybt1(j)=v1bend_chyb(j,iti)
7673          enddo
7674          sumth1thyb=tschebyshev
7675      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7676         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7677      &    sumth1thyb
7678         ihelp=nbend_kcc_Tb(iti)-1
7679         gradthybt1=gradtschebyshev
7680      &         (0,ihelp,thybt1(1),costhet)
7681         etheta=etheta+sumth1thyb
7682 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7683         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7684      &   gradthybt1*sinthet*(-0.5d0)
7685       enddo
7686       if (tor_mode.ne.2) then
7687       ethetacnstr=0.0d0
7688 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7689       do i=ithetaconstr_start,ithetaconstr_end
7690         itheta=itheta_constr(i)
7691         thetiii=theta(itheta)
7692         difi=pinorm(thetiii-theta_constr0(i))
7693         if (difi.gt.theta_drange(i)) then
7694           difi=difi-theta_drange(i)
7695           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7696           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7697      &    +for_thet_constr(i)*difi**3
7698         else if (difi.lt.-drange(i)) then
7699           difi=difi+drange(i)
7700           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7701           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7702      &    +for_thet_constr(i)*difi**3
7703         else
7704           difi=0.0
7705         endif
7706        if (energy_dec) then
7707         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7708      &    i,itheta,rad2deg*thetiii,
7709      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7710      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7711      &    gloc(itheta+nphi-2,icg)
7712         endif
7713       enddo
7714       endif
7715       return
7716       end
7717 c------------------------------------------------------------------------------
7718       subroutine eback_sc_corr(esccor)
7719 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7720 c        conformational states; temporarily implemented as differences
7721 c        between UNRES torsional potentials (dependent on three types of
7722 c        residues) and the torsional potentials dependent on all 20 types
7723 c        of residues computed from AM1  energy surfaces of terminally-blocked
7724 c        amino-acid residues.
7725       implicit real*8 (a-h,o-z)
7726       include 'DIMENSIONS'
7727       include 'COMMON.VAR'
7728       include 'COMMON.GEO'
7729       include 'COMMON.LOCAL'
7730       include 'COMMON.TORSION'
7731       include 'COMMON.SCCOR'
7732       include 'COMMON.INTERACT'
7733       include 'COMMON.DERIV'
7734       include 'COMMON.CHAIN'
7735       include 'COMMON.NAMES'
7736       include 'COMMON.IOUNITS'
7737       include 'COMMON.FFIELD'
7738       include 'COMMON.CONTROL'
7739       logical lprn
7740 C Set lprn=.true. for debugging
7741       lprn=.false.
7742 c      lprn=.true.
7743 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7744       esccor=0.0D0
7745       do i=itau_start,itau_end
7746         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7747         esccor_ii=0.0D0
7748         isccori=isccortyp(itype(i-2))
7749         isccori1=isccortyp(itype(i-1))
7750 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7751         phii=phi(i)
7752         do intertyp=1,3 !intertyp
7753 cc Added 09 May 2012 (Adasko)
7754 cc  Intertyp means interaction type of backbone mainchain correlation:
7755 c   1 = SC...Ca...Ca...Ca
7756 c   2 = Ca...Ca...Ca...SC
7757 c   3 = SC...Ca...Ca...SCi
7758         gloci=0.0D0
7759         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7760      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7761      &      (itype(i-1).eq.ntyp1)))
7762      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7763      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7764      &     .or.(itype(i).eq.ntyp1)))
7765      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7766      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7767      &      (itype(i-3).eq.ntyp1)))) cycle
7768         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7769         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7770      & cycle
7771        do j=1,nterm_sccor(isccori,isccori1)
7772           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7773           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7774           cosphi=dcos(j*tauangle(intertyp,i))
7775           sinphi=dsin(j*tauangle(intertyp,i))
7776           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7777           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7778         enddo
7779 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7780         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7781         if (lprn)
7782      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7783      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7784      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7785      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7786         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7787        enddo !intertyp
7788       enddo
7789
7790       return
7791       end
7792 c----------------------------------------------------------------------------
7793       subroutine multibody(ecorr)
7794 C This subroutine calculates multi-body contributions to energy following
7795 C the idea of Skolnick et al. If side chains I and J make a contact and
7796 C at the same time side chains I+1 and J+1 make a contact, an extra
7797 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7798       implicit real*8 (a-h,o-z)
7799       include 'DIMENSIONS'
7800       include 'COMMON.IOUNITS'
7801       include 'COMMON.DERIV'
7802       include 'COMMON.INTERACT'
7803       include 'COMMON.CONTACTS'
7804       double precision gx(3),gx1(3)
7805       logical lprn
7806
7807 C Set lprn=.true. for debugging
7808       lprn=.false.
7809
7810       if (lprn) then
7811         write (iout,'(a)') 'Contact function values:'
7812         do i=nnt,nct-2
7813           write (iout,'(i2,20(1x,i2,f10.5))')
7814      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7815         enddo
7816       endif
7817       ecorr=0.0D0
7818       do i=nnt,nct
7819         do j=1,3
7820           gradcorr(j,i)=0.0D0
7821           gradxorr(j,i)=0.0D0
7822         enddo
7823       enddo
7824       do i=nnt,nct-2
7825
7826         DO ISHIFT = 3,4
7827
7828         i1=i+ishift
7829         num_conti=num_cont(i)
7830         num_conti1=num_cont(i1)
7831         do jj=1,num_conti
7832           j=jcont(jj,i)
7833           do kk=1,num_conti1
7834             j1=jcont(kk,i1)
7835             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7836 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7837 cd   &                   ' ishift=',ishift
7838 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7839 C The system gains extra energy.
7840               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7841             endif   ! j1==j+-ishift
7842           enddo     ! kk
7843         enddo       ! jj
7844
7845         ENDDO ! ISHIFT
7846
7847       enddo         ! i
7848       return
7849       end
7850 c------------------------------------------------------------------------------
7851       double precision function esccorr(i,j,k,l,jj,kk)
7852       implicit real*8 (a-h,o-z)
7853       include 'DIMENSIONS'
7854       include 'COMMON.IOUNITS'
7855       include 'COMMON.DERIV'
7856       include 'COMMON.INTERACT'
7857       include 'COMMON.CONTACTS'
7858       include 'COMMON.SHIELD'
7859       double precision gx(3),gx1(3)
7860       logical lprn
7861       lprn=.false.
7862       eij=facont(jj,i)
7863       ekl=facont(kk,k)
7864 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7865 C Calculate the multi-body contribution to energy.
7866 C Calculate multi-body contributions to the gradient.
7867 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7868 cd   & k,l,(gacont(m,kk,k),m=1,3)
7869       do m=1,3
7870         gx(m) =ekl*gacont(m,jj,i)
7871         gx1(m)=eij*gacont(m,kk,k)
7872         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7873         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7874         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7875         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7876       enddo
7877       do m=i,j-1
7878         do ll=1,3
7879           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7880         enddo
7881       enddo
7882       do m=k,l-1
7883         do ll=1,3
7884           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7885         enddo
7886       enddo
7887       esccorr=-eij*ekl
7888       return
7889       end
7890 c------------------------------------------------------------------------------
7891       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7892 C This subroutine calculates multi-body contributions to hydrogen-bonding
7893       implicit real*8 (a-h,o-z)
7894       include 'DIMENSIONS'
7895       include 'COMMON.IOUNITS'
7896 #ifdef MPI
7897       include "mpif.h"
7898       parameter (max_cont=maxconts)
7899       parameter (max_dim=26)
7900       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7901       double precision zapas(max_dim,maxconts,max_fg_procs),
7902      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7903       common /przechowalnia/ zapas
7904       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7905      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7906 #endif
7907       include 'COMMON.SETUP'
7908       include 'COMMON.FFIELD'
7909       include 'COMMON.DERIV'
7910       include 'COMMON.INTERACT'
7911       include 'COMMON.CONTACTS'
7912       include 'COMMON.CONTROL'
7913       include 'COMMON.LOCAL'
7914       double precision gx(3),gx1(3),time00
7915       logical lprn,ldone
7916
7917 C Set lprn=.true. for debugging
7918       lprn=.false.
7919 #ifdef MPI
7920       n_corr=0
7921       n_corr1=0
7922       if (nfgtasks.le.1) goto 30
7923       if (lprn) then
7924         write (iout,'(a)') 'Contact function values before RECEIVE:'
7925         do i=nnt,nct-2
7926           write (iout,'(2i3,50(1x,i2,f5.2))')
7927      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7928      &    j=1,num_cont_hb(i))
7929         enddo
7930       endif
7931       call flush(iout)
7932       do i=1,ntask_cont_from
7933         ncont_recv(i)=0
7934       enddo
7935       do i=1,ntask_cont_to
7936         ncont_sent(i)=0
7937       enddo
7938 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7939 c     & ntask_cont_to
7940 C Make the list of contacts to send to send to other procesors
7941 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7942 c      call flush(iout)
7943       do i=iturn3_start,iturn3_end
7944 c        write (iout,*) "make contact list turn3",i," num_cont",
7945 c     &    num_cont_hb(i)
7946         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7947       enddo
7948       do i=iturn4_start,iturn4_end
7949 c        write (iout,*) "make contact list turn4",i," num_cont",
7950 c     &   num_cont_hb(i)
7951         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7952       enddo
7953       do ii=1,nat_sent
7954         i=iat_sent(ii)
7955 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7956 c     &    num_cont_hb(i)
7957         do j=1,num_cont_hb(i)
7958         do k=1,4
7959           jjc=jcont_hb(j,i)
7960           iproc=iint_sent_local(k,jjc,ii)
7961 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7962           if (iproc.gt.0) then
7963             ncont_sent(iproc)=ncont_sent(iproc)+1
7964             nn=ncont_sent(iproc)
7965             zapas(1,nn,iproc)=i
7966             zapas(2,nn,iproc)=jjc
7967             zapas(3,nn,iproc)=facont_hb(j,i)
7968             zapas(4,nn,iproc)=ees0p(j,i)
7969             zapas(5,nn,iproc)=ees0m(j,i)
7970             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7971             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7972             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7973             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7974             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7975             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7976             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7977             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7978             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7979             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7980             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7981             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7982             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7983             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7984             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7985             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7986             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7987             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7988             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7989             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7990             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7991           endif
7992         enddo
7993         enddo
7994       enddo
7995       if (lprn) then
7996       write (iout,*)
7997      &  "Numbers of contacts to be sent to other processors",
7998      &  (ncont_sent(i),i=1,ntask_cont_to)
7999       write (iout,*) "Contacts sent"
8000       do ii=1,ntask_cont_to
8001         nn=ncont_sent(ii)
8002         iproc=itask_cont_to(ii)
8003         write (iout,*) nn," contacts to processor",iproc,
8004      &   " of CONT_TO_COMM group"
8005         do i=1,nn
8006           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8007         enddo
8008       enddo
8009       call flush(iout)
8010       endif
8011       CorrelType=477
8012       CorrelID=fg_rank+1
8013       CorrelType1=478
8014       CorrelID1=nfgtasks+fg_rank+1
8015       ireq=0
8016 C Receive the numbers of needed contacts from other processors
8017       do ii=1,ntask_cont_from
8018         iproc=itask_cont_from(ii)
8019         ireq=ireq+1
8020         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8021      &    FG_COMM,req(ireq),IERR)
8022       enddo
8023 c      write (iout,*) "IRECV ended"
8024 c      call flush(iout)
8025 C Send the number of contacts needed by other processors
8026       do ii=1,ntask_cont_to
8027         iproc=itask_cont_to(ii)
8028         ireq=ireq+1
8029         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8030      &    FG_COMM,req(ireq),IERR)
8031       enddo
8032 c      write (iout,*) "ISEND ended"
8033 c      write (iout,*) "number of requests (nn)",ireq
8034       call flush(iout)
8035       if (ireq.gt.0)
8036      &  call MPI_Waitall(ireq,req,status_array,ierr)
8037 c      write (iout,*)
8038 c     &  "Numbers of contacts to be received from other processors",
8039 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8040 c      call flush(iout)
8041 C Receive contacts
8042       ireq=0
8043       do ii=1,ntask_cont_from
8044         iproc=itask_cont_from(ii)
8045         nn=ncont_recv(ii)
8046 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8047 c     &   " of CONT_TO_COMM group"
8048         call flush(iout)
8049         if (nn.gt.0) then
8050           ireq=ireq+1
8051           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8052      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8053 c          write (iout,*) "ireq,req",ireq,req(ireq)
8054         endif
8055       enddo
8056 C Send the contacts to processors that need them
8057       do ii=1,ntask_cont_to
8058         iproc=itask_cont_to(ii)
8059         nn=ncont_sent(ii)
8060 c        write (iout,*) nn," contacts to processor",iproc,
8061 c     &   " of CONT_TO_COMM group"
8062         if (nn.gt.0) then
8063           ireq=ireq+1
8064           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8065      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8066 c          write (iout,*) "ireq,req",ireq,req(ireq)
8067 c          do i=1,nn
8068 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8069 c          enddo
8070         endif
8071       enddo
8072 c      write (iout,*) "number of requests (contacts)",ireq
8073 c      write (iout,*) "req",(req(i),i=1,4)
8074 c      call flush(iout)
8075       if (ireq.gt.0)
8076      & call MPI_Waitall(ireq,req,status_array,ierr)
8077       do iii=1,ntask_cont_from
8078         iproc=itask_cont_from(iii)
8079         nn=ncont_recv(iii)
8080         if (lprn) then
8081         write (iout,*) "Received",nn," contacts from processor",iproc,
8082      &   " of CONT_FROM_COMM group"
8083         call flush(iout)
8084         do i=1,nn
8085           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8086         enddo
8087         call flush(iout)
8088         endif
8089         do i=1,nn
8090           ii=zapas_recv(1,i,iii)
8091 c Flag the received contacts to prevent double-counting
8092           jj=-zapas_recv(2,i,iii)
8093 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8094 c          call flush(iout)
8095           nnn=num_cont_hb(ii)+1
8096           num_cont_hb(ii)=nnn
8097           jcont_hb(nnn,ii)=jj
8098           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8099           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8100           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8101           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8102           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8103           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8104           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8105           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8106           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8107           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8108           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8109           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8110           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8111           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8112           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8113           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8114           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8115           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8116           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8117           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8118           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8119           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8120           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8121           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8122         enddo
8123       enddo
8124       call flush(iout)
8125       if (lprn) then
8126         write (iout,'(a)') 'Contact function values after receive:'
8127         do i=nnt,nct-2
8128           write (iout,'(2i3,50(1x,i3,f5.2))')
8129      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8130      &    j=1,num_cont_hb(i))
8131         enddo
8132         call flush(iout)
8133       endif
8134    30 continue
8135 #endif
8136       if (lprn) then
8137         write (iout,'(a)') 'Contact function values:'
8138         do i=nnt,nct-2
8139           write (iout,'(2i3,50(1x,i3,f5.2))')
8140      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8141      &    j=1,num_cont_hb(i))
8142         enddo
8143       endif
8144       ecorr=0.0D0
8145 C Remove the loop below after debugging !!!
8146       do i=nnt,nct
8147         do j=1,3
8148           gradcorr(j,i)=0.0D0
8149           gradxorr(j,i)=0.0D0
8150         enddo
8151       enddo
8152 C Calculate the local-electrostatic correlation terms
8153       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8154         i1=i+1
8155         num_conti=num_cont_hb(i)
8156         num_conti1=num_cont_hb(i+1)
8157         do jj=1,num_conti
8158           j=jcont_hb(jj,i)
8159           jp=iabs(j)
8160           do kk=1,num_conti1
8161             j1=jcont_hb(kk,i1)
8162             jp1=iabs(j1)
8163 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8164 c     &         ' jj=',jj,' kk=',kk
8165             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8166      &          .or. j.lt.0 .and. j1.gt.0) .and.
8167      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8168 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8169 C The system gains extra energy.
8170               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8171               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8172      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8173               n_corr=n_corr+1
8174             else if (j1.eq.j) then
8175 C Contacts I-J and I-(J+1) occur simultaneously.
8176 C The system loses extra energy.
8177 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8178             endif
8179           enddo ! kk
8180           do kk=1,num_conti
8181             j1=jcont_hb(kk,i)
8182 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8183 c    &         ' jj=',jj,' kk=',kk
8184             if (j1.eq.j+1) then
8185 C Contacts I-J and (I+1)-J occur simultaneously.
8186 C The system loses extra energy.
8187 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8188             endif ! j1==j+1
8189           enddo ! kk
8190         enddo ! jj
8191       enddo ! i
8192       return
8193       end
8194 c------------------------------------------------------------------------------
8195       subroutine add_hb_contact(ii,jj,itask)
8196       implicit real*8 (a-h,o-z)
8197       include "DIMENSIONS"
8198       include "COMMON.IOUNITS"
8199       integer max_cont
8200       integer max_dim
8201       parameter (max_cont=maxconts)
8202       parameter (max_dim=26)
8203       include "COMMON.CONTACTS"
8204       double precision zapas(max_dim,maxconts,max_fg_procs),
8205      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8206       common /przechowalnia/ zapas
8207       integer i,j,ii,jj,iproc,itask(4),nn
8208 c      write (iout,*) "itask",itask
8209       do i=1,2
8210         iproc=itask(i)
8211         if (iproc.gt.0) then
8212           do j=1,num_cont_hb(ii)
8213             jjc=jcont_hb(j,ii)
8214 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8215             if (jjc.eq.jj) then
8216               ncont_sent(iproc)=ncont_sent(iproc)+1
8217               nn=ncont_sent(iproc)
8218               zapas(1,nn,iproc)=ii
8219               zapas(2,nn,iproc)=jjc
8220               zapas(3,nn,iproc)=facont_hb(j,ii)
8221               zapas(4,nn,iproc)=ees0p(j,ii)
8222               zapas(5,nn,iproc)=ees0m(j,ii)
8223               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8224               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8225               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8226               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8227               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8228               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8229               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8230               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8231               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8232               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8233               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8234               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8235               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8236               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8237               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8238               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8239               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8240               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8241               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8242               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8243               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8244               exit
8245             endif
8246           enddo
8247         endif
8248       enddo
8249       return
8250       end
8251 c------------------------------------------------------------------------------
8252       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8253      &  n_corr1)
8254 C This subroutine calculates multi-body contributions to hydrogen-bonding
8255       implicit real*8 (a-h,o-z)
8256       include 'DIMENSIONS'
8257       include 'COMMON.IOUNITS'
8258 #ifdef MPI
8259       include "mpif.h"
8260       parameter (max_cont=maxconts)
8261       parameter (max_dim=70)
8262       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8263       double precision zapas(max_dim,maxconts,max_fg_procs),
8264      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8265       common /przechowalnia/ zapas
8266       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8267      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8268 #endif
8269       include 'COMMON.SETUP'
8270       include 'COMMON.FFIELD'
8271       include 'COMMON.DERIV'
8272       include 'COMMON.LOCAL'
8273       include 'COMMON.INTERACT'
8274       include 'COMMON.CONTACTS'
8275       include 'COMMON.CHAIN'
8276       include 'COMMON.CONTROL'
8277       include 'COMMON.SHIELD'
8278       double precision gx(3),gx1(3)
8279       integer num_cont_hb_old(maxres)
8280       logical lprn,ldone
8281       double precision eello4,eello5,eelo6,eello_turn6
8282       external eello4,eello5,eello6,eello_turn6
8283 C Set lprn=.true. for debugging
8284       lprn=.false.
8285       eturn6=0.0d0
8286 #ifdef MPI
8287       do i=1,nres
8288         num_cont_hb_old(i)=num_cont_hb(i)
8289       enddo
8290       n_corr=0
8291       n_corr1=0
8292       if (nfgtasks.le.1) goto 30
8293       if (lprn) then
8294         write (iout,'(a)') 'Contact function values before RECEIVE:'
8295         do i=nnt,nct-2
8296           write (iout,'(2i3,50(1x,i2,f5.2))')
8297      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8298      &    j=1,num_cont_hb(i))
8299         enddo
8300       endif
8301       call flush(iout)
8302       do i=1,ntask_cont_from
8303         ncont_recv(i)=0
8304       enddo
8305       do i=1,ntask_cont_to
8306         ncont_sent(i)=0
8307       enddo
8308 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8309 c     & ntask_cont_to
8310 C Make the list of contacts to send to send to other procesors
8311       do i=iturn3_start,iturn3_end
8312 c        write (iout,*) "make contact list turn3",i," num_cont",
8313 c     &    num_cont_hb(i)
8314         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8315       enddo
8316       do i=iturn4_start,iturn4_end
8317 c        write (iout,*) "make contact list turn4",i," num_cont",
8318 c     &   num_cont_hb(i)
8319         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8320       enddo
8321       do ii=1,nat_sent
8322         i=iat_sent(ii)
8323 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8324 c     &    num_cont_hb(i)
8325         do j=1,num_cont_hb(i)
8326         do k=1,4
8327           jjc=jcont_hb(j,i)
8328           iproc=iint_sent_local(k,jjc,ii)
8329 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8330           if (iproc.ne.0) then
8331             ncont_sent(iproc)=ncont_sent(iproc)+1
8332             nn=ncont_sent(iproc)
8333             zapas(1,nn,iproc)=i
8334             zapas(2,nn,iproc)=jjc
8335             zapas(3,nn,iproc)=d_cont(j,i)
8336             ind=3
8337             do kk=1,3
8338               ind=ind+1
8339               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8340             enddo
8341             do kk=1,2
8342               do ll=1,2
8343                 ind=ind+1
8344                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8345               enddo
8346             enddo
8347             do jj=1,5
8348               do kk=1,3
8349                 do ll=1,2
8350                   do mm=1,2
8351                     ind=ind+1
8352                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8353                   enddo
8354                 enddo
8355               enddo
8356             enddo
8357           endif
8358         enddo
8359         enddo
8360       enddo
8361       if (lprn) then
8362       write (iout,*)
8363      &  "Numbers of contacts to be sent to other processors",
8364      &  (ncont_sent(i),i=1,ntask_cont_to)
8365       write (iout,*) "Contacts sent"
8366       do ii=1,ntask_cont_to
8367         nn=ncont_sent(ii)
8368         iproc=itask_cont_to(ii)
8369         write (iout,*) nn," contacts to processor",iproc,
8370      &   " of CONT_TO_COMM group"
8371         do i=1,nn
8372           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8373         enddo
8374       enddo
8375       call flush(iout)
8376       endif
8377       CorrelType=477
8378       CorrelID=fg_rank+1
8379       CorrelType1=478
8380       CorrelID1=nfgtasks+fg_rank+1
8381       ireq=0
8382 C Receive the numbers of needed contacts from other processors
8383       do ii=1,ntask_cont_from
8384         iproc=itask_cont_from(ii)
8385         ireq=ireq+1
8386         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8387      &    FG_COMM,req(ireq),IERR)
8388       enddo
8389 c      write (iout,*) "IRECV ended"
8390 c      call flush(iout)
8391 C Send the number of contacts needed by other processors
8392       do ii=1,ntask_cont_to
8393         iproc=itask_cont_to(ii)
8394         ireq=ireq+1
8395         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8396      &    FG_COMM,req(ireq),IERR)
8397       enddo
8398 c      write (iout,*) "ISEND ended"
8399 c      write (iout,*) "number of requests (nn)",ireq
8400       call flush(iout)
8401       if (ireq.gt.0)
8402      &  call MPI_Waitall(ireq,req,status_array,ierr)
8403 c      write (iout,*)
8404 c     &  "Numbers of contacts to be received from other processors",
8405 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8406 c      call flush(iout)
8407 C Receive contacts
8408       ireq=0
8409       do ii=1,ntask_cont_from
8410         iproc=itask_cont_from(ii)
8411         nn=ncont_recv(ii)
8412 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8413 c     &   " of CONT_TO_COMM group"
8414         call flush(iout)
8415         if (nn.gt.0) then
8416           ireq=ireq+1
8417           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8418      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8419 c          write (iout,*) "ireq,req",ireq,req(ireq)
8420         endif
8421       enddo
8422 C Send the contacts to processors that need them
8423       do ii=1,ntask_cont_to
8424         iproc=itask_cont_to(ii)
8425         nn=ncont_sent(ii)
8426 c        write (iout,*) nn," contacts to processor",iproc,
8427 c     &   " of CONT_TO_COMM group"
8428         if (nn.gt.0) then
8429           ireq=ireq+1
8430           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8431      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8432 c          write (iout,*) "ireq,req",ireq,req(ireq)
8433 c          do i=1,nn
8434 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8435 c          enddo
8436         endif
8437       enddo
8438 c      write (iout,*) "number of requests (contacts)",ireq
8439 c      write (iout,*) "req",(req(i),i=1,4)
8440 c      call flush(iout)
8441       if (ireq.gt.0)
8442      & call MPI_Waitall(ireq,req,status_array,ierr)
8443       do iii=1,ntask_cont_from
8444         iproc=itask_cont_from(iii)
8445         nn=ncont_recv(iii)
8446         if (lprn) then
8447         write (iout,*) "Received",nn," contacts from processor",iproc,
8448      &   " of CONT_FROM_COMM group"
8449         call flush(iout)
8450         do i=1,nn
8451           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8452         enddo
8453         call flush(iout)
8454         endif
8455         do i=1,nn
8456           ii=zapas_recv(1,i,iii)
8457 c Flag the received contacts to prevent double-counting
8458           jj=-zapas_recv(2,i,iii)
8459 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8460 c          call flush(iout)
8461           nnn=num_cont_hb(ii)+1
8462           num_cont_hb(ii)=nnn
8463           jcont_hb(nnn,ii)=jj
8464           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8465           ind=3
8466           do kk=1,3
8467             ind=ind+1
8468             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8469           enddo
8470           do kk=1,2
8471             do ll=1,2
8472               ind=ind+1
8473               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8474             enddo
8475           enddo
8476           do jj=1,5
8477             do kk=1,3
8478               do ll=1,2
8479                 do mm=1,2
8480                   ind=ind+1
8481                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8482                 enddo
8483               enddo
8484             enddo
8485           enddo
8486         enddo
8487       enddo
8488       call flush(iout)
8489       if (lprn) then
8490         write (iout,'(a)') 'Contact function values after receive:'
8491         do i=nnt,nct-2
8492           write (iout,'(2i3,50(1x,i3,5f6.3))')
8493      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8494      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8495         enddo
8496         call flush(iout)
8497       endif
8498    30 continue
8499 #endif
8500       if (lprn) then
8501         write (iout,'(a)') 'Contact function values:'
8502         do i=nnt,nct-2
8503           write (iout,'(2i3,50(1x,i2,5f6.3))')
8504      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8505      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8506         enddo
8507       endif
8508       ecorr=0.0D0
8509       ecorr5=0.0d0
8510       ecorr6=0.0d0
8511 C Remove the loop below after debugging !!!
8512       do i=nnt,nct
8513         do j=1,3
8514           gradcorr(j,i)=0.0D0
8515           gradxorr(j,i)=0.0D0
8516         enddo
8517       enddo
8518 C Calculate the dipole-dipole interaction energies
8519       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8520       do i=iatel_s,iatel_e+1
8521         num_conti=num_cont_hb(i)
8522         do jj=1,num_conti
8523           j=jcont_hb(jj,i)
8524 #ifdef MOMENT
8525           call dipole(i,j,jj)
8526 #endif
8527         enddo
8528       enddo
8529       endif
8530 C Calculate the local-electrostatic correlation terms
8531 c                write (iout,*) "gradcorr5 in eello5 before loop"
8532 c                do iii=1,nres
8533 c                  write (iout,'(i5,3f10.5)')
8534 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8535 c                enddo
8536       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8537 c        write (iout,*) "corr loop i",i
8538         i1=i+1
8539         num_conti=num_cont_hb(i)
8540         num_conti1=num_cont_hb(i+1)
8541         do jj=1,num_conti
8542           j=jcont_hb(jj,i)
8543           jp=iabs(j)
8544           do kk=1,num_conti1
8545             j1=jcont_hb(kk,i1)
8546             jp1=iabs(j1)
8547 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8548 c     &         ' jj=',jj,' kk=',kk
8549 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8550             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8551      &          .or. j.lt.0 .and. j1.gt.0) .and.
8552      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8553 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8554 C The system gains extra energy.
8555               n_corr=n_corr+1
8556               sqd1=dsqrt(d_cont(jj,i))
8557               sqd2=dsqrt(d_cont(kk,i1))
8558               sred_geom = sqd1*sqd2
8559               IF (sred_geom.lt.cutoff_corr) THEN
8560                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8561      &            ekont,fprimcont)
8562 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8563 cd     &         ' jj=',jj,' kk=',kk
8564                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8565                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8566                 do l=1,3
8567                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8568                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8569                 enddo
8570                 n_corr1=n_corr1+1
8571 cd               write (iout,*) 'sred_geom=',sred_geom,
8572 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8573 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8574 cd               write (iout,*) "g_contij",g_contij
8575 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8576 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8577                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8578                 if (wcorr4.gt.0.0d0)
8579      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8580 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8581                   if (energy_dec.and.wcorr4.gt.0.0d0)
8582      1                 write (iout,'(a6,4i5,0pf7.3)')
8583      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8584 c                write (iout,*) "gradcorr5 before eello5"
8585 c                do iii=1,nres
8586 c                  write (iout,'(i5,3f10.5)')
8587 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8588 c                enddo
8589                 if (wcorr5.gt.0.0d0)
8590      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8591 c                write (iout,*) "gradcorr5 after eello5"
8592 c                do iii=1,nres
8593 c                  write (iout,'(i5,3f10.5)')
8594 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8595 c                enddo
8596                   if (energy_dec.and.wcorr5.gt.0.0d0)
8597      1                 write (iout,'(a6,4i5,0pf7.3)')
8598      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8599 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8600 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8601                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8602      &               .or. wturn6.eq.0.0d0))then
8603 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8604                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8605                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8606      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8607 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8608 cd     &            'ecorr6=',ecorr6
8609 cd                write (iout,'(4e15.5)') sred_geom,
8610 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8611 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8612 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8613                 else if (wturn6.gt.0.0d0
8614      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8615 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8616                   eturn6=eturn6+eello_turn6(i,jj,kk)
8617                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8618      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8619 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8620                 endif
8621               ENDIF
8622 1111          continue
8623             endif
8624           enddo ! kk
8625         enddo ! jj
8626       enddo ! i
8627       do i=1,nres
8628         num_cont_hb(i)=num_cont_hb_old(i)
8629       enddo
8630 c                write (iout,*) "gradcorr5 in eello5"
8631 c                do iii=1,nres
8632 c                  write (iout,'(i5,3f10.5)')
8633 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8634 c                enddo
8635       return
8636       end
8637 c------------------------------------------------------------------------------
8638       subroutine add_hb_contact_eello(ii,jj,itask)
8639       implicit real*8 (a-h,o-z)
8640       include "DIMENSIONS"
8641       include "COMMON.IOUNITS"
8642       integer max_cont
8643       integer max_dim
8644       parameter (max_cont=maxconts)
8645       parameter (max_dim=70)
8646       include "COMMON.CONTACTS"
8647       double precision zapas(max_dim,maxconts,max_fg_procs),
8648      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8649       common /przechowalnia/ zapas
8650       integer i,j,ii,jj,iproc,itask(4),nn
8651 c      write (iout,*) "itask",itask
8652       do i=1,2
8653         iproc=itask(i)
8654         if (iproc.gt.0) then
8655           do j=1,num_cont_hb(ii)
8656             jjc=jcont_hb(j,ii)
8657 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8658             if (jjc.eq.jj) then
8659               ncont_sent(iproc)=ncont_sent(iproc)+1
8660               nn=ncont_sent(iproc)
8661               zapas(1,nn,iproc)=ii
8662               zapas(2,nn,iproc)=jjc
8663               zapas(3,nn,iproc)=d_cont(j,ii)
8664               ind=3
8665               do kk=1,3
8666                 ind=ind+1
8667                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8668               enddo
8669               do kk=1,2
8670                 do ll=1,2
8671                   ind=ind+1
8672                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8673                 enddo
8674               enddo
8675               do jj=1,5
8676                 do kk=1,3
8677                   do ll=1,2
8678                     do mm=1,2
8679                       ind=ind+1
8680                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8681                     enddo
8682                   enddo
8683                 enddo
8684               enddo
8685               exit
8686             endif
8687           enddo
8688         endif
8689       enddo
8690       return
8691       end
8692 c------------------------------------------------------------------------------
8693       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8694       implicit real*8 (a-h,o-z)
8695       include 'DIMENSIONS'
8696       include 'COMMON.IOUNITS'
8697       include 'COMMON.DERIV'
8698       include 'COMMON.INTERACT'
8699       include 'COMMON.CONTACTS'
8700       include 'COMMON.SHIELD'
8701       include 'COMMON.CONTROL'
8702       double precision gx(3),gx1(3)
8703       logical lprn
8704       lprn=.false.
8705 C      print *,"wchodze",fac_shield(i),shield_mode
8706       eij=facont_hb(jj,i)
8707       ekl=facont_hb(kk,k)
8708       ees0pij=ees0p(jj,i)
8709       ees0pkl=ees0p(kk,k)
8710       ees0mij=ees0m(jj,i)
8711       ees0mkl=ees0m(kk,k)
8712       ekont=eij*ekl
8713       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8714 C*
8715 C     & fac_shield(i)**2*fac_shield(j)**2
8716 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8717 C Following 4 lines for diagnostics.
8718 cd    ees0pkl=0.0D0
8719 cd    ees0pij=1.0D0
8720 cd    ees0mkl=0.0D0
8721 cd    ees0mij=1.0D0
8722 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8723 c     & 'Contacts ',i,j,
8724 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8725 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8726 c     & 'gradcorr_long'
8727 C Calculate the multi-body contribution to energy.
8728 C      ecorr=ecorr+ekont*ees
8729 C Calculate multi-body contributions to the gradient.
8730       coeffpees0pij=coeffp*ees0pij
8731       coeffmees0mij=coeffm*ees0mij
8732       coeffpees0pkl=coeffp*ees0pkl
8733       coeffmees0mkl=coeffm*ees0mkl
8734       do ll=1,3
8735 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8736         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8737      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8738      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8739         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8740      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8741      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8742 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8743         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8744      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8745      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8746         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8747      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8748      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8749         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8750      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8751      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8752         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8753         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8754         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8755      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8756      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8757         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8758         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8759 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8760       enddo
8761 c      write (iout,*)
8762 cgrad      do m=i+1,j-1
8763 cgrad        do ll=1,3
8764 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8765 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8766 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8767 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8768 cgrad        enddo
8769 cgrad      enddo
8770 cgrad      do m=k+1,l-1
8771 cgrad        do ll=1,3
8772 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8773 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8774 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8775 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8776 cgrad        enddo
8777 cgrad      enddo
8778 c      write (iout,*) "ehbcorr",ekont*ees
8779 C      print *,ekont,ees,i,k
8780       ehbcorr=ekont*ees
8781 C now gradient over shielding
8782 C      return
8783       if (shield_mode.gt.0) then
8784        j=ees0plist(jj,i)
8785        l=ees0plist(kk,k)
8786 C        print *,i,j,fac_shield(i),fac_shield(j),
8787 C     &fac_shield(k),fac_shield(l)
8788         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8789      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8790           do ilist=1,ishield_list(i)
8791            iresshield=shield_list(ilist,i)
8792            do m=1,3
8793            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8794 C     &      *2.0
8795            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8796      &              rlocshield
8797      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8798             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8799      &+rlocshield
8800            enddo
8801           enddo
8802           do ilist=1,ishield_list(j)
8803            iresshield=shield_list(ilist,j)
8804            do m=1,3
8805            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8806 C     &     *2.0
8807            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8808      &              rlocshield
8809      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8810            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8811      &     +rlocshield
8812            enddo
8813           enddo
8814
8815           do ilist=1,ishield_list(k)
8816            iresshield=shield_list(ilist,k)
8817            do m=1,3
8818            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8819 C     &     *2.0
8820            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8821      &              rlocshield
8822      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8823            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8824      &     +rlocshield
8825            enddo
8826           enddo
8827           do ilist=1,ishield_list(l)
8828            iresshield=shield_list(ilist,l)
8829            do m=1,3
8830            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8831 C     &     *2.0
8832            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8833      &              rlocshield
8834      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8835            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8836      &     +rlocshield
8837            enddo
8838           enddo
8839 C          print *,gshieldx(m,iresshield)
8840           do m=1,3
8841             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8842      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8843             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8844      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8845             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8846      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8847             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8848      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8849
8850             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8851      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8852             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8853      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8854             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8855      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8856             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8857      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8858
8859            enddo
8860       endif
8861       endif
8862       return
8863       end
8864 #ifdef MOMENT
8865 C---------------------------------------------------------------------------
8866       subroutine dipole(i,j,jj)
8867       implicit real*8 (a-h,o-z)
8868       include 'DIMENSIONS'
8869       include 'COMMON.IOUNITS'
8870       include 'COMMON.CHAIN'
8871       include 'COMMON.FFIELD'
8872       include 'COMMON.DERIV'
8873       include 'COMMON.INTERACT'
8874       include 'COMMON.CONTACTS'
8875       include 'COMMON.TORSION'
8876       include 'COMMON.VAR'
8877       include 'COMMON.GEO'
8878       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8879      &  auxmat(2,2)
8880       iti1 = itortyp(itype(i+1))
8881       if (j.lt.nres-1) then
8882         itj1 = itype2loc(itype(j+1))
8883       else
8884         itj1=nloctyp
8885       endif
8886       do iii=1,2
8887         dipi(iii,1)=Ub2(iii,i)
8888         dipderi(iii)=Ub2der(iii,i)
8889         dipi(iii,2)=b1(iii,i+1)
8890         dipj(iii,1)=Ub2(iii,j)
8891         dipderj(iii)=Ub2der(iii,j)
8892         dipj(iii,2)=b1(iii,j+1)
8893       enddo
8894       kkk=0
8895       do iii=1,2
8896         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8897         do jjj=1,2
8898           kkk=kkk+1
8899           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8900         enddo
8901       enddo
8902       do kkk=1,5
8903         do lll=1,3
8904           mmm=0
8905           do iii=1,2
8906             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8907      &        auxvec(1))
8908             do jjj=1,2
8909               mmm=mmm+1
8910               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8911             enddo
8912           enddo
8913         enddo
8914       enddo
8915       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8916       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8917       do iii=1,2
8918         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8919       enddo
8920       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8921       do iii=1,2
8922         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8923       enddo
8924       return
8925       end
8926 #endif
8927 C---------------------------------------------------------------------------
8928       subroutine calc_eello(i,j,k,l,jj,kk)
8929 C
8930 C This subroutine computes matrices and vectors needed to calculate
8931 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8932 C
8933       implicit real*8 (a-h,o-z)
8934       include 'DIMENSIONS'
8935       include 'COMMON.IOUNITS'
8936       include 'COMMON.CHAIN'
8937       include 'COMMON.DERIV'
8938       include 'COMMON.INTERACT'
8939       include 'COMMON.CONTACTS'
8940       include 'COMMON.TORSION'
8941       include 'COMMON.VAR'
8942       include 'COMMON.GEO'
8943       include 'COMMON.FFIELD'
8944       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8945      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8946       logical lprn
8947       common /kutas/ lprn
8948 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8949 cd     & ' jj=',jj,' kk=',kk
8950 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8951 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8952 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8953       do iii=1,2
8954         do jjj=1,2
8955           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8956           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8957         enddo
8958       enddo
8959       call transpose2(aa1(1,1),aa1t(1,1))
8960       call transpose2(aa2(1,1),aa2t(1,1))
8961       do kkk=1,5
8962         do lll=1,3
8963           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8964      &      aa1tder(1,1,lll,kkk))
8965           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8966      &      aa2tder(1,1,lll,kkk))
8967         enddo
8968       enddo
8969       if (l.eq.j+1) then
8970 C parallel orientation of the two CA-CA-CA frames.
8971         if (i.gt.1) then
8972           iti=itype2loc(itype(i))
8973         else
8974           iti=nloctyp
8975         endif
8976         itk1=itype2loc(itype(k+1))
8977         itj=itype2loc(itype(j))
8978         if (l.lt.nres-1) then
8979           itl1=itype2loc(itype(l+1))
8980         else
8981           itl1=nloctyp
8982         endif
8983 C A1 kernel(j+1) A2T
8984 cd        do iii=1,2
8985 cd          write (iout,'(3f10.5,5x,3f10.5)')
8986 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8987 cd        enddo
8988         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8989      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8990      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8991 C Following matrices are needed only for 6-th order cumulants
8992         IF (wcorr6.gt.0.0d0) THEN
8993         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8994      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8995      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8996         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8997      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8998      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8999      &   ADtEAderx(1,1,1,1,1,1))
9000         lprn=.false.
9001         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9002      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9003      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9004      &   ADtEA1derx(1,1,1,1,1,1))
9005         ENDIF
9006 C End 6-th order cumulants
9007 cd        lprn=.false.
9008 cd        if (lprn) then
9009 cd        write (2,*) 'In calc_eello6'
9010 cd        do iii=1,2
9011 cd          write (2,*) 'iii=',iii
9012 cd          do kkk=1,5
9013 cd            write (2,*) 'kkk=',kkk
9014 cd            do jjj=1,2
9015 cd              write (2,'(3(2f10.5),5x)')
9016 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9017 cd            enddo
9018 cd          enddo
9019 cd        enddo
9020 cd        endif
9021         call transpose2(EUgder(1,1,k),auxmat(1,1))
9022         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9023         call transpose2(EUg(1,1,k),auxmat(1,1))
9024         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9025         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9026         do iii=1,2
9027           do kkk=1,5
9028             do lll=1,3
9029               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9030      &          EAEAderx(1,1,lll,kkk,iii,1))
9031             enddo
9032           enddo
9033         enddo
9034 C A1T kernel(i+1) A2
9035         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9036      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9037      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9038 C Following matrices are needed only for 6-th order cumulants
9039         IF (wcorr6.gt.0.0d0) THEN
9040         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9041      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9042      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9043         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9044      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9045      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9046      &   ADtEAderx(1,1,1,1,1,2))
9047         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9048      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9049      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9050      &   ADtEA1derx(1,1,1,1,1,2))
9051         ENDIF
9052 C End 6-th order cumulants
9053         call transpose2(EUgder(1,1,l),auxmat(1,1))
9054         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9055         call transpose2(EUg(1,1,l),auxmat(1,1))
9056         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9057         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9058         do iii=1,2
9059           do kkk=1,5
9060             do lll=1,3
9061               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9062      &          EAEAderx(1,1,lll,kkk,iii,2))
9063             enddo
9064           enddo
9065         enddo
9066 C AEAb1 and AEAb2
9067 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9068 C They are needed only when the fifth- or the sixth-order cumulants are
9069 C indluded.
9070         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9071         call transpose2(AEA(1,1,1),auxmat(1,1))
9072         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9073         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9074         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9075         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9076         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9077         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9078         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9079         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9080         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9081         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9082         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9083         call transpose2(AEA(1,1,2),auxmat(1,1))
9084         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9085         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9086         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9087         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9088         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9089         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9090         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9091         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9092         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9093         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9094         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9095 C Calculate the Cartesian derivatives of the vectors.
9096         do iii=1,2
9097           do kkk=1,5
9098             do lll=1,3
9099               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9100               call matvec2(auxmat(1,1),b1(1,i),
9101      &          AEAb1derx(1,lll,kkk,iii,1,1))
9102               call matvec2(auxmat(1,1),Ub2(1,i),
9103      &          AEAb2derx(1,lll,kkk,iii,1,1))
9104               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9105      &          AEAb1derx(1,lll,kkk,iii,2,1))
9106               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9107      &          AEAb2derx(1,lll,kkk,iii,2,1))
9108               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9109               call matvec2(auxmat(1,1),b1(1,j),
9110      &          AEAb1derx(1,lll,kkk,iii,1,2))
9111               call matvec2(auxmat(1,1),Ub2(1,j),
9112      &          AEAb2derx(1,lll,kkk,iii,1,2))
9113               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9114      &          AEAb1derx(1,lll,kkk,iii,2,2))
9115               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9116      &          AEAb2derx(1,lll,kkk,iii,2,2))
9117             enddo
9118           enddo
9119         enddo
9120         ENDIF
9121 C End vectors
9122       else
9123 C Antiparallel orientation of the two CA-CA-CA frames.
9124         if (i.gt.1) then
9125           iti=itype2loc(itype(i))
9126         else
9127           iti=nloctyp
9128         endif
9129         itk1=itype2loc(itype(k+1))
9130         itl=itype2loc(itype(l))
9131         itj=itype2loc(itype(j))
9132         if (j.lt.nres-1) then
9133           itj1=itype2loc(itype(j+1))
9134         else
9135           itj1=nloctyp
9136         endif
9137 C A2 kernel(j-1)T A1T
9138         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9139      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9140      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9141 C Following matrices are needed only for 6-th order cumulants
9142         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9143      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9144         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9145      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9146      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9147         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9148      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9149      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9150      &   ADtEAderx(1,1,1,1,1,1))
9151         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9152      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9153      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9154      &   ADtEA1derx(1,1,1,1,1,1))
9155         ENDIF
9156 C End 6-th order cumulants
9157         call transpose2(EUgder(1,1,k),auxmat(1,1))
9158         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9159         call transpose2(EUg(1,1,k),auxmat(1,1))
9160         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9161         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9162         do iii=1,2
9163           do kkk=1,5
9164             do lll=1,3
9165               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9166      &          EAEAderx(1,1,lll,kkk,iii,1))
9167             enddo
9168           enddo
9169         enddo
9170 C A2T kernel(i+1)T A1
9171         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9172      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9173      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9174 C Following matrices are needed only for 6-th order cumulants
9175         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9176      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9177         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9178      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9179      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9180         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9181      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9182      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9183      &   ADtEAderx(1,1,1,1,1,2))
9184         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9185      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9186      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9187      &   ADtEA1derx(1,1,1,1,1,2))
9188         ENDIF
9189 C End 6-th order cumulants
9190         call transpose2(EUgder(1,1,j),auxmat(1,1))
9191         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9192         call transpose2(EUg(1,1,j),auxmat(1,1))
9193         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9194         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9195         do iii=1,2
9196           do kkk=1,5
9197             do lll=1,3
9198               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9199      &          EAEAderx(1,1,lll,kkk,iii,2))
9200             enddo
9201           enddo
9202         enddo
9203 C AEAb1 and AEAb2
9204 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9205 C They are needed only when the fifth- or the sixth-order cumulants are
9206 C indluded.
9207         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9208      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9209         call transpose2(AEA(1,1,1),auxmat(1,1))
9210         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9211         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9212         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9213         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9214         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9215         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9216         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9217         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9218         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9219         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9220         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9221         call transpose2(AEA(1,1,2),auxmat(1,1))
9222         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9223         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9224         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9225         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9226         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9227         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9228         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9229         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9230         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9231         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9232         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9233 C Calculate the Cartesian derivatives of the vectors.
9234         do iii=1,2
9235           do kkk=1,5
9236             do lll=1,3
9237               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9238               call matvec2(auxmat(1,1),b1(1,i),
9239      &          AEAb1derx(1,lll,kkk,iii,1,1))
9240               call matvec2(auxmat(1,1),Ub2(1,i),
9241      &          AEAb2derx(1,lll,kkk,iii,1,1))
9242               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9243      &          AEAb1derx(1,lll,kkk,iii,2,1))
9244               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9245      &          AEAb2derx(1,lll,kkk,iii,2,1))
9246               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9247               call matvec2(auxmat(1,1),b1(1,l),
9248      &          AEAb1derx(1,lll,kkk,iii,1,2))
9249               call matvec2(auxmat(1,1),Ub2(1,l),
9250      &          AEAb2derx(1,lll,kkk,iii,1,2))
9251               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9252      &          AEAb1derx(1,lll,kkk,iii,2,2))
9253               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9254      &          AEAb2derx(1,lll,kkk,iii,2,2))
9255             enddo
9256           enddo
9257         enddo
9258         ENDIF
9259 C End vectors
9260       endif
9261       return
9262       end
9263 C---------------------------------------------------------------------------
9264       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9265      &  KK,KKderg,AKA,AKAderg,AKAderx)
9266       implicit none
9267       integer nderg
9268       logical transp
9269       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9270      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9271      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9272       integer iii,kkk,lll
9273       integer jjj,mmm
9274       logical lprn
9275       common /kutas/ lprn
9276       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9277       do iii=1,nderg
9278         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9279      &    AKAderg(1,1,iii))
9280       enddo
9281 cd      if (lprn) write (2,*) 'In kernel'
9282       do kkk=1,5
9283 cd        if (lprn) write (2,*) 'kkk=',kkk
9284         do lll=1,3
9285           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9286      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9287 cd          if (lprn) then
9288 cd            write (2,*) 'lll=',lll
9289 cd            write (2,*) 'iii=1'
9290 cd            do jjj=1,2
9291 cd              write (2,'(3(2f10.5),5x)')
9292 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9293 cd            enddo
9294 cd          endif
9295           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9296      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9297 cd          if (lprn) then
9298 cd            write (2,*) 'lll=',lll
9299 cd            write (2,*) 'iii=2'
9300 cd            do jjj=1,2
9301 cd              write (2,'(3(2f10.5),5x)')
9302 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9303 cd            enddo
9304 cd          endif
9305         enddo
9306       enddo
9307       return
9308       end
9309 C---------------------------------------------------------------------------
9310       double precision function eello4(i,j,k,l,jj,kk)
9311       implicit real*8 (a-h,o-z)
9312       include 'DIMENSIONS'
9313       include 'COMMON.IOUNITS'
9314       include 'COMMON.CHAIN'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       double precision pizda(2,2),ggg1(3),ggg2(3)
9322 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9323 cd        eello4=0.0d0
9324 cd        return
9325 cd      endif
9326 cd      print *,'eello4:',i,j,k,l,jj,kk
9327 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9328 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9329 cold      eij=facont_hb(jj,i)
9330 cold      ekl=facont_hb(kk,k)
9331 cold      ekont=eij*ekl
9332       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9333 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9334       gcorr_loc(k-1)=gcorr_loc(k-1)
9335      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9336       if (l.eq.j+1) then
9337         gcorr_loc(l-1)=gcorr_loc(l-1)
9338      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9339       else
9340         gcorr_loc(j-1)=gcorr_loc(j-1)
9341      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9342       endif
9343       do iii=1,2
9344         do kkk=1,5
9345           do lll=1,3
9346             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9347      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9348 cd            derx(lll,kkk,iii)=0.0d0
9349           enddo
9350         enddo
9351       enddo
9352 cd      gcorr_loc(l-1)=0.0d0
9353 cd      gcorr_loc(j-1)=0.0d0
9354 cd      gcorr_loc(k-1)=0.0d0
9355 cd      eel4=1.0d0
9356 cd      write (iout,*)'Contacts have occurred for peptide groups',
9357 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9358 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9359       if (j.lt.nres-1) then
9360         j1=j+1
9361         j2=j-1
9362       else
9363         j1=j-1
9364         j2=j-2
9365       endif
9366       if (l.lt.nres-1) then
9367         l1=l+1
9368         l2=l-1
9369       else
9370         l1=l-1
9371         l2=l-2
9372       endif
9373       do ll=1,3
9374 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9375 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9376         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9377         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9378 cgrad        ghalf=0.5d0*ggg1(ll)
9379         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9380         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9381         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9382         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9383         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9384         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9385 cgrad        ghalf=0.5d0*ggg2(ll)
9386         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9387         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9388         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9389         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9390         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9391         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9392       enddo
9393 cgrad      do m=i+1,j-1
9394 cgrad        do ll=1,3
9395 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9396 cgrad        enddo
9397 cgrad      enddo
9398 cgrad      do m=k+1,l-1
9399 cgrad        do ll=1,3
9400 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9401 cgrad        enddo
9402 cgrad      enddo
9403 cgrad      do m=i+2,j2
9404 cgrad        do ll=1,3
9405 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9406 cgrad        enddo
9407 cgrad      enddo
9408 cgrad      do m=k+2,l2
9409 cgrad        do ll=1,3
9410 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9411 cgrad        enddo
9412 cgrad      enddo
9413 cd      do iii=1,nres-3
9414 cd        write (2,*) iii,gcorr_loc(iii)
9415 cd      enddo
9416       eello4=ekont*eel4
9417 cd      write (2,*) 'ekont',ekont
9418 cd      write (iout,*) 'eello4',ekont*eel4
9419       return
9420       end
9421 C---------------------------------------------------------------------------
9422       double precision function eello5(i,j,k,l,jj,kk)
9423       implicit real*8 (a-h,o-z)
9424       include 'DIMENSIONS'
9425       include 'COMMON.IOUNITS'
9426       include 'COMMON.CHAIN'
9427       include 'COMMON.DERIV'
9428       include 'COMMON.INTERACT'
9429       include 'COMMON.CONTACTS'
9430       include 'COMMON.TORSION'
9431       include 'COMMON.VAR'
9432       include 'COMMON.GEO'
9433       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9434       double precision ggg1(3),ggg2(3)
9435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9436 C                                                                              C
9437 C                            Parallel chains                                   C
9438 C                                                                              C
9439 C          o             o                   o             o                   C
9440 C         /l\           / \             \   / \           / \   /              C
9441 C        /   \         /   \             \ /   \         /   \ /               C
9442 C       j| o |l1       | o |              o| o |         | o |o                C
9443 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9444 C      \i/   \         /   \ /             /   \         /   \                 C
9445 C       o    k1             o                                                  C
9446 C         (I)          (II)                (III)          (IV)                 C
9447 C                                                                              C
9448 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9449 C                                                                              C
9450 C                            Antiparallel chains                               C
9451 C                                                                              C
9452 C          o             o                   o             o                   C
9453 C         /j\           / \             \   / \           / \   /              C
9454 C        /   \         /   \             \ /   \         /   \ /               C
9455 C      j1| o |l        | o |              o| o |         | o |o                C
9456 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9457 C      \i/   \         /   \ /             /   \         /   \                 C
9458 C       o     k1            o                                                  C
9459 C         (I)          (II)                (III)          (IV)                 C
9460 C                                                                              C
9461 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9462 C                                                                              C
9463 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9464 C                                                                              C
9465 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9466 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9467 cd        eello5=0.0d0
9468 cd        return
9469 cd      endif
9470 cd      write (iout,*)
9471 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9472 cd     &   ' and',k,l
9473       itk=itype2loc(itype(k))
9474       itl=itype2loc(itype(l))
9475       itj=itype2loc(itype(j))
9476       eello5_1=0.0d0
9477       eello5_2=0.0d0
9478       eello5_3=0.0d0
9479       eello5_4=0.0d0
9480 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9481 cd     &   eel5_3_num,eel5_4_num)
9482       do iii=1,2
9483         do kkk=1,5
9484           do lll=1,3
9485             derx(lll,kkk,iii)=0.0d0
9486           enddo
9487         enddo
9488       enddo
9489 cd      eij=facont_hb(jj,i)
9490 cd      ekl=facont_hb(kk,k)
9491 cd      ekont=eij*ekl
9492 cd      write (iout,*)'Contacts have occurred for peptide groups',
9493 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9494 cd      goto 1111
9495 C Contribution from the graph I.
9496 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9497 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9498       call transpose2(EUg(1,1,k),auxmat(1,1))
9499       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9500       vv(1)=pizda(1,1)-pizda(2,2)
9501       vv(2)=pizda(1,2)+pizda(2,1)
9502       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9503      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9504 C Explicit gradient in virtual-dihedral angles.
9505       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9506      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9507      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9508       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9509       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9510       vv(1)=pizda(1,1)-pizda(2,2)
9511       vv(2)=pizda(1,2)+pizda(2,1)
9512       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9513      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9514      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9515       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9516       vv(1)=pizda(1,1)-pizda(2,2)
9517       vv(2)=pizda(1,2)+pizda(2,1)
9518       if (l.eq.j+1) then
9519         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9520      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9521      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9522       else
9523         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9524      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9525      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9526       endif
9527 C Cartesian gradient
9528       do iii=1,2
9529         do kkk=1,5
9530           do lll=1,3
9531             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9532      &        pizda(1,1))
9533             vv(1)=pizda(1,1)-pizda(2,2)
9534             vv(2)=pizda(1,2)+pizda(2,1)
9535             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9536      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9537      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9538           enddo
9539         enddo
9540       enddo
9541 c      goto 1112
9542 c1111  continue
9543 C Contribution from graph II
9544       call transpose2(EE(1,1,k),auxmat(1,1))
9545       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9546       vv(1)=pizda(1,1)+pizda(2,2)
9547       vv(2)=pizda(2,1)-pizda(1,2)
9548       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9549      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9550 C Explicit gradient in virtual-dihedral angles.
9551       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9552      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9553       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9554       vv(1)=pizda(1,1)+pizda(2,2)
9555       vv(2)=pizda(2,1)-pizda(1,2)
9556       if (l.eq.j+1) then
9557         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9558      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9559      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9560       else
9561         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9562      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9563      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9564       endif
9565 C Cartesian gradient
9566       do iii=1,2
9567         do kkk=1,5
9568           do lll=1,3
9569             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9570      &        pizda(1,1))
9571             vv(1)=pizda(1,1)+pizda(2,2)
9572             vv(2)=pizda(2,1)-pizda(1,2)
9573             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9574      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9575      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9576           enddo
9577         enddo
9578       enddo
9579 cd      goto 1112
9580 cd1111  continue
9581       if (l.eq.j+1) then
9582 cd        goto 1110
9583 C Parallel orientation
9584 C Contribution from graph III
9585         call transpose2(EUg(1,1,l),auxmat(1,1))
9586         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9587         vv(1)=pizda(1,1)-pizda(2,2)
9588         vv(2)=pizda(1,2)+pizda(2,1)
9589         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9591 C Explicit gradient in virtual-dihedral angles.
9592         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9593      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9594      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9595         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9596         vv(1)=pizda(1,1)-pizda(2,2)
9597         vv(2)=pizda(1,2)+pizda(2,1)
9598         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9599      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9600      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9601         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9602         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9603         vv(1)=pizda(1,1)-pizda(2,2)
9604         vv(2)=pizda(1,2)+pizda(2,1)
9605         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9606      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9607      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9608 C Cartesian gradient
9609         do iii=1,2
9610           do kkk=1,5
9611             do lll=1,3
9612               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9613      &          pizda(1,1))
9614               vv(1)=pizda(1,1)-pizda(2,2)
9615               vv(2)=pizda(1,2)+pizda(2,1)
9616               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9617      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9618      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9619             enddo
9620           enddo
9621         enddo
9622 cd        goto 1112
9623 C Contribution from graph IV
9624 cd1110    continue
9625         call transpose2(EE(1,1,l),auxmat(1,1))
9626         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9627         vv(1)=pizda(1,1)+pizda(2,2)
9628         vv(2)=pizda(2,1)-pizda(1,2)
9629         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9630      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9631 C Explicit gradient in virtual-dihedral angles.
9632         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9633      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9634         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9635         vv(1)=pizda(1,1)+pizda(2,2)
9636         vv(2)=pizda(2,1)-pizda(1,2)
9637         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9638      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9639      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9640 C Cartesian gradient
9641         do iii=1,2
9642           do kkk=1,5
9643             do lll=1,3
9644               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9645      &          pizda(1,1))
9646               vv(1)=pizda(1,1)+pizda(2,2)
9647               vv(2)=pizda(2,1)-pizda(1,2)
9648               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9649      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9650      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9651             enddo
9652           enddo
9653         enddo
9654       else
9655 C Antiparallel orientation
9656 C Contribution from graph III
9657 c        goto 1110
9658         call transpose2(EUg(1,1,j),auxmat(1,1))
9659         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9660         vv(1)=pizda(1,1)-pizda(2,2)
9661         vv(2)=pizda(1,2)+pizda(2,1)
9662         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9664 C Explicit gradient in virtual-dihedral angles.
9665         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9666      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9667      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9668         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9669         vv(1)=pizda(1,1)-pizda(2,2)
9670         vv(2)=pizda(1,2)+pizda(2,1)
9671         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9672      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9673      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9674         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9675         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9676         vv(1)=pizda(1,1)-pizda(2,2)
9677         vv(2)=pizda(1,2)+pizda(2,1)
9678         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9679      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9680      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9681 C Cartesian gradient
9682         do iii=1,2
9683           do kkk=1,5
9684             do lll=1,3
9685               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9686      &          pizda(1,1))
9687               vv(1)=pizda(1,1)-pizda(2,2)
9688               vv(2)=pizda(1,2)+pizda(2,1)
9689               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9690      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9691      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9692             enddo
9693           enddo
9694         enddo
9695 cd        goto 1112
9696 C Contribution from graph IV
9697 1110    continue
9698         call transpose2(EE(1,1,j),auxmat(1,1))
9699         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9700         vv(1)=pizda(1,1)+pizda(2,2)
9701         vv(2)=pizda(2,1)-pizda(1,2)
9702         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9703      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9704 C Explicit gradient in virtual-dihedral angles.
9705         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9706      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9707         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9708         vv(1)=pizda(1,1)+pizda(2,2)
9709         vv(2)=pizda(2,1)-pizda(1,2)
9710         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9711      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9712      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9713 C Cartesian gradient
9714         do iii=1,2
9715           do kkk=1,5
9716             do lll=1,3
9717               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9718      &          pizda(1,1))
9719               vv(1)=pizda(1,1)+pizda(2,2)
9720               vv(2)=pizda(2,1)-pizda(1,2)
9721               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9722      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9723      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9724             enddo
9725           enddo
9726         enddo
9727       endif
9728 1112  continue
9729       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9730 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9731 cd        write (2,*) 'ijkl',i,j,k,l
9732 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9733 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9734 cd      endif
9735 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9736 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9737 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9738 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9739       if (j.lt.nres-1) then
9740         j1=j+1
9741         j2=j-1
9742       else
9743         j1=j-1
9744         j2=j-2
9745       endif
9746       if (l.lt.nres-1) then
9747         l1=l+1
9748         l2=l-1
9749       else
9750         l1=l-1
9751         l2=l-2
9752       endif
9753 cd      eij=1.0d0
9754 cd      ekl=1.0d0
9755 cd      ekont=1.0d0
9756 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9757 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9758 C        summed up outside the subrouine as for the other subroutines
9759 C        handling long-range interactions. The old code is commented out
9760 C        with "cgrad" to keep track of changes.
9761       do ll=1,3
9762 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9763 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9764         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9765         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9766 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9767 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9768 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9769 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9770 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9771 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9772 c     &   gradcorr5ij,
9773 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9774 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9775 cgrad        ghalf=0.5d0*ggg1(ll)
9776 cd        ghalf=0.0d0
9777         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9778         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9779         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9780         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9781         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9782         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9783 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9784 cgrad        ghalf=0.5d0*ggg2(ll)
9785 cd        ghalf=0.0d0
9786         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9787         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9788         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9789         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9790         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9791         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9792       enddo
9793 cd      goto 1112
9794 cgrad      do m=i+1,j-1
9795 cgrad        do ll=1,3
9796 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9797 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9798 cgrad        enddo
9799 cgrad      enddo
9800 cgrad      do m=k+1,l-1
9801 cgrad        do ll=1,3
9802 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9803 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9804 cgrad        enddo
9805 cgrad      enddo
9806 c1112  continue
9807 cgrad      do m=i+2,j2
9808 cgrad        do ll=1,3
9809 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9810 cgrad        enddo
9811 cgrad      enddo
9812 cgrad      do m=k+2,l2
9813 cgrad        do ll=1,3
9814 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9815 cgrad        enddo
9816 cgrad      enddo
9817 cd      do iii=1,nres-3
9818 cd        write (2,*) iii,g_corr5_loc(iii)
9819 cd      enddo
9820       eello5=ekont*eel5
9821 cd      write (2,*) 'ekont',ekont
9822 cd      write (iout,*) 'eello5',ekont*eel5
9823       return
9824       end
9825 c--------------------------------------------------------------------------
9826       double precision function eello6(i,j,k,l,jj,kk)
9827       implicit real*8 (a-h,o-z)
9828       include 'DIMENSIONS'
9829       include 'COMMON.IOUNITS'
9830       include 'COMMON.CHAIN'
9831       include 'COMMON.DERIV'
9832       include 'COMMON.INTERACT'
9833       include 'COMMON.CONTACTS'
9834       include 'COMMON.TORSION'
9835       include 'COMMON.VAR'
9836       include 'COMMON.GEO'
9837       include 'COMMON.FFIELD'
9838       double precision ggg1(3),ggg2(3)
9839 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9840 cd        eello6=0.0d0
9841 cd        return
9842 cd      endif
9843 cd      write (iout,*)
9844 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9845 cd     &   ' and',k,l
9846       eello6_1=0.0d0
9847       eello6_2=0.0d0
9848       eello6_3=0.0d0
9849       eello6_4=0.0d0
9850       eello6_5=0.0d0
9851       eello6_6=0.0d0
9852 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9853 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9854       do iii=1,2
9855         do kkk=1,5
9856           do lll=1,3
9857             derx(lll,kkk,iii)=0.0d0
9858           enddo
9859         enddo
9860       enddo
9861 cd      eij=facont_hb(jj,i)
9862 cd      ekl=facont_hb(kk,k)
9863 cd      ekont=eij*ekl
9864 cd      eij=1.0d0
9865 cd      ekl=1.0d0
9866 cd      ekont=1.0d0
9867       if (l.eq.j+1) then
9868         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9869         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9870         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9871         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9872         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9873         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9874       else
9875         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9876         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9877         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9878         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9879         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9880           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9881         else
9882           eello6_5=0.0d0
9883         endif
9884         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9885       endif
9886 C If turn contributions are considered, they will be handled separately.
9887       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9888 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9889 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9890 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9891 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9892 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9893 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9894 cd      goto 1112
9895       if (j.lt.nres-1) then
9896         j1=j+1
9897         j2=j-1
9898       else
9899         j1=j-1
9900         j2=j-2
9901       endif
9902       if (l.lt.nres-1) then
9903         l1=l+1
9904         l2=l-1
9905       else
9906         l1=l-1
9907         l2=l-2
9908       endif
9909       do ll=1,3
9910 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9911 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9912 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9913 cgrad        ghalf=0.5d0*ggg1(ll)
9914 cd        ghalf=0.0d0
9915         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9916         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9917         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9918         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9919         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9920         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9921         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9922         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9923 cgrad        ghalf=0.5d0*ggg2(ll)
9924 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9925 cd        ghalf=0.0d0
9926         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9927         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9928         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9929         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9930         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9931         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9932       enddo
9933 cd      goto 1112
9934 cgrad      do m=i+1,j-1
9935 cgrad        do ll=1,3
9936 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9937 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9938 cgrad        enddo
9939 cgrad      enddo
9940 cgrad      do m=k+1,l-1
9941 cgrad        do ll=1,3
9942 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9943 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9944 cgrad        enddo
9945 cgrad      enddo
9946 cgrad1112  continue
9947 cgrad      do m=i+2,j2
9948 cgrad        do ll=1,3
9949 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9950 cgrad        enddo
9951 cgrad      enddo
9952 cgrad      do m=k+2,l2
9953 cgrad        do ll=1,3
9954 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9955 cgrad        enddo
9956 cgrad      enddo
9957 cd      do iii=1,nres-3
9958 cd        write (2,*) iii,g_corr6_loc(iii)
9959 cd      enddo
9960       eello6=ekont*eel6
9961 cd      write (2,*) 'ekont',ekont
9962 cd      write (iout,*) 'eello6',ekont*eel6
9963       return
9964       end
9965 c--------------------------------------------------------------------------
9966       double precision function eello6_graph1(i,j,k,l,imat,swap)
9967       implicit real*8 (a-h,o-z)
9968       include 'DIMENSIONS'
9969       include 'COMMON.IOUNITS'
9970       include 'COMMON.CHAIN'
9971       include 'COMMON.DERIV'
9972       include 'COMMON.INTERACT'
9973       include 'COMMON.CONTACTS'
9974       include 'COMMON.TORSION'
9975       include 'COMMON.VAR'
9976       include 'COMMON.GEO'
9977       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9978       logical swap
9979       logical lprn
9980       common /kutas/ lprn
9981 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9982 C                                                                              C
9983 C      Parallel       Antiparallel                                             C
9984 C                                                                              C
9985 C          o             o                                                     C
9986 C         /l\           /j\                                                    C
9987 C        /   \         /   \                                                   C
9988 C       /| o |         | o |\                                                  C
9989 C     \ j|/k\|  /   \  |/k\|l /                                                C
9990 C      \ /   \ /     \ /   \ /                                                 C
9991 C       o     o       o     o                                                  C
9992 C       i             i                                                        C
9993 C                                                                              C
9994 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9995       itk=itype2loc(itype(k))
9996       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9997       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9998       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9999       call transpose2(EUgC(1,1,k),auxmat(1,1))
10000       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10001       vv1(1)=pizda1(1,1)-pizda1(2,2)
10002       vv1(2)=pizda1(1,2)+pizda1(2,1)
10003       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10004       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10005       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10006       s5=scalar2(vv(1),Dtobr2(1,i))
10007 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10008       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10009       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10010      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10011      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10012      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10013      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10014      & +scalar2(vv(1),Dtobr2der(1,i)))
10015       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10016       vv1(1)=pizda1(1,1)-pizda1(2,2)
10017       vv1(2)=pizda1(1,2)+pizda1(2,1)
10018       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10019       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10020       if (l.eq.j+1) then
10021         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10022      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10023      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10024      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10025      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10026       else
10027         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10028      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10029      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10030      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10031      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10032       endif
10033       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10034       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10035       vv1(1)=pizda1(1,1)-pizda1(2,2)
10036       vv1(2)=pizda1(1,2)+pizda1(2,1)
10037       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10038      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10039      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10040      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10041       do iii=1,2
10042         if (swap) then
10043           ind=3-iii
10044         else
10045           ind=iii
10046         endif
10047         do kkk=1,5
10048           do lll=1,3
10049             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10050             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10051             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10052             call transpose2(EUgC(1,1,k),auxmat(1,1))
10053             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10054      &        pizda1(1,1))
10055             vv1(1)=pizda1(1,1)-pizda1(2,2)
10056             vv1(2)=pizda1(1,2)+pizda1(2,1)
10057             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10058             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10059      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10060             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10061      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10062             s5=scalar2(vv(1),Dtobr2(1,i))
10063             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10064           enddo
10065         enddo
10066       enddo
10067       return
10068       end
10069 c----------------------------------------------------------------------------
10070       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10071       implicit real*8 (a-h,o-z)
10072       include 'DIMENSIONS'
10073       include 'COMMON.IOUNITS'
10074       include 'COMMON.CHAIN'
10075       include 'COMMON.DERIV'
10076       include 'COMMON.INTERACT'
10077       include 'COMMON.CONTACTS'
10078       include 'COMMON.TORSION'
10079       include 'COMMON.VAR'
10080       include 'COMMON.GEO'
10081       logical swap
10082       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10083      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10084       logical lprn
10085       common /kutas/ lprn
10086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10087 C                                                                              C
10088 C      Parallel       Antiparallel                                             C
10089 C                                                                              C
10090 C          o             o                                                     C
10091 C     \   /l\           /j\   /                                                C
10092 C      \ /   \         /   \ /                                                 C
10093 C       o| o |         | o |o                                                  C
10094 C     \ j|/k\|      \  |/k\|l                                                  C
10095 C      \ /   \       \ /   \                                                   C
10096 C       o             o                                                        C
10097 C       i             i                                                        C
10098 C                                                                              C
10099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10100 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10101 C AL 7/4/01 s1 would occur in the sixth-order moment,
10102 C           but not in a cluster cumulant
10103 #ifdef MOMENT
10104       s1=dip(1,jj,i)*dip(1,kk,k)
10105 #endif
10106       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10107       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10108       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10109       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10110       call transpose2(EUg(1,1,k),auxmat(1,1))
10111       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10112       vv(1)=pizda(1,1)-pizda(2,2)
10113       vv(2)=pizda(1,2)+pizda(2,1)
10114       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10115 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10116 #ifdef MOMENT
10117       eello6_graph2=-(s1+s2+s3+s4)
10118 #else
10119       eello6_graph2=-(s2+s3+s4)
10120 #endif
10121 c      eello6_graph2=-s3
10122 C Derivatives in gamma(i-1)
10123       if (i.gt.1) then
10124 #ifdef MOMENT
10125         s1=dipderg(1,jj,i)*dip(1,kk,k)
10126 #endif
10127         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10128         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10129         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10130         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10131 #ifdef MOMENT
10132         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10133 #else
10134         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10135 #endif
10136 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10137       endif
10138 C Derivatives in gamma(k-1)
10139 #ifdef MOMENT
10140       s1=dip(1,jj,i)*dipderg(1,kk,k)
10141 #endif
10142       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10143       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10144       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10145       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10146       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10147       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10148       vv(1)=pizda(1,1)-pizda(2,2)
10149       vv(2)=pizda(1,2)+pizda(2,1)
10150       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10151 #ifdef MOMENT
10152       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10153 #else
10154       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10155 #endif
10156 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10157 C Derivatives in gamma(j-1) or gamma(l-1)
10158       if (j.gt.1) then
10159 #ifdef MOMENT
10160         s1=dipderg(3,jj,i)*dip(1,kk,k)
10161 #endif
10162         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10163         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10164         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10165         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10166         vv(1)=pizda(1,1)-pizda(2,2)
10167         vv(2)=pizda(1,2)+pizda(2,1)
10168         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10169 #ifdef MOMENT
10170         if (swap) then
10171           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10172         else
10173           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10174         endif
10175 #endif
10176         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10177 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10178       endif
10179 C Derivatives in gamma(l-1) or gamma(j-1)
10180       if (l.gt.1) then
10181 #ifdef MOMENT
10182         s1=dip(1,jj,i)*dipderg(3,kk,k)
10183 #endif
10184         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10185         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10186         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10187         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10188         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10189         vv(1)=pizda(1,1)-pizda(2,2)
10190         vv(2)=pizda(1,2)+pizda(2,1)
10191         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10192 #ifdef MOMENT
10193         if (swap) then
10194           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10195         else
10196           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10197         endif
10198 #endif
10199         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10200 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10201       endif
10202 C Cartesian derivatives.
10203       if (lprn) then
10204         write (2,*) 'In eello6_graph2'
10205         do iii=1,2
10206           write (2,*) 'iii=',iii
10207           do kkk=1,5
10208             write (2,*) 'kkk=',kkk
10209             do jjj=1,2
10210               write (2,'(3(2f10.5),5x)')
10211      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10212             enddo
10213           enddo
10214         enddo
10215       endif
10216       do iii=1,2
10217         do kkk=1,5
10218           do lll=1,3
10219 #ifdef MOMENT
10220             if (iii.eq.1) then
10221               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10222             else
10223               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10224             endif
10225 #endif
10226             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10227      &        auxvec(1))
10228             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10229             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10230      &        auxvec(1))
10231             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10232             call transpose2(EUg(1,1,k),auxmat(1,1))
10233             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10234      &        pizda(1,1))
10235             vv(1)=pizda(1,1)-pizda(2,2)
10236             vv(2)=pizda(1,2)+pizda(2,1)
10237             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10238 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10239 #ifdef MOMENT
10240             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10241 #else
10242             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10243 #endif
10244             if (swap) then
10245               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10246             else
10247               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10248             endif
10249           enddo
10250         enddo
10251       enddo
10252       return
10253       end
10254 c----------------------------------------------------------------------------
10255       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10256       implicit real*8 (a-h,o-z)
10257       include 'DIMENSIONS'
10258       include 'COMMON.IOUNITS'
10259       include 'COMMON.CHAIN'
10260       include 'COMMON.DERIV'
10261       include 'COMMON.INTERACT'
10262       include 'COMMON.CONTACTS'
10263       include 'COMMON.TORSION'
10264       include 'COMMON.VAR'
10265       include 'COMMON.GEO'
10266       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10267       logical swap
10268 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10269 C                                                                              C
10270 C      Parallel       Antiparallel                                             C
10271 C                                                                              C
10272 C          o             o                                                     C
10273 C         /l\   /   \   /j\                                                    C
10274 C        /   \ /     \ /   \                                                   C
10275 C       /| o |o       o| o |\                                                  C
10276 C       j|/k\|  /      |/k\|l /                                                C
10277 C        /   \ /       /   \ /                                                 C
10278 C       /     o       /     o                                                  C
10279 C       i             i                                                        C
10280 C                                                                              C
10281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10282 C
10283 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10284 C           energy moment and not to the cluster cumulant.
10285       iti=itortyp(itype(i))
10286       if (j.lt.nres-1) then
10287         itj1=itype2loc(itype(j+1))
10288       else
10289         itj1=nloctyp
10290       endif
10291       itk=itype2loc(itype(k))
10292       itk1=itype2loc(itype(k+1))
10293       if (l.lt.nres-1) then
10294         itl1=itype2loc(itype(l+1))
10295       else
10296         itl1=nloctyp
10297       endif
10298 #ifdef MOMENT
10299       s1=dip(4,jj,i)*dip(4,kk,k)
10300 #endif
10301       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10302       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10303       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10304       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10305       call transpose2(EE(1,1,k),auxmat(1,1))
10306       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10307       vv(1)=pizda(1,1)+pizda(2,2)
10308       vv(2)=pizda(2,1)-pizda(1,2)
10309       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10310 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10311 cd     & "sum",-(s2+s3+s4)
10312 #ifdef MOMENT
10313       eello6_graph3=-(s1+s2+s3+s4)
10314 #else
10315       eello6_graph3=-(s2+s3+s4)
10316 #endif
10317 c      eello6_graph3=-s4
10318 C Derivatives in gamma(k-1)
10319       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10320       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10321       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10322       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10323 C Derivatives in gamma(l-1)
10324       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10325       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10326       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10327       vv(1)=pizda(1,1)+pizda(2,2)
10328       vv(2)=pizda(2,1)-pizda(1,2)
10329       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10330       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10331 C Cartesian derivatives.
10332       do iii=1,2
10333         do kkk=1,5
10334           do lll=1,3
10335 #ifdef MOMENT
10336             if (iii.eq.1) then
10337               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10338             else
10339               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10340             endif
10341 #endif
10342             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10343      &        auxvec(1))
10344             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10345             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10346      &        auxvec(1))
10347             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10348             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10349      &        pizda(1,1))
10350             vv(1)=pizda(1,1)+pizda(2,2)
10351             vv(2)=pizda(2,1)-pizda(1,2)
10352             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10353 #ifdef MOMENT
10354             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10355 #else
10356             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10357 #endif
10358             if (swap) then
10359               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10360             else
10361               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10362             endif
10363 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10364           enddo
10365         enddo
10366       enddo
10367       return
10368       end
10369 c----------------------------------------------------------------------------
10370       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10371       implicit real*8 (a-h,o-z)
10372       include 'DIMENSIONS'
10373       include 'COMMON.IOUNITS'
10374       include 'COMMON.CHAIN'
10375       include 'COMMON.DERIV'
10376       include 'COMMON.INTERACT'
10377       include 'COMMON.CONTACTS'
10378       include 'COMMON.TORSION'
10379       include 'COMMON.VAR'
10380       include 'COMMON.GEO'
10381       include 'COMMON.FFIELD'
10382       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10383      & auxvec1(2),auxmat1(2,2)
10384       logical swap
10385 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10386 C                                                                              C
10387 C      Parallel       Antiparallel                                             C
10388 C                                                                              C
10389 C          o             o                                                     C
10390 C         /l\   /   \   /j\                                                    C
10391 C        /   \ /     \ /   \                                                   C
10392 C       /| o |o       o| o |\                                                  C
10393 C     \ j|/k\|      \  |/k\|l                                                  C
10394 C      \ /   \       \ /   \                                                   C
10395 C       o     \       o     \                                                  C
10396 C       i             i                                                        C
10397 C                                                                              C
10398 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10399 C
10400 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10401 C           energy moment and not to the cluster cumulant.
10402 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10403       iti=itype2loc(itype(i))
10404       itj=itype2loc(itype(j))
10405       if (j.lt.nres-1) then
10406         itj1=itype2loc(itype(j+1))
10407       else
10408         itj1=nloctyp
10409       endif
10410       itk=itype2loc(itype(k))
10411       if (k.lt.nres-1) then
10412         itk1=itype2loc(itype(k+1))
10413       else
10414         itk1=nloctyp
10415       endif
10416       itl=itype2loc(itype(l))
10417       if (l.lt.nres-1) then
10418         itl1=itype2loc(itype(l+1))
10419       else
10420         itl1=nloctyp
10421       endif
10422 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10423 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10424 cd     & ' itl',itl,' itl1',itl1
10425 #ifdef MOMENT
10426       if (imat.eq.1) then
10427         s1=dip(3,jj,i)*dip(3,kk,k)
10428       else
10429         s1=dip(2,jj,j)*dip(2,kk,l)
10430       endif
10431 #endif
10432       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10433       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10434       if (j.eq.l+1) then
10435         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10436         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10437       else
10438         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10439         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10440       endif
10441       call transpose2(EUg(1,1,k),auxmat(1,1))
10442       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10443       vv(1)=pizda(1,1)-pizda(2,2)
10444       vv(2)=pizda(2,1)+pizda(1,2)
10445       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10446 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10447 #ifdef MOMENT
10448       eello6_graph4=-(s1+s2+s3+s4)
10449 #else
10450       eello6_graph4=-(s2+s3+s4)
10451 #endif
10452 C Derivatives in gamma(i-1)
10453       if (i.gt.1) then
10454 #ifdef MOMENT
10455         if (imat.eq.1) then
10456           s1=dipderg(2,jj,i)*dip(3,kk,k)
10457         else
10458           s1=dipderg(4,jj,j)*dip(2,kk,l)
10459         endif
10460 #endif
10461         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10462         if (j.eq.l+1) then
10463           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10464           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10465         else
10466           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10467           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10468         endif
10469         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10470         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10471 cd          write (2,*) 'turn6 derivatives'
10472 #ifdef MOMENT
10473           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10474 #else
10475           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10476 #endif
10477         else
10478 #ifdef MOMENT
10479           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10480 #else
10481           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10482 #endif
10483         endif
10484       endif
10485 C Derivatives in gamma(k-1)
10486 #ifdef MOMENT
10487       if (imat.eq.1) then
10488         s1=dip(3,jj,i)*dipderg(2,kk,k)
10489       else
10490         s1=dip(2,jj,j)*dipderg(4,kk,l)
10491       endif
10492 #endif
10493       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10494       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10495       if (j.eq.l+1) then
10496         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10497         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10498       else
10499         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10500         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10501       endif
10502       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10503       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10504       vv(1)=pizda(1,1)-pizda(2,2)
10505       vv(2)=pizda(2,1)+pizda(1,2)
10506       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10507       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10508 #ifdef MOMENT
10509         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10510 #else
10511         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10512 #endif
10513       else
10514 #ifdef MOMENT
10515         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10516 #else
10517         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10518 #endif
10519       endif
10520 C Derivatives in gamma(j-1) or gamma(l-1)
10521       if (l.eq.j+1 .and. l.gt.1) then
10522         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10523         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10524         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10525         vv(1)=pizda(1,1)-pizda(2,2)
10526         vv(2)=pizda(2,1)+pizda(1,2)
10527         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10528         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10529       else if (j.gt.1) then
10530         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10531         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10532         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10533         vv(1)=pizda(1,1)-pizda(2,2)
10534         vv(2)=pizda(2,1)+pizda(1,2)
10535         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10536         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10537           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10538         else
10539           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10540         endif
10541       endif
10542 C Cartesian derivatives.
10543       do iii=1,2
10544         do kkk=1,5
10545           do lll=1,3
10546 #ifdef MOMENT
10547             if (iii.eq.1) then
10548               if (imat.eq.1) then
10549                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10550               else
10551                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10552               endif
10553             else
10554               if (imat.eq.1) then
10555                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10556               else
10557                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10558               endif
10559             endif
10560 #endif
10561             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10562      &        auxvec(1))
10563             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10564             if (j.eq.l+1) then
10565               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10566      &          b1(1,j+1),auxvec(1))
10567               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10568             else
10569               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10570      &          b1(1,l+1),auxvec(1))
10571               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10572             endif
10573             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10574      &        pizda(1,1))
10575             vv(1)=pizda(1,1)-pizda(2,2)
10576             vv(2)=pizda(2,1)+pizda(1,2)
10577             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10578             if (swap) then
10579               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10580 #ifdef MOMENT
10581                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10582      &             -(s1+s2+s4)
10583 #else
10584                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10585      &             -(s2+s4)
10586 #endif
10587                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10588               else
10589 #ifdef MOMENT
10590                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10591 #else
10592                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10593 #endif
10594                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10595               endif
10596             else
10597 #ifdef MOMENT
10598               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10599 #else
10600               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10601 #endif
10602               if (l.eq.j+1) then
10603                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10604               else
10605                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10606               endif
10607             endif
10608           enddo
10609         enddo
10610       enddo
10611       return
10612       end
10613 c----------------------------------------------------------------------------
10614       double precision function eello_turn6(i,jj,kk)
10615       implicit real*8 (a-h,o-z)
10616       include 'DIMENSIONS'
10617       include 'COMMON.IOUNITS'
10618       include 'COMMON.CHAIN'
10619       include 'COMMON.DERIV'
10620       include 'COMMON.INTERACT'
10621       include 'COMMON.CONTACTS'
10622       include 'COMMON.TORSION'
10623       include 'COMMON.VAR'
10624       include 'COMMON.GEO'
10625       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10626      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10627      &  ggg1(3),ggg2(3)
10628       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10629      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10630 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10631 C           the respective energy moment and not to the cluster cumulant.
10632       s1=0.0d0
10633       s8=0.0d0
10634       s13=0.0d0
10635 c
10636       eello_turn6=0.0d0
10637       j=i+4
10638       k=i+1
10639       l=i+3
10640       iti=itype2loc(itype(i))
10641       itk=itype2loc(itype(k))
10642       itk1=itype2loc(itype(k+1))
10643       itl=itype2loc(itype(l))
10644       itj=itype2loc(itype(j))
10645 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10646 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10647 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10648 cd        eello6=0.0d0
10649 cd        return
10650 cd      endif
10651 cd      write (iout,*)
10652 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10653 cd     &   ' and',k,l
10654 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10655       do iii=1,2
10656         do kkk=1,5
10657           do lll=1,3
10658             derx_turn(lll,kkk,iii)=0.0d0
10659           enddo
10660         enddo
10661       enddo
10662 cd      eij=1.0d0
10663 cd      ekl=1.0d0
10664 cd      ekont=1.0d0
10665       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10666 cd      eello6_5=0.0d0
10667 cd      write (2,*) 'eello6_5',eello6_5
10668 #ifdef MOMENT
10669       call transpose2(AEA(1,1,1),auxmat(1,1))
10670       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10671       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10672       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10673 #endif
10674       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10675       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10676       s2 = scalar2(b1(1,k),vtemp1(1))
10677 #ifdef MOMENT
10678       call transpose2(AEA(1,1,2),atemp(1,1))
10679       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10680       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10681       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10682 #endif
10683       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10684       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10685       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10686 #ifdef MOMENT
10687       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10688       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10689       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10690       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10691       ss13 = scalar2(b1(1,k),vtemp4(1))
10692       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10693 #endif
10694 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10695 c      s1=0.0d0
10696 c      s2=0.0d0
10697 c      s8=0.0d0
10698 c      s12=0.0d0
10699 c      s13=0.0d0
10700       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10701 C Derivatives in gamma(i+2)
10702       s1d =0.0d0
10703       s8d =0.0d0
10704 #ifdef MOMENT
10705       call transpose2(AEA(1,1,1),auxmatd(1,1))
10706       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10707       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10708       call transpose2(AEAderg(1,1,2),atempd(1,1))
10709       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10710       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10711 #endif
10712       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10713       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10714       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10715 c      s1d=0.0d0
10716 c      s2d=0.0d0
10717 c      s8d=0.0d0
10718 c      s12d=0.0d0
10719 c      s13d=0.0d0
10720       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10721 C Derivatives in gamma(i+3)
10722 #ifdef MOMENT
10723       call transpose2(AEA(1,1,1),auxmatd(1,1))
10724       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10725       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10726       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10727 #endif
10728       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10729       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10730       s2d = scalar2(b1(1,k),vtemp1d(1))
10731 #ifdef MOMENT
10732       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10733       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10734 #endif
10735       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10736 #ifdef MOMENT
10737       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10738       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10739       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10740 #endif
10741 c      s1d=0.0d0
10742 c      s2d=0.0d0
10743 c      s8d=0.0d0
10744 c      s12d=0.0d0
10745 c      s13d=0.0d0
10746 #ifdef MOMENT
10747       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10748      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10749 #else
10750       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10751      &               -0.5d0*ekont*(s2d+s12d)
10752 #endif
10753 C Derivatives in gamma(i+4)
10754       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10755       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10756       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10757 #ifdef MOMENT
10758       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10759       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10760       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10761 #endif
10762 c      s1d=0.0d0
10763 c      s2d=0.0d0
10764 c      s8d=0.0d0
10765 C      s12d=0.0d0
10766 c      s13d=0.0d0
10767 #ifdef MOMENT
10768       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10769 #else
10770       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10771 #endif
10772 C Derivatives in gamma(i+5)
10773 #ifdef MOMENT
10774       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10775       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10776       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10777 #endif
10778       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10779       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10780       s2d = scalar2(b1(1,k),vtemp1d(1))
10781 #ifdef MOMENT
10782       call transpose2(AEA(1,1,2),atempd(1,1))
10783       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10784       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10785 #endif
10786       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10787       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10788 #ifdef MOMENT
10789       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10790       ss13d = scalar2(b1(1,k),vtemp4d(1))
10791       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10792 #endif
10793 c      s1d=0.0d0
10794 c      s2d=0.0d0
10795 c      s8d=0.0d0
10796 c      s12d=0.0d0
10797 c      s13d=0.0d0
10798 #ifdef MOMENT
10799       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10800      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10801 #else
10802       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10803      &               -0.5d0*ekont*(s2d+s12d)
10804 #endif
10805 C Cartesian derivatives
10806       do iii=1,2
10807         do kkk=1,5
10808           do lll=1,3
10809 #ifdef MOMENT
10810             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10811             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10812             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10813 #endif
10814             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10815             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10816      &          vtemp1d(1))
10817             s2d = scalar2(b1(1,k),vtemp1d(1))
10818 #ifdef MOMENT
10819             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10820             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10821             s8d = -(atempd(1,1)+atempd(2,2))*
10822      &           scalar2(cc(1,1,itl),vtemp2(1))
10823 #endif
10824             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10825      &           auxmatd(1,1))
10826             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10827             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10828 c      s1d=0.0d0
10829 c      s2d=0.0d0
10830 c      s8d=0.0d0
10831 c      s12d=0.0d0
10832 c      s13d=0.0d0
10833 #ifdef MOMENT
10834             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10835      &        - 0.5d0*(s1d+s2d)
10836 #else
10837             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10838      &        - 0.5d0*s2d
10839 #endif
10840 #ifdef MOMENT
10841             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10842      &        - 0.5d0*(s8d+s12d)
10843 #else
10844             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10845      &        - 0.5d0*s12d
10846 #endif
10847           enddo
10848         enddo
10849       enddo
10850 #ifdef MOMENT
10851       do kkk=1,5
10852         do lll=1,3
10853           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10854      &      achuj_tempd(1,1))
10855           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10856           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10857           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10858           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10859           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10860      &      vtemp4d(1))
10861           ss13d = scalar2(b1(1,k),vtemp4d(1))
10862           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10863           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10864         enddo
10865       enddo
10866 #endif
10867 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10868 cd     &  16*eel_turn6_num
10869 cd      goto 1112
10870       if (j.lt.nres-1) then
10871         j1=j+1
10872         j2=j-1
10873       else
10874         j1=j-1
10875         j2=j-2
10876       endif
10877       if (l.lt.nres-1) then
10878         l1=l+1
10879         l2=l-1
10880       else
10881         l1=l-1
10882         l2=l-2
10883       endif
10884       do ll=1,3
10885 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10886 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10887 cgrad        ghalf=0.5d0*ggg1(ll)
10888 cd        ghalf=0.0d0
10889         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10890         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10891         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10892      &    +ekont*derx_turn(ll,2,1)
10893         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10894         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10895      &    +ekont*derx_turn(ll,4,1)
10896         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10897         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10898         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10899 cgrad        ghalf=0.5d0*ggg2(ll)
10900 cd        ghalf=0.0d0
10901         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10902      &    +ekont*derx_turn(ll,2,2)
10903         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10904         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10905      &    +ekont*derx_turn(ll,4,2)
10906         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10907         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10908         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10909       enddo
10910 cd      goto 1112
10911 cgrad      do m=i+1,j-1
10912 cgrad        do ll=1,3
10913 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10914 cgrad        enddo
10915 cgrad      enddo
10916 cgrad      do m=k+1,l-1
10917 cgrad        do ll=1,3
10918 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10919 cgrad        enddo
10920 cgrad      enddo
10921 cgrad1112  continue
10922 cgrad      do m=i+2,j2
10923 cgrad        do ll=1,3
10924 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10925 cgrad        enddo
10926 cgrad      enddo
10927 cgrad      do m=k+2,l2
10928 cgrad        do ll=1,3
10929 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10930 cgrad        enddo
10931 cgrad      enddo
10932 cd      do iii=1,nres-3
10933 cd        write (2,*) iii,g_corr6_loc(iii)
10934 cd      enddo
10935       eello_turn6=ekont*eel_turn6
10936 cd      write (2,*) 'ekont',ekont
10937 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10938       return
10939       end
10940
10941 C-----------------------------------------------------------------------------
10942       double precision function scalar(u,v)
10943 !DIR$ INLINEALWAYS scalar
10944 #ifndef OSF
10945 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10946 #endif
10947       implicit none
10948       double precision u(3),v(3)
10949 cd      double precision sc
10950 cd      integer i
10951 cd      sc=0.0d0
10952 cd      do i=1,3
10953 cd        sc=sc+u(i)*v(i)
10954 cd      enddo
10955 cd      scalar=sc
10956
10957       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10958       return
10959       end
10960 crc-------------------------------------------------
10961       SUBROUTINE MATVEC2(A1,V1,V2)
10962 !DIR$ INLINEALWAYS MATVEC2
10963 #ifndef OSF
10964 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10965 #endif
10966       implicit real*8 (a-h,o-z)
10967       include 'DIMENSIONS'
10968       DIMENSION A1(2,2),V1(2),V2(2)
10969 c      DO 1 I=1,2
10970 c        VI=0.0
10971 c        DO 3 K=1,2
10972 c    3     VI=VI+A1(I,K)*V1(K)
10973 c        Vaux(I)=VI
10974 c    1 CONTINUE
10975
10976       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10977       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10978
10979       v2(1)=vaux1
10980       v2(2)=vaux2
10981       END
10982 C---------------------------------------
10983       SUBROUTINE MATMAT2(A1,A2,A3)
10984 #ifndef OSF
10985 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10986 #endif
10987       implicit real*8 (a-h,o-z)
10988       include 'DIMENSIONS'
10989       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10990 c      DIMENSION AI3(2,2)
10991 c        DO  J=1,2
10992 c          A3IJ=0.0
10993 c          DO K=1,2
10994 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10995 c          enddo
10996 c          A3(I,J)=A3IJ
10997 c       enddo
10998 c      enddo
10999
11000       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11001       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11002       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11003       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11004
11005       A3(1,1)=AI3_11
11006       A3(2,1)=AI3_21
11007       A3(1,2)=AI3_12
11008       A3(2,2)=AI3_22
11009       END
11010
11011 c-------------------------------------------------------------------------
11012       double precision function scalar2(u,v)
11013 !DIR$ INLINEALWAYS scalar2
11014       implicit none
11015       double precision u(2),v(2)
11016       double precision sc
11017       integer i
11018       scalar2=u(1)*v(1)+u(2)*v(2)
11019       return
11020       end
11021
11022 C-----------------------------------------------------------------------------
11023
11024       subroutine transpose2(a,at)
11025 !DIR$ INLINEALWAYS transpose2
11026 #ifndef OSF
11027 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11028 #endif
11029       implicit none
11030       double precision a(2,2),at(2,2)
11031       at(1,1)=a(1,1)
11032       at(1,2)=a(2,1)
11033       at(2,1)=a(1,2)
11034       at(2,2)=a(2,2)
11035       return
11036       end
11037 c--------------------------------------------------------------------------
11038       subroutine transpose(n,a,at)
11039       implicit none
11040       integer n,i,j
11041       double precision a(n,n),at(n,n)
11042       do i=1,n
11043         do j=1,n
11044           at(j,i)=a(i,j)
11045         enddo
11046       enddo
11047       return
11048       end
11049 C---------------------------------------------------------------------------
11050       subroutine prodmat3(a1,a2,kk,transp,prod)
11051 !DIR$ INLINEALWAYS prodmat3
11052 #ifndef OSF
11053 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11054 #endif
11055       implicit none
11056       integer i,j
11057       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11058       logical transp
11059 crc      double precision auxmat(2,2),prod_(2,2)
11060
11061       if (transp) then
11062 crc        call transpose2(kk(1,1),auxmat(1,1))
11063 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11064 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11065
11066            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11067      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11068            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11069      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11070            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11071      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11072            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11073      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11074
11075       else
11076 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11077 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11078
11079            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11080      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11081            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11082      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11083            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11084      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11085            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11086      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11087
11088       endif
11089 c      call transpose2(a2(1,1),a2t(1,1))
11090
11091 crc      print *,transp
11092 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11093 crc      print *,((prod(i,j),i=1,2),j=1,2)
11094
11095       return
11096       end
11097 CCC----------------------------------------------
11098       subroutine Eliptransfer(eliptran)
11099       implicit real*8 (a-h,o-z)
11100       include 'DIMENSIONS'
11101       include 'COMMON.GEO'
11102       include 'COMMON.VAR'
11103       include 'COMMON.LOCAL'
11104       include 'COMMON.CHAIN'
11105       include 'COMMON.DERIV'
11106       include 'COMMON.NAMES'
11107       include 'COMMON.INTERACT'
11108       include 'COMMON.IOUNITS'
11109       include 'COMMON.CALC'
11110       include 'COMMON.CONTROL'
11111       include 'COMMON.SPLITELE'
11112       include 'COMMON.SBRIDGE'
11113 C this is done by Adasko
11114 C      print *,"wchodze"
11115 C structure of box:
11116 C      water
11117 C--bordliptop-- buffore starts
11118 C--bufliptop--- here true lipid starts
11119 C      lipid
11120 C--buflipbot--- lipid ends buffore starts
11121 C--bordlipbot--buffore ends
11122       eliptran=0.0
11123       do i=ilip_start,ilip_end
11124 C       do i=1,1
11125         if (itype(i).eq.ntyp1) cycle
11126
11127         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11128         if (positi.le.0.0) positi=positi+boxzsize
11129 C        print *,i
11130 C first for peptide groups
11131 c for each residue check if it is in lipid or lipid water border area
11132        if ((positi.gt.bordlipbot)
11133      &.and.(positi.lt.bordliptop)) then
11134 C the energy transfer exist
11135         if (positi.lt.buflipbot) then
11136 C what fraction I am in
11137          fracinbuf=1.0d0-
11138      &        ((positi-bordlipbot)/lipbufthick)
11139 C lipbufthick is thickenes of lipid buffore
11140          sslip=sscalelip(fracinbuf)
11141          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11142          eliptran=eliptran+sslip*pepliptran
11143          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11144          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11145 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11146
11147 C        print *,"doing sccale for lower part"
11148 C         print *,i,sslip,fracinbuf,ssgradlip
11149         elseif (positi.gt.bufliptop) then
11150          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11151          sslip=sscalelip(fracinbuf)
11152          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11153          eliptran=eliptran+sslip*pepliptran
11154          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11155          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11156 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11157 C          print *, "doing sscalefor top part"
11158 C         print *,i,sslip,fracinbuf,ssgradlip
11159         else
11160          eliptran=eliptran+pepliptran
11161 C         print *,"I am in true lipid"
11162         endif
11163 C       else
11164 C       eliptran=elpitran+0.0 ! I am in water
11165        endif
11166        enddo
11167 C       print *, "nic nie bylo w lipidzie?"
11168 C now multiply all by the peptide group transfer factor
11169 C       eliptran=eliptran*pepliptran
11170 C now the same for side chains
11171 CV       do i=1,1
11172        do i=ilip_start,ilip_end
11173         if (itype(i).eq.ntyp1) cycle
11174         positi=(mod(c(3,i+nres),boxzsize))
11175         if (positi.le.0) positi=positi+boxzsize
11176 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11177 c for each residue check if it is in lipid or lipid water border area
11178 C       respos=mod(c(3,i+nres),boxzsize)
11179 C       print *,positi,bordlipbot,buflipbot
11180        if ((positi.gt.bordlipbot)
11181      & .and.(positi.lt.bordliptop)) then
11182 C the energy transfer exist
11183         if (positi.lt.buflipbot) then
11184          fracinbuf=1.0d0-
11185      &     ((positi-bordlipbot)/lipbufthick)
11186 C lipbufthick is thickenes of lipid buffore
11187          sslip=sscalelip(fracinbuf)
11188          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11189          eliptran=eliptran+sslip*liptranene(itype(i))
11190          gliptranx(3,i)=gliptranx(3,i)
11191      &+ssgradlip*liptranene(itype(i))
11192          gliptranc(3,i-1)= gliptranc(3,i-1)
11193      &+ssgradlip*liptranene(itype(i))
11194 C         print *,"doing sccale for lower part"
11195         elseif (positi.gt.bufliptop) then
11196          fracinbuf=1.0d0-
11197      &((bordliptop-positi)/lipbufthick)
11198          sslip=sscalelip(fracinbuf)
11199          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11200          eliptran=eliptran+sslip*liptranene(itype(i))
11201          gliptranx(3,i)=gliptranx(3,i)
11202      &+ssgradlip*liptranene(itype(i))
11203          gliptranc(3,i-1)= gliptranc(3,i-1)
11204      &+ssgradlip*liptranene(itype(i))
11205 C          print *, "doing sscalefor top part",sslip,fracinbuf
11206         else
11207          eliptran=eliptran+liptranene(itype(i))
11208 C         print *,"I am in true lipid"
11209         endif
11210         endif ! if in lipid or buffor
11211 C       else
11212 C       eliptran=elpitran+0.0 ! I am in water
11213        enddo
11214        return
11215        end
11216 C---------------------------------------------------------
11217 C AFM soubroutine for constant force
11218        subroutine AFMforce(Eafmforce)
11219        implicit real*8 (a-h,o-z)
11220       include 'DIMENSIONS'
11221       include 'COMMON.GEO'
11222       include 'COMMON.VAR'
11223       include 'COMMON.LOCAL'
11224       include 'COMMON.CHAIN'
11225       include 'COMMON.DERIV'
11226       include 'COMMON.NAMES'
11227       include 'COMMON.INTERACT'
11228       include 'COMMON.IOUNITS'
11229       include 'COMMON.CALC'
11230       include 'COMMON.CONTROL'
11231       include 'COMMON.SPLITELE'
11232       include 'COMMON.SBRIDGE'
11233       real*8 diffafm(3)
11234       dist=0.0d0
11235       Eafmforce=0.0d0
11236       do i=1,3
11237       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11238       dist=dist+diffafm(i)**2
11239       enddo
11240       dist=dsqrt(dist)
11241       Eafmforce=-forceAFMconst*(dist-distafminit)
11242       do i=1,3
11243       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11244       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11245       enddo
11246 C      print *,'AFM',Eafmforce
11247       return
11248       end
11249 C---------------------------------------------------------
11250 C AFM subroutine with pseudoconstant velocity
11251        subroutine AFMvel(Eafmforce)
11252        implicit real*8 (a-h,o-z)
11253       include 'DIMENSIONS'
11254       include 'COMMON.GEO'
11255       include 'COMMON.VAR'
11256       include 'COMMON.LOCAL'
11257       include 'COMMON.CHAIN'
11258       include 'COMMON.DERIV'
11259       include 'COMMON.NAMES'
11260       include 'COMMON.INTERACT'
11261       include 'COMMON.IOUNITS'
11262       include 'COMMON.CALC'
11263       include 'COMMON.CONTROL'
11264       include 'COMMON.SPLITELE'
11265       include 'COMMON.SBRIDGE'
11266       real*8 diffafm(3)
11267 C Only for check grad COMMENT if not used for checkgrad
11268 C      totT=3.0d0
11269 C--------------------------------------------------------
11270 C      print *,"wchodze"
11271       dist=0.0d0
11272       Eafmforce=0.0d0
11273       do i=1,3
11274       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11275       dist=dist+diffafm(i)**2
11276       enddo
11277       dist=dsqrt(dist)
11278       Eafmforce=0.5d0*forceAFMconst
11279      & *(distafminit+totTafm*velAFMconst-dist)**2
11280 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11281       do i=1,3
11282       gradafm(i,afmend-1)=-forceAFMconst*
11283      &(distafminit+totTafm*velAFMconst-dist)
11284      &*diffafm(i)/dist
11285       gradafm(i,afmbeg-1)=forceAFMconst*
11286      &(distafminit+totTafm*velAFMconst-dist)
11287      &*diffafm(i)/dist
11288       enddo
11289 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11290       return
11291       end
11292 C-----------------------------------------------------------
11293 C first for shielding is setting of function of side-chains
11294        subroutine set_shield_fac
11295       implicit real*8 (a-h,o-z)
11296       include 'DIMENSIONS'
11297       include 'COMMON.CHAIN'
11298       include 'COMMON.DERIV'
11299       include 'COMMON.IOUNITS'
11300       include 'COMMON.SHIELD'
11301       include 'COMMON.INTERACT'
11302 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11303       double precision div77_81/0.974996043d0/,
11304      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11305
11306 C the vector between center of side_chain and peptide group
11307        double precision pep_side(3),long,side_calf(3),
11308      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11309      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11310 C the line belowe needs to be changed for FGPROC>1
11311       do i=1,nres-1
11312       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11313       ishield_list(i)=0
11314 Cif there two consequtive dummy atoms there is no peptide group between them
11315 C the line below has to be changed for FGPROC>1
11316       VolumeTotal=0.0
11317       do k=1,nres
11318        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11319        dist_pep_side=0.0
11320        dist_side_calf=0.0
11321        do j=1,3
11322 C first lets set vector conecting the ithe side-chain with kth side-chain
11323       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11324 C      pep_side(j)=2.0d0
11325 C and vector conecting the side-chain with its proper calfa
11326       side_calf(j)=c(j,k+nres)-c(j,k)
11327 C      side_calf(j)=2.0d0
11328       pept_group(j)=c(j,i)-c(j,i+1)
11329 C lets have their lenght
11330       dist_pep_side=pep_side(j)**2+dist_pep_side
11331       dist_side_calf=dist_side_calf+side_calf(j)**2
11332       dist_pept_group=dist_pept_group+pept_group(j)**2
11333       enddo
11334        dist_pep_side=dsqrt(dist_pep_side)
11335        dist_pept_group=dsqrt(dist_pept_group)
11336        dist_side_calf=dsqrt(dist_side_calf)
11337       do j=1,3
11338         pep_side_norm(j)=pep_side(j)/dist_pep_side
11339         side_calf_norm(j)=dist_side_calf
11340       enddo
11341 C now sscale fraction
11342        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11343 C       print *,buff_shield,"buff"
11344 C now sscale
11345         if (sh_frac_dist.le.0.0) cycle
11346 C If we reach here it means that this side chain reaches the shielding sphere
11347 C Lets add him to the list for gradient
11348         ishield_list(i)=ishield_list(i)+1
11349 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11350 C this list is essential otherwise problem would be O3
11351         shield_list(ishield_list(i),i)=k
11352 C Lets have the sscale value
11353         if (sh_frac_dist.gt.1.0) then
11354          scale_fac_dist=1.0d0
11355          do j=1,3
11356          sh_frac_dist_grad(j)=0.0d0
11357          enddo
11358         else
11359          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11360      &                   *(2.0*sh_frac_dist-3.0d0)
11361          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11362      &                  /dist_pep_side/buff_shield*0.5
11363 C remember for the final gradient multiply sh_frac_dist_grad(j)
11364 C for side_chain by factor -2 !
11365          do j=1,3
11366          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11367 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11368 C     &                    sh_frac_dist_grad(j)
11369          enddo
11370         endif
11371 C        if ((i.eq.3).and.(k.eq.2)) then
11372 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11373 C     & ,"TU"
11374 C        endif
11375
11376 C this is what is now we have the distance scaling now volume...
11377       short=short_r_sidechain(itype(k))
11378       long=long_r_sidechain(itype(k))
11379       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11380 C now costhet_grad
11381 C       costhet=0.0d0
11382        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11383 C       costhet_fac=0.0d0
11384        do j=1,3
11385          costhet_grad(j)=costhet_fac*pep_side(j)
11386        enddo
11387 C remember for the final gradient multiply costhet_grad(j)
11388 C for side_chain by factor -2 !
11389 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11390 C pep_side0pept_group is vector multiplication
11391       pep_side0pept_group=0.0
11392       do j=1,3
11393       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11394       enddo
11395       cosalfa=(pep_side0pept_group/
11396      & (dist_pep_side*dist_side_calf))
11397       fac_alfa_sin=1.0-cosalfa**2
11398       fac_alfa_sin=dsqrt(fac_alfa_sin)
11399       rkprim=fac_alfa_sin*(long-short)+short
11400 C now costhet_grad
11401        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11402        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11403
11404        do j=1,3
11405          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11406      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11407      &*(long-short)/fac_alfa_sin*cosalfa/
11408      &((dist_pep_side*dist_side_calf))*
11409      &((side_calf(j))-cosalfa*
11410      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11411
11412         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11413      &*(long-short)/fac_alfa_sin*cosalfa
11414      &/((dist_pep_side*dist_side_calf))*
11415      &(pep_side(j)-
11416      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11417        enddo
11418
11419       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11420      &                    /VSolvSphere_div
11421      &                    *wshield
11422 C now the gradient...
11423 C grad_shield is gradient of Calfa for peptide groups
11424 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11425 C     &               costhet,cosphi
11426 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11427 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11428       do j=1,3
11429       grad_shield(j,i)=grad_shield(j,i)
11430 C gradient po skalowaniu
11431      &                +(sh_frac_dist_grad(j)
11432 C  gradient po costhet
11433      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11434      &-scale_fac_dist*(cosphi_grad_long(j))
11435      &/(1.0-cosphi) )*div77_81
11436      &*VofOverlap
11437 C grad_shield_side is Cbeta sidechain gradient
11438       grad_shield_side(j,ishield_list(i),i)=
11439      &        (sh_frac_dist_grad(j)*-2.0d0
11440      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11441      &       +scale_fac_dist*(cosphi_grad_long(j))
11442      &        *2.0d0/(1.0-cosphi))
11443      &        *div77_81*VofOverlap
11444
11445        grad_shield_loc(j,ishield_list(i),i)=
11446      &   scale_fac_dist*cosphi_grad_loc(j)
11447      &        *2.0d0/(1.0-cosphi)
11448      &        *div77_81*VofOverlap
11449       enddo
11450       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11451       enddo
11452       fac_shield(i)=VolumeTotal*div77_81+div4_81
11453 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11454       enddo
11455       return
11456       end
11457 C--------------------------------------------------------------------------
11458       double precision function tschebyshev(m,n,x,y)
11459       implicit none
11460       include "DIMENSIONS"
11461       integer i,m,n
11462       double precision x(n),y,yy(0:maxvar),aux
11463 c Tschebyshev polynomial. Note that the first term is omitted
11464 c m=0: the constant term is included
11465 c m=1: the constant term is not included
11466       yy(0)=1.0d0
11467       yy(1)=y
11468       do i=2,n
11469         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11470       enddo
11471       aux=0.0d0
11472       do i=m,n
11473         aux=aux+x(i)*yy(i)
11474       enddo
11475       tschebyshev=aux
11476       return
11477       end
11478 C--------------------------------------------------------------------------
11479       double precision function gradtschebyshev(m,n,x,y)
11480       implicit none
11481       include "DIMENSIONS"
11482       integer i,m,n
11483       double precision x(n+1),y,yy(0:maxvar),aux
11484 c Tschebyshev polynomial. Note that the first term is omitted
11485 c m=0: the constant term is included
11486 c m=1: the constant term is not included
11487       yy(0)=1.0d0
11488       yy(1)=2.0d0*y
11489       do i=2,n
11490         yy(i)=2*y*yy(i-1)-yy(i-2)
11491       enddo
11492       aux=0.0d0
11493       do i=m,n
11494         aux=aux+x(i+1)*yy(i)*(i+1)
11495 C        print *, x(i+1),yy(i),i
11496       enddo
11497       gradtschebyshev=aux
11498       return
11499       end
11500 C------------------------------------------------------------------------
11501 C first for shielding is setting of function of side-chains
11502        subroutine set_shield_fac2
11503       implicit real*8 (a-h,o-z)
11504       include 'DIMENSIONS'
11505       include 'COMMON.CHAIN'
11506       include 'COMMON.DERIV'
11507       include 'COMMON.IOUNITS'
11508       include 'COMMON.SHIELD'
11509       include 'COMMON.INTERACT'
11510 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11511       double precision div77_81/0.974996043d0/,
11512      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11513
11514 C the vector between center of side_chain and peptide group
11515        double precision pep_side(3),long,side_calf(3),
11516      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11517      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11518 C the line belowe needs to be changed for FGPROC>1
11519       do i=1,nres-1
11520       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11521       ishield_list(i)=0
11522 Cif there two consequtive dummy atoms there is no peptide group between them
11523 C the line below has to be changed for FGPROC>1
11524       VolumeTotal=0.0
11525       do k=1,nres
11526        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11527        dist_pep_side=0.0
11528        dist_side_calf=0.0
11529        do j=1,3
11530 C first lets set vector conecting the ithe side-chain with kth side-chain
11531       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11532 C      pep_side(j)=2.0d0
11533 C and vector conecting the side-chain with its proper calfa
11534       side_calf(j)=c(j,k+nres)-c(j,k)
11535 C      side_calf(j)=2.0d0
11536       pept_group(j)=c(j,i)-c(j,i+1)
11537 C lets have their lenght
11538       dist_pep_side=pep_side(j)**2+dist_pep_side
11539       dist_side_calf=dist_side_calf+side_calf(j)**2
11540       dist_pept_group=dist_pept_group+pept_group(j)**2
11541       enddo
11542        dist_pep_side=dsqrt(dist_pep_side)
11543        dist_pept_group=dsqrt(dist_pept_group)
11544        dist_side_calf=dsqrt(dist_side_calf)
11545       do j=1,3
11546         pep_side_norm(j)=pep_side(j)/dist_pep_side
11547         side_calf_norm(j)=dist_side_calf
11548       enddo
11549 C now sscale fraction
11550        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11551 C       print *,buff_shield,"buff"
11552 C now sscale
11553         if (sh_frac_dist.le.0.0) cycle
11554 C If we reach here it means that this side chain reaches the shielding sphere
11555 C Lets add him to the list for gradient
11556         ishield_list(i)=ishield_list(i)+1
11557 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11558 C this list is essential otherwise problem would be O3
11559         shield_list(ishield_list(i),i)=k
11560 C Lets have the sscale value
11561         if (sh_frac_dist.gt.1.0) then
11562          scale_fac_dist=1.0d0
11563          do j=1,3
11564          sh_frac_dist_grad(j)=0.0d0
11565          enddo
11566         else
11567          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11568      &                   *(2.0d0*sh_frac_dist-3.0d0)
11569          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11570      &                  /dist_pep_side/buff_shield*0.5d0
11571 C remember for the final gradient multiply sh_frac_dist_grad(j)
11572 C for side_chain by factor -2 !
11573          do j=1,3
11574          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11575 C         sh_frac_dist_grad(j)=0.0d0
11576 C         scale_fac_dist=1.0d0
11577 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11578 C     &                    sh_frac_dist_grad(j)
11579          enddo
11580         endif
11581 C this is what is now we have the distance scaling now volume...
11582       short=short_r_sidechain(itype(k))
11583       long=long_r_sidechain(itype(k))
11584       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11585       sinthet=short/dist_pep_side*costhet
11586 C now costhet_grad
11587 C       costhet=0.6d0
11588 C       sinthet=0.8
11589        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11590 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11591 C     &             -short/dist_pep_side**2/costhet)
11592 C       costhet_fac=0.0d0
11593        do j=1,3
11594          costhet_grad(j)=costhet_fac*pep_side(j)
11595        enddo
11596 C remember for the final gradient multiply costhet_grad(j)
11597 C for side_chain by factor -2 !
11598 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11599 C pep_side0pept_group is vector multiplication
11600       pep_side0pept_group=0.0d0
11601       do j=1,3
11602       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11603       enddo
11604       cosalfa=(pep_side0pept_group/
11605      & (dist_pep_side*dist_side_calf))
11606       fac_alfa_sin=1.0d0-cosalfa**2
11607       fac_alfa_sin=dsqrt(fac_alfa_sin)
11608       rkprim=fac_alfa_sin*(long-short)+short
11609 C      rkprim=short
11610
11611 C now costhet_grad
11612        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11613 C       cosphi=0.6
11614        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11615        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11616      &      dist_pep_side**2)
11617 C       sinphi=0.8
11618        do j=1,3
11619          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11620      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11621      &*(long-short)/fac_alfa_sin*cosalfa/
11622      &((dist_pep_side*dist_side_calf))*
11623      &((side_calf(j))-cosalfa*
11624      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11625 C       cosphi_grad_long(j)=0.0d0
11626         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11627      &*(long-short)/fac_alfa_sin*cosalfa
11628      &/((dist_pep_side*dist_side_calf))*
11629      &(pep_side(j)-
11630      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11631 C       cosphi_grad_loc(j)=0.0d0
11632        enddo
11633 C      print *,sinphi,sinthet
11634       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11635      &                    /VSolvSphere_div
11636 C     &                    *wshield
11637 C now the gradient...
11638       do j=1,3
11639       grad_shield(j,i)=grad_shield(j,i)
11640 C gradient po skalowaniu
11641      &                +(sh_frac_dist_grad(j)*VofOverlap
11642 C  gradient po costhet
11643      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11644      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11645      &       sinphi/sinthet*costhet*costhet_grad(j)
11646      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11647      & )*wshield
11648 C grad_shield_side is Cbeta sidechain gradient
11649       grad_shield_side(j,ishield_list(i),i)=
11650      &        (sh_frac_dist_grad(j)*-2.0d0
11651      &        *VofOverlap
11652      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11653      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11654      &       sinphi/sinthet*costhet*costhet_grad(j)
11655      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11656      &       )*wshield
11657
11658        grad_shield_loc(j,ishield_list(i),i)=
11659      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11660      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11661      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11662      &        ))
11663      &        *wshield
11664       enddo
11665       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11666       enddo
11667       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11668 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11669       enddo
11670       return
11671       end
11672