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.le.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 c          time00=MPI_Wtime()
3665 cd      write (iout,*) "eelecij",i,j
3666 c          ind=ind+1
3667           iteli=itel(i)
3668           itelj=itel(j)
3669           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3670           aaa=app(iteli,itelj)
3671           bbb=bpp(iteli,itelj)
3672           ael6i=ael6(iteli,itelj)
3673           ael3i=ael3(iteli,itelj)
3674           dxj=dc(1,j)
3675           dyj=dc(2,j)
3676           dzj=dc(3,j)
3677           dx_normj=dc_norm(1,j)
3678           dy_normj=dc_norm(2,j)
3679           dz_normj=dc_norm(3,j)
3680 C          xj=c(1,j)+0.5D0*dxj-xmedi
3681 C          yj=c(2,j)+0.5D0*dyj-ymedi
3682 C          zj=c(3,j)+0.5D0*dzj-zmedi
3683           xj=c(1,j)+0.5D0*dxj
3684           yj=c(2,j)+0.5D0*dyj
3685           zj=c(3,j)+0.5D0*dzj
3686           xj=mod(xj,boxxsize)
3687           if (xj.lt.0) xj=xj+boxxsize
3688           yj=mod(yj,boxysize)
3689           if (yj.lt.0) yj=yj+boxysize
3690           zj=mod(zj,boxzsize)
3691           if (zj.lt.0) zj=zj+boxzsize
3692           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3693       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3694       xj_safe=xj
3695       yj_safe=yj
3696       zj_safe=zj
3697       isubchap=0
3698       do xshift=-1,1
3699       do yshift=-1,1
3700       do zshift=-1,1
3701           xj=xj_safe+xshift*boxxsize
3702           yj=yj_safe+yshift*boxysize
3703           zj=zj_safe+zshift*boxzsize
3704           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3705           if(dist_temp.lt.dist_init) then
3706             dist_init=dist_temp
3707             xj_temp=xj
3708             yj_temp=yj
3709             zj_temp=zj
3710             isubchap=1
3711           endif
3712        enddo
3713        enddo
3714        enddo
3715        if (isubchap.eq.1) then
3716           xj=xj_temp-xmedi
3717           yj=yj_temp-ymedi
3718           zj=zj_temp-zmedi
3719        else
3720           xj=xj_safe-xmedi
3721           yj=yj_safe-ymedi
3722           zj=zj_safe-zmedi
3723        endif
3724 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3725 c  174   continue
3726 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3727 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3728 C Condition for being inside the proper box
3729 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3730 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3731 c        go to 174
3732 c        endif
3733 c  175   continue
3734 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3735 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3736 C Condition for being inside the proper box
3737 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3738 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3739 c        go to 175
3740 c        endif
3741 c  176   continue
3742 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3743 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3744 C Condition for being inside the proper box
3745 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3746 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3747 c        go to 176
3748 c        endif
3749 C        endif !endPBC condintion
3750 C        xj=xj-xmedi
3751 C        yj=yj-ymedi
3752 C        zj=zj-zmedi
3753           rij=xj*xj+yj*yj+zj*zj
3754
3755             sss=sscale(sqrt(rij))
3756             sssgrad=sscagrad(sqrt(rij))
3757 c            if (sss.gt.0.0d0) then
3758           rrmij=1.0D0/rij
3759           rij=dsqrt(rij)
3760           rmij=1.0D0/rij
3761           r3ij=rrmij*rmij
3762           r6ij=r3ij*r3ij
3763           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3764           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3765           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3766           fac=cosa-3.0D0*cosb*cosg
3767           ev1=aaa*r6ij*r6ij
3768 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3769           if (j.eq.i+2) ev1=scal_el*ev1
3770           ev2=bbb*r6ij
3771           fac3=ael6i*r6ij
3772           fac4=ael3i*r3ij
3773           evdwij=(ev1+ev2)
3774           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3775           el2=fac4*fac
3776 C MARYSIA
3777 C          eesij=(el1+el2)
3778 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3779           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3780           if (shield_mode.gt.0) then
3781 C          fac_shield(i)=0.4
3782 C          fac_shield(j)=0.6
3783           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3784           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3785           eesij=(el1+el2)
3786           ees=ees+eesij
3787           else
3788           fac_shield(i)=1.0
3789           fac_shield(j)=1.0
3790           eesij=(el1+el2)
3791           ees=ees+eesij
3792           endif
3793           evdw1=evdw1+evdwij*sss
3794 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3795 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3796 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3797 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3798
3799           if (energy_dec) then
3800               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3801      &'evdw1',i,j,evdwij
3802      &,iteli,itelj,aaa,evdw1
3803               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3804      &fac_shield(i),fac_shield(j)
3805           endif
3806
3807 C
3808 C Calculate contributions to the Cartesian gradient.
3809 C
3810 #ifdef SPLITELE
3811           facvdw=-6*rrmij*(ev1+evdwij)*sss
3812           facel=-3*rrmij*(el1+eesij)
3813           fac1=fac
3814           erij(1)=xj*rmij
3815           erij(2)=yj*rmij
3816           erij(3)=zj*rmij
3817
3818 *
3819 * Radial derivatives. First process both termini of the fragment (i,j)
3820 *
3821           ggg(1)=facel*xj
3822           ggg(2)=facel*yj
3823           ggg(3)=facel*zj
3824           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3825      &  (shield_mode.gt.0)) then
3826 C          print *,i,j
3827           do ilist=1,ishield_list(i)
3828            iresshield=shield_list(ilist,i)
3829            do k=1,3
3830            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3831      &      *2.0
3832            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3833      &              rlocshield
3834      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3835             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3836 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3837 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3838 C             if (iresshield.gt.i) then
3839 C               do ishi=i+1,iresshield-1
3840 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3841 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3842 C
3843 C              enddo
3844 C             else
3845 C               do ishi=iresshield,i
3846 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3847 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3848 C
3849 C               enddo
3850 C              endif
3851            enddo
3852           enddo
3853           do ilist=1,ishield_list(j)
3854            iresshield=shield_list(ilist,j)
3855            do k=1,3
3856            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3857      &     *2.0
3858            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3859      &              rlocshield
3860      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3861            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3862
3863 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3864 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3865 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3866 C             if (iresshield.gt.j) then
3867 C               do ishi=j+1,iresshield-1
3868 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3869 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3870 C
3871 C               enddo
3872 C            else
3873 C               do ishi=iresshield,j
3874 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3875 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3876 C               enddo
3877 C              endif
3878            enddo
3879           enddo
3880
3881           do k=1,3
3882             gshieldc(k,i)=gshieldc(k,i)+
3883      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3884             gshieldc(k,j)=gshieldc(k,j)+
3885      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3886             gshieldc(k,i-1)=gshieldc(k,i-1)+
3887      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3888             gshieldc(k,j-1)=gshieldc(k,j-1)+
3889      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3890
3891            enddo
3892            endif
3893 c          do k=1,3
3894 c            ghalf=0.5D0*ggg(k)
3895 c            gelc(k,i)=gelc(k,i)+ghalf
3896 c            gelc(k,j)=gelc(k,j)+ghalf
3897 c          enddo
3898 c 9/28/08 AL Gradient compotents will be summed only at the end
3899 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3900           do k=1,3
3901             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3902 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3903             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3904 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3905 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3906 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3907 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3908 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3909           enddo
3910 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3911
3912 *
3913 * Loop over residues i+1 thru j-1.
3914 *
3915 cgrad          do k=i+1,j-1
3916 cgrad            do l=1,3
3917 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3918 cgrad            enddo
3919 cgrad          enddo
3920           if (sss.gt.0.0) then
3921           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3922           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3923           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3924           else
3925           ggg(1)=0.0
3926           ggg(2)=0.0
3927           ggg(3)=0.0
3928           endif
3929 c          do k=1,3
3930 c            ghalf=0.5D0*ggg(k)
3931 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3932 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3933 c          enddo
3934 c 9/28/08 AL Gradient compotents will be summed only at the end
3935           do k=1,3
3936             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3937             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3938           enddo
3939 *
3940 * Loop over residues i+1 thru j-1.
3941 *
3942 cgrad          do k=i+1,j-1
3943 cgrad            do l=1,3
3944 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3945 cgrad            enddo
3946 cgrad          enddo
3947 #else
3948 C MARYSIA
3949           facvdw=(ev1+evdwij)*sss
3950           facel=(el1+eesij)
3951           fac1=fac
3952           fac=-3*rrmij*(facvdw+facvdw+facel)
3953           erij(1)=xj*rmij
3954           erij(2)=yj*rmij
3955           erij(3)=zj*rmij
3956 *
3957 * Radial derivatives. First process both termini of the fragment (i,j)
3958 *
3959           ggg(1)=fac*xj
3960 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3961           ggg(2)=fac*yj
3962 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3963           ggg(3)=fac*zj
3964 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3965 c          do k=1,3
3966 c            ghalf=0.5D0*ggg(k)
3967 c            gelc(k,i)=gelc(k,i)+ghalf
3968 c            gelc(k,j)=gelc(k,j)+ghalf
3969 c          enddo
3970 c 9/28/08 AL Gradient compotents will be summed only at the end
3971           do k=1,3
3972             gelc_long(k,j)=gelc(k,j)+ggg(k)
3973             gelc_long(k,i)=gelc(k,i)-ggg(k)
3974           enddo
3975 *
3976 * Loop over residues i+1 thru j-1.
3977 *
3978 cgrad          do k=i+1,j-1
3979 cgrad            do l=1,3
3980 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3981 cgrad            enddo
3982 cgrad          enddo
3983 c 9/28/08 AL Gradient compotents will be summed only at the end
3984           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3985           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3986           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3987           do k=1,3
3988             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3989             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3990           enddo
3991 #endif
3992 *
3993 * Angular part
3994 *
3995           ecosa=2.0D0*fac3*fac1+fac4
3996           fac4=-3.0D0*fac4
3997           fac3=-6.0D0*fac3
3998           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3999           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4000           do k=1,3
4001             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4002             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4003           enddo
4004 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4005 cd   &          (dcosg(k),k=1,3)
4006           do k=1,3
4007             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4008      &      fac_shield(i)**2*fac_shield(j)**2
4009           enddo
4010 c          do k=1,3
4011 c            ghalf=0.5D0*ggg(k)
4012 c            gelc(k,i)=gelc(k,i)+ghalf
4013 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4014 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4015 c            gelc(k,j)=gelc(k,j)+ghalf
4016 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4017 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4018 c          enddo
4019 cgrad          do k=i+1,j-1
4020 cgrad            do l=1,3
4021 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4022 cgrad            enddo
4023 cgrad          enddo
4024 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4025           do k=1,3
4026             gelc(k,i)=gelc(k,i)
4027      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4028      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4029      &           *fac_shield(i)**2*fac_shield(j)**2
4030             gelc(k,j)=gelc(k,j)
4031      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4032      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4033      &           *fac_shield(i)**2*fac_shield(j)**2
4034             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4035             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4036           enddo
4037 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4038
4039 C MARYSIA
4040 c          endif !sscale
4041           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4042      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4043      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4044 C
4045 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4046 C   energy of a peptide unit is assumed in the form of a second-order
4047 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4048 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4049 C   are computed for EVERY pair of non-contiguous peptide groups.
4050 C
4051
4052           if (j.lt.nres-1) then
4053             j1=j+1
4054             j2=j-1
4055           else
4056             j1=j-1
4057             j2=j-2
4058           endif
4059           kkk=0
4060           lll=0
4061           do k=1,2
4062             do l=1,2
4063               kkk=kkk+1
4064               muij(kkk)=mu(k,i)*mu(l,j)
4065 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4066 #ifdef NEWCORR
4067              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4068 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4069              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4070              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4071 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4072              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4073 #endif
4074             enddo
4075           enddo
4076 cd         write (iout,*) 'EELEC: i',i,' j',j
4077 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4078 cd          write(iout,*) 'muij',muij
4079           ury=scalar(uy(1,i),erij)
4080           urz=scalar(uz(1,i),erij)
4081           vry=scalar(uy(1,j),erij)
4082           vrz=scalar(uz(1,j),erij)
4083           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4084           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4085           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4086           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4087           fac=dsqrt(-ael6i)*r3ij
4088           a22=a22*fac
4089           a23=a23*fac
4090           a32=a32*fac
4091           a33=a33*fac
4092 cd          write (iout,'(4i5,4f10.5)')
4093 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4094 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4095 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4096 cd     &      uy(:,j),uz(:,j)
4097 cd          write (iout,'(4f10.5)')
4098 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4099 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4100 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4101 cd           write (iout,'(9f10.5/)')
4102 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4103 C Derivatives of the elements of A in virtual-bond vectors
4104           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4105           do k=1,3
4106             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4107             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4108             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4109             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4110             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4111             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4112             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4113             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4114             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4115             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4116             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4117             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4118           enddo
4119 C Compute radial contributions to the gradient
4120           facr=-3.0d0*rrmij
4121           a22der=a22*facr
4122           a23der=a23*facr
4123           a32der=a32*facr
4124           a33der=a33*facr
4125           agg(1,1)=a22der*xj
4126           agg(2,1)=a22der*yj
4127           agg(3,1)=a22der*zj
4128           agg(1,2)=a23der*xj
4129           agg(2,2)=a23der*yj
4130           agg(3,2)=a23der*zj
4131           agg(1,3)=a32der*xj
4132           agg(2,3)=a32der*yj
4133           agg(3,3)=a32der*zj
4134           agg(1,4)=a33der*xj
4135           agg(2,4)=a33der*yj
4136           agg(3,4)=a33der*zj
4137 C Add the contributions coming from er
4138           fac3=-3.0d0*fac
4139           do k=1,3
4140             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4141             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4142             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4143             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4144           enddo
4145           do k=1,3
4146 C Derivatives in DC(i)
4147 cgrad            ghalf1=0.5d0*agg(k,1)
4148 cgrad            ghalf2=0.5d0*agg(k,2)
4149 cgrad            ghalf3=0.5d0*agg(k,3)
4150 cgrad            ghalf4=0.5d0*agg(k,4)
4151             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4152      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4153             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4154      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4155             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4156      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4157             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4158      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4159 C Derivatives in DC(i+1)
4160             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4161      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4162             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4163      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4164             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4165      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4166             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4167      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4168 C Derivatives in DC(j)
4169             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4170      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4171             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4172      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4173             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4174      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4175             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4176      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4177 C Derivatives in DC(j+1) or DC(nres-1)
4178             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4179      &      -3.0d0*vryg(k,3)*ury)
4180             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4181      &      -3.0d0*vrzg(k,3)*ury)
4182             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4183      &      -3.0d0*vryg(k,3)*urz)
4184             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4185      &      -3.0d0*vrzg(k,3)*urz)
4186 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4187 cgrad              do l=1,4
4188 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4189 cgrad              enddo
4190 cgrad            endif
4191           enddo
4192           acipa(1,1)=a22
4193           acipa(1,2)=a23
4194           acipa(2,1)=a32
4195           acipa(2,2)=a33
4196           a22=-a22
4197           a23=-a23
4198           do l=1,2
4199             do k=1,3
4200               agg(k,l)=-agg(k,l)
4201               aggi(k,l)=-aggi(k,l)
4202               aggi1(k,l)=-aggi1(k,l)
4203               aggj(k,l)=-aggj(k,l)
4204               aggj1(k,l)=-aggj1(k,l)
4205             enddo
4206           enddo
4207           if (j.lt.nres-1) then
4208             a22=-a22
4209             a32=-a32
4210             do l=1,3,2
4211               do k=1,3
4212                 agg(k,l)=-agg(k,l)
4213                 aggi(k,l)=-aggi(k,l)
4214                 aggi1(k,l)=-aggi1(k,l)
4215                 aggj(k,l)=-aggj(k,l)
4216                 aggj1(k,l)=-aggj1(k,l)
4217               enddo
4218             enddo
4219           else
4220             a22=-a22
4221             a23=-a23
4222             a32=-a32
4223             a33=-a33
4224             do l=1,4
4225               do k=1,3
4226                 agg(k,l)=-agg(k,l)
4227                 aggi(k,l)=-aggi(k,l)
4228                 aggi1(k,l)=-aggi1(k,l)
4229                 aggj(k,l)=-aggj(k,l)
4230                 aggj1(k,l)=-aggj1(k,l)
4231               enddo
4232             enddo
4233           endif
4234           ENDIF ! WCORR
4235           IF (wel_loc.gt.0.0d0) THEN
4236 C Contribution to the local-electrostatic energy coming from the i-j pair
4237           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4238      &     +a33*muij(4)
4239           if (shield_mode.eq.0) then
4240            fac_shield(i)=1.0
4241            fac_shield(j)=1.0
4242 C          else
4243 C           fac_shield(i)=0.4
4244 C           fac_shield(j)=0.6
4245           endif
4246           eel_loc_ij=eel_loc_ij
4247      &    *fac_shield(i)*fac_shield(j)
4248 C Now derivative over eel_loc
4249           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4250      &  (shield_mode.gt.0)) then
4251 C          print *,i,j
4252
4253           do ilist=1,ishield_list(i)
4254            iresshield=shield_list(ilist,i)
4255            do k=1,3
4256            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4257      &                                          /fac_shield(i)
4258 C     &      *2.0
4259            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4260      &              rlocshield
4261      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4262             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4263      &      +rlocshield
4264            enddo
4265           enddo
4266           do ilist=1,ishield_list(j)
4267            iresshield=shield_list(ilist,j)
4268            do k=1,3
4269            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4270      &                                       /fac_shield(j)
4271 C     &     *2.0
4272            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4273      &              rlocshield
4274      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4275            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4276      &             +rlocshield
4277
4278            enddo
4279           enddo
4280
4281           do k=1,3
4282             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4283      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4284             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4285      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4286             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4287      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4288             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4289      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4290            enddo
4291            endif
4292
4293
4294 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4295 c     &                     ' eel_loc_ij',eel_loc_ij
4296 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4297 C Calculate patrial derivative for theta angle
4298 #ifdef NEWCORR
4299          geel_loc_ij=(a22*gmuij1(1)
4300      &     +a23*gmuij1(2)
4301      &     +a32*gmuij1(3)
4302      &     +a33*gmuij1(4))
4303      &    *fac_shield(i)*fac_shield(j)
4304 c         write(iout,*) "derivative over thatai"
4305 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4306 c     &   a33*gmuij1(4)
4307          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4308      &      geel_loc_ij*wel_loc
4309 c         write(iout,*) "derivative over thatai-1"
4310 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4311 c     &   a33*gmuij2(4)
4312          geel_loc_ij=
4313      &     a22*gmuij2(1)
4314      &     +a23*gmuij2(2)
4315      &     +a32*gmuij2(3)
4316      &     +a33*gmuij2(4)
4317          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4318      &      geel_loc_ij*wel_loc
4319      &    *fac_shield(i)*fac_shield(j)
4320
4321 c  Derivative over j residue
4322          geel_loc_ji=a22*gmuji1(1)
4323      &     +a23*gmuji1(2)
4324      &     +a32*gmuji1(3)
4325      &     +a33*gmuji1(4)
4326 c         write(iout,*) "derivative over thataj"
4327 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4328 c     &   a33*gmuji1(4)
4329
4330         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4331      &      geel_loc_ji*wel_loc
4332      &    *fac_shield(i)*fac_shield(j)
4333
4334          geel_loc_ji=
4335      &     +a22*gmuji2(1)
4336      &     +a23*gmuji2(2)
4337      &     +a32*gmuji2(3)
4338      &     +a33*gmuji2(4)
4339 c         write(iout,*) "derivative over thataj-1"
4340 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4341 c     &   a33*gmuji2(4)
4342          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4343      &      geel_loc_ji*wel_loc
4344      &    *fac_shield(i)*fac_shield(j)
4345 #endif
4346 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4347
4348           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4349      &            'eelloc',i,j,eel_loc_ij
4350 c           if (eel_loc_ij.ne.0)
4351 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4352 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4353
4354           eel_loc=eel_loc+eel_loc_ij
4355 C Partial derivatives in virtual-bond dihedral angles gamma
4356           if (i.gt.1)
4357      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4358      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4359      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4360      &    *fac_shield(i)*fac_shield(j)
4361
4362           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4363      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4364      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4365      &    *fac_shield(i)*fac_shield(j)
4366 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4367           do l=1,3
4368             ggg(l)=(agg(l,1)*muij(1)+
4369      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4370      &    *fac_shield(i)*fac_shield(j)
4371             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4372             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4373 cgrad            ghalf=0.5d0*ggg(l)
4374 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4375 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4376           enddo
4377 cgrad          do k=i+1,j2
4378 cgrad            do l=1,3
4379 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4380 cgrad            enddo
4381 cgrad          enddo
4382 C Remaining derivatives of eello
4383           do l=1,3
4384             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4385      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4386      &    *fac_shield(i)*fac_shield(j)
4387
4388             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4389      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4390      &    *fac_shield(i)*fac_shield(j)
4391
4392             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4393      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4394      &    *fac_shield(i)*fac_shield(j)
4395
4396             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4397      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4398      &    *fac_shield(i)*fac_shield(j)
4399
4400           enddo
4401           ENDIF
4402 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4403 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4404           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4405      &       .and. num_conti.le.maxconts) then
4406 c            write (iout,*) i,j," entered corr"
4407 C
4408 C Calculate the contact function. The ith column of the array JCONT will
4409 C contain the numbers of atoms that make contacts with the atom I (of numbers
4410 C greater than I). The arrays FACONT and GACONT will contain the values of
4411 C the contact function and its derivative.
4412 c           r0ij=1.02D0*rpp(iteli,itelj)
4413 c           r0ij=1.11D0*rpp(iteli,itelj)
4414             r0ij=2.20D0*rpp(iteli,itelj)
4415 c           r0ij=1.55D0*rpp(iteli,itelj)
4416             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4417             if (fcont.gt.0.0D0) then
4418               num_conti=num_conti+1
4419               if (num_conti.gt.maxconts) then
4420                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4421      &                         ' will skip next contacts for this conf.'
4422               else
4423                 jcont_hb(num_conti,i)=j
4424 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4425 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4426                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4427      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4428 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4429 C  terms.
4430                 d_cont(num_conti,i)=rij
4431 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4432 C     --- Electrostatic-interaction matrix ---
4433                 a_chuj(1,1,num_conti,i)=a22
4434                 a_chuj(1,2,num_conti,i)=a23
4435                 a_chuj(2,1,num_conti,i)=a32
4436                 a_chuj(2,2,num_conti,i)=a33
4437 C     --- Gradient of rij
4438                 do kkk=1,3
4439                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4440                 enddo
4441                 kkll=0
4442                 do k=1,2
4443                   do l=1,2
4444                     kkll=kkll+1
4445                     do m=1,3
4446                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4447                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4448                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4449                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4450                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4451                     enddo
4452                   enddo
4453                 enddo
4454                 ENDIF
4455                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4456 C Calculate contact energies
4457                 cosa4=4.0D0*cosa
4458                 wij=cosa-3.0D0*cosb*cosg
4459                 cosbg1=cosb+cosg
4460                 cosbg2=cosb-cosg
4461 c               fac3=dsqrt(-ael6i)/r0ij**3
4462                 fac3=dsqrt(-ael6i)*r3ij
4463 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4464                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4465                 if (ees0tmp.gt.0) then
4466                   ees0pij=dsqrt(ees0tmp)
4467                 else
4468                   ees0pij=0
4469                 endif
4470 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4471                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4472                 if (ees0tmp.gt.0) then
4473                   ees0mij=dsqrt(ees0tmp)
4474                 else
4475                   ees0mij=0
4476                 endif
4477 c               ees0mij=0.0D0
4478                 if (shield_mode.eq.0) then
4479                 fac_shield(i)=1.0d0
4480                 fac_shield(j)=1.0d0
4481                 else
4482                 ees0plist(num_conti,i)=j
4483 C                fac_shield(i)=0.4d0
4484 C                fac_shield(j)=0.6d0
4485                 endif
4486                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4487      &          *fac_shield(i)*fac_shield(j)
4488                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4489      &          *fac_shield(i)*fac_shield(j)
4490 C Diagnostics. Comment out or remove after debugging!
4491 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4492 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4493 c               ees0m(num_conti,i)=0.0D0
4494 C End diagnostics.
4495 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4496 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4497 C Angular derivatives of the contact function
4498                 ees0pij1=fac3/ees0pij
4499                 ees0mij1=fac3/ees0mij
4500                 fac3p=-3.0D0*fac3*rrmij
4501                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4502                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4503 c               ees0mij1=0.0D0
4504                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4505                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4506                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4507                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4508                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4509                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4510                 ecosap=ecosa1+ecosa2
4511                 ecosbp=ecosb1+ecosb2
4512                 ecosgp=ecosg1+ecosg2
4513                 ecosam=ecosa1-ecosa2
4514                 ecosbm=ecosb1-ecosb2
4515                 ecosgm=ecosg1-ecosg2
4516 C Diagnostics
4517 c               ecosap=ecosa1
4518 c               ecosbp=ecosb1
4519 c               ecosgp=ecosg1
4520 c               ecosam=0.0D0
4521 c               ecosbm=0.0D0
4522 c               ecosgm=0.0D0
4523 C End diagnostics
4524                 facont_hb(num_conti,i)=fcont
4525                 fprimcont=fprimcont/rij
4526 cd              facont_hb(num_conti,i)=1.0D0
4527 C Following line is for diagnostics.
4528 cd              fprimcont=0.0D0
4529                 do k=1,3
4530                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4531                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4532                 enddo
4533                 do k=1,3
4534                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4535                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4536                 enddo
4537                 gggp(1)=gggp(1)+ees0pijp*xj
4538                 gggp(2)=gggp(2)+ees0pijp*yj
4539                 gggp(3)=gggp(3)+ees0pijp*zj
4540                 gggm(1)=gggm(1)+ees0mijp*xj
4541                 gggm(2)=gggm(2)+ees0mijp*yj
4542                 gggm(3)=gggm(3)+ees0mijp*zj
4543 C Derivatives due to the contact function
4544                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4545                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4546                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4547                 do k=1,3
4548 c
4549 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4550 c          following the change of gradient-summation algorithm.
4551 c
4552 cgrad                  ghalfp=0.5D0*gggp(k)
4553 cgrad                  ghalfm=0.5D0*gggm(k)
4554                   gacontp_hb1(k,num_conti,i)=!ghalfp
4555      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4556      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4557      &          *fac_shield(i)*fac_shield(j)
4558
4559                   gacontp_hb2(k,num_conti,i)=!ghalfp
4560      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4561      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4562      &          *fac_shield(i)*fac_shield(j)
4563
4564                   gacontp_hb3(k,num_conti,i)=gggp(k)
4565      &          *fac_shield(i)*fac_shield(j)
4566
4567                   gacontm_hb1(k,num_conti,i)=!ghalfm
4568      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4569      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4570      &          *fac_shield(i)*fac_shield(j)
4571
4572                   gacontm_hb2(k,num_conti,i)=!ghalfm
4573      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4574      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4575      &          *fac_shield(i)*fac_shield(j)
4576
4577                   gacontm_hb3(k,num_conti,i)=gggm(k)
4578      &          *fac_shield(i)*fac_shield(j)
4579
4580                 enddo
4581 C Diagnostics. Comment out or remove after debugging!
4582 cdiag           do k=1,3
4583 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4584 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4585 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4586 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4587 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4588 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4589 cdiag           enddo
4590               ENDIF ! wcorr
4591               endif  ! num_conti.le.maxconts
4592             endif  ! fcont.gt.0
4593           endif    ! j.gt.i+1
4594           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4595             do k=1,4
4596               do l=1,3
4597                 ghalf=0.5d0*agg(l,k)
4598                 aggi(l,k)=aggi(l,k)+ghalf
4599                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4600                 aggj(l,k)=aggj(l,k)+ghalf
4601               enddo
4602             enddo
4603             if (j.eq.nres-1 .and. i.lt.j-2) then
4604               do k=1,4
4605                 do l=1,3
4606                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4607                 enddo
4608               enddo
4609             endif
4610           endif
4611 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4612       return
4613       end
4614 C-----------------------------------------------------------------------------
4615       subroutine eturn3(i,eello_turn3)
4616 C Third- and fourth-order contributions from turns
4617       implicit real*8 (a-h,o-z)
4618       include 'DIMENSIONS'
4619       include 'COMMON.IOUNITS'
4620       include 'COMMON.GEO'
4621       include 'COMMON.VAR'
4622       include 'COMMON.LOCAL'
4623       include 'COMMON.CHAIN'
4624       include 'COMMON.DERIV'
4625       include 'COMMON.INTERACT'
4626       include 'COMMON.CONTACTS'
4627       include 'COMMON.TORSION'
4628       include 'COMMON.VECTORS'
4629       include 'COMMON.FFIELD'
4630       include 'COMMON.CONTROL'
4631       include 'COMMON.SHIELD'
4632       dimension ggg(3)
4633       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4634      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4635      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4636      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4637      &  auxgmat2(2,2),auxgmatt2(2,2)
4638       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4639      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4640       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4641      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4642      &    num_conti,j1,j2
4643       j=i+2
4644 c      write (iout,*) "eturn3",i,j,j1,j2
4645       a_temp(1,1)=a22
4646       a_temp(1,2)=a23
4647       a_temp(2,1)=a32
4648       a_temp(2,2)=a33
4649 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4650 C
4651 C               Third-order contributions
4652 C
4653 C                 (i+2)o----(i+3)
4654 C                      | |
4655 C                      | |
4656 C                 (i+1)o----i
4657 C
4658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4659 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4660         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4661 c auxalary matices for theta gradient
4662 c auxalary matrix for i+1 and constant i+2
4663         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4664 c auxalary matrix for i+2 and constant i+1
4665         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4666         call transpose2(auxmat(1,1),auxmat1(1,1))
4667         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4668         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4669         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4670         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4671         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4672         if (shield_mode.eq.0) then
4673         fac_shield(i)=1.0
4674         fac_shield(j)=1.0
4675 C        else
4676 C        fac_shield(i)=0.4
4677 C        fac_shield(j)=0.6
4678         endif
4679         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4680      &  *fac_shield(i)*fac_shield(j)
4681         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4682      &  *fac_shield(i)*fac_shield(j)
4683 C Derivatives in theta
4684         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4685      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4686      &   *fac_shield(i)*fac_shield(j)
4687         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4688      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4689      &   *fac_shield(i)*fac_shield(j)
4690
4691
4692 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4693 C Derivatives in shield mode
4694           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4695      &  (shield_mode.gt.0)) then
4696 C          print *,i,j
4697
4698           do ilist=1,ishield_list(i)
4699            iresshield=shield_list(ilist,i)
4700            do k=1,3
4701            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4702 C     &      *2.0
4703            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4704      &              rlocshield
4705      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4706             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4707      &      +rlocshield
4708            enddo
4709           enddo
4710           do ilist=1,ishield_list(j)
4711            iresshield=shield_list(ilist,j)
4712            do k=1,3
4713            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4714 C     &     *2.0
4715            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4716      &              rlocshield
4717      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4718            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4719      &             +rlocshield
4720
4721            enddo
4722           enddo
4723
4724           do k=1,3
4725             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4726      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4727             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4728      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4729             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4730      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4731             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4732      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4733            enddo
4734            endif
4735
4736 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4737 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4738 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4739 cd     &    ' eello_turn3_num',4*eello_turn3_num
4740 C Derivatives in gamma(i)
4741         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4742         call transpose2(auxmat2(1,1),auxmat3(1,1))
4743         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4744         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4745      &   *fac_shield(i)*fac_shield(j)
4746 C Derivatives in gamma(i+1)
4747         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4748         call transpose2(auxmat2(1,1),auxmat3(1,1))
4749         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4750         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4751      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4752      &   *fac_shield(i)*fac_shield(j)
4753 C Cartesian derivatives
4754         do l=1,3
4755 c            ghalf1=0.5d0*agg(l,1)
4756 c            ghalf2=0.5d0*agg(l,2)
4757 c            ghalf3=0.5d0*agg(l,3)
4758 c            ghalf4=0.5d0*agg(l,4)
4759           a_temp(1,1)=aggi(l,1)!+ghalf1
4760           a_temp(1,2)=aggi(l,2)!+ghalf2
4761           a_temp(2,1)=aggi(l,3)!+ghalf3
4762           a_temp(2,2)=aggi(l,4)!+ghalf4
4763           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4764           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4765      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4766      &   *fac_shield(i)*fac_shield(j)
4767
4768           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4769           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4770           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4771           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4772           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4773           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4774      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4775      &   *fac_shield(i)*fac_shield(j)
4776           a_temp(1,1)=aggj(l,1)!+ghalf1
4777           a_temp(1,2)=aggj(l,2)!+ghalf2
4778           a_temp(2,1)=aggj(l,3)!+ghalf3
4779           a_temp(2,2)=aggj(l,4)!+ghalf4
4780           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4781           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4782      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4783      &   *fac_shield(i)*fac_shield(j)
4784           a_temp(1,1)=aggj1(l,1)
4785           a_temp(1,2)=aggj1(l,2)
4786           a_temp(2,1)=aggj1(l,3)
4787           a_temp(2,2)=aggj1(l,4)
4788           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4789           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4790      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4791      &   *fac_shield(i)*fac_shield(j)
4792         enddo
4793       return
4794       end
4795 C-------------------------------------------------------------------------------
4796       subroutine eturn4(i,eello_turn4)
4797 C Third- and fourth-order contributions from turns
4798       implicit real*8 (a-h,o-z)
4799       include 'DIMENSIONS'
4800       include 'COMMON.IOUNITS'
4801       include 'COMMON.GEO'
4802       include 'COMMON.VAR'
4803       include 'COMMON.LOCAL'
4804       include 'COMMON.CHAIN'
4805       include 'COMMON.DERIV'
4806       include 'COMMON.INTERACT'
4807       include 'COMMON.CONTACTS'
4808       include 'COMMON.TORSION'
4809       include 'COMMON.VECTORS'
4810       include 'COMMON.FFIELD'
4811       include 'COMMON.CONTROL'
4812       include 'COMMON.SHIELD'
4813       dimension ggg(3)
4814       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4815      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4816      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4817      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4818      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4819      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4820      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4821       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4822      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4823       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4824      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4825      &    num_conti,j1,j2
4826       j=i+3
4827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4828 C
4829 C               Fourth-order contributions
4830 C
4831 C                 (i+3)o----(i+4)
4832 C                     /  |
4833 C               (i+2)o   |
4834 C                     \  |
4835 C                 (i+1)o----i
4836 C
4837 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4838 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4839 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4840 c        write(iout,*)"WCHODZE W PROGRAM"
4841         a_temp(1,1)=a22
4842         a_temp(1,2)=a23
4843         a_temp(2,1)=a32
4844         a_temp(2,2)=a33
4845         iti1=itype2loc(itype(i+1))
4846         iti2=itype2loc(itype(i+2))
4847         iti3=itype2loc(itype(i+3))
4848 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4849         call transpose2(EUg(1,1,i+1),e1t(1,1))
4850         call transpose2(Eug(1,1,i+2),e2t(1,1))
4851         call transpose2(Eug(1,1,i+3),e3t(1,1))
4852 C Ematrix derivative in theta
4853         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4854         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4855         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4856         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4857 c       eta1 in derivative theta
4858         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4859         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4860 c       auxgvec is derivative of Ub2 so i+3 theta
4861         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4862 c       auxalary matrix of E i+1
4863         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4864 c        s1=0.0
4865 c        gs1=0.0
4866         s1=scalar2(b1(1,i+2),auxvec(1))
4867 c derivative of theta i+2 with constant i+3
4868         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4869 c derivative of theta i+2 with constant i+2
4870         gs32=scalar2(b1(1,i+2),auxgvec(1))
4871 c derivative of E matix in theta of i+1
4872         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4873
4874         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4875 c       ea31 in derivative theta
4876         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4877         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4878 c auxilary matrix auxgvec of Ub2 with constant E matirx
4879         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4880 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4881         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4882
4883 c        s2=0.0
4884 c        gs2=0.0
4885         s2=scalar2(b1(1,i+1),auxvec(1))
4886 c derivative of theta i+1 with constant i+3
4887         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4888 c derivative of theta i+2 with constant i+1
4889         gs21=scalar2(b1(1,i+1),auxgvec(1))
4890 c derivative of theta i+3 with constant i+1
4891         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4892 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4893 c     &  gtb1(1,i+1)
4894         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4895 c two derivatives over diffetent matrices
4896 c gtae3e2 is derivative over i+3
4897         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4898 c ae3gte2 is derivative over i+2
4899         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4900         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4901 c three possible derivative over theta E matices
4902 c i+1
4903         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4904 c i+2
4905         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4906 c i+3
4907         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4908         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4909
4910         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4911         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4912         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4913         if (shield_mode.eq.0) then
4914         fac_shield(i)=1.0
4915         fac_shield(j)=1.0
4916 C        else
4917 C        fac_shield(i)=0.6
4918 C        fac_shield(j)=0.4
4919         endif
4920         eello_turn4=eello_turn4-(s1+s2+s3)
4921      &  *fac_shield(i)*fac_shield(j)
4922         eello_t4=-(s1+s2+s3)
4923      &  *fac_shield(i)*fac_shield(j)
4924 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4925         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4926      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4927 C Now derivative over shield:
4928           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4929      &  (shield_mode.gt.0)) then
4930 C          print *,i,j
4931
4932           do ilist=1,ishield_list(i)
4933            iresshield=shield_list(ilist,i)
4934            do k=1,3
4935            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4936 C     &      *2.0
4937            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4938      &              rlocshield
4939      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4940             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4941      &      +rlocshield
4942            enddo
4943           enddo
4944           do ilist=1,ishield_list(j)
4945            iresshield=shield_list(ilist,j)
4946            do k=1,3
4947            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4948 C     &     *2.0
4949            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4950      &              rlocshield
4951      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4952            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4953      &             +rlocshield
4954
4955            enddo
4956           enddo
4957
4958           do k=1,3
4959             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4960      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4961             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4962      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4963             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4964      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4965             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4966      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4967            enddo
4968            endif
4969
4970
4971
4972
4973
4974
4975 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4976 cd     &    ' eello_turn4_num',8*eello_turn4_num
4977 #ifdef NEWCORR
4978         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4979      &                  -(gs13+gsE13+gsEE1)*wturn4
4980      &  *fac_shield(i)*fac_shield(j)
4981         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4982      &                    -(gs23+gs21+gsEE2)*wturn4
4983      &  *fac_shield(i)*fac_shield(j)
4984
4985         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4986      &                    -(gs32+gsE31+gsEE3)*wturn4
4987      &  *fac_shield(i)*fac_shield(j)
4988
4989 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4990 c     &   gs2
4991 #endif
4992         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4993      &      'eturn4',i,j,-(s1+s2+s3)
4994 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4995 c     &    ' eello_turn4_num',8*eello_turn4_num
4996 C Derivatives in gamma(i)
4997         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4998         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4999         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5000         s1=scalar2(b1(1,i+2),auxvec(1))
5001         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5002         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5003         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5004      &  *fac_shield(i)*fac_shield(j)
5005 C Derivatives in gamma(i+1)
5006         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5007         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5008         s2=scalar2(b1(1,i+1),auxvec(1))
5009         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5010         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5011         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5012         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5013      &  *fac_shield(i)*fac_shield(j)
5014 C Derivatives in gamma(i+2)
5015         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5016         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5017         s1=scalar2(b1(1,i+2),auxvec(1))
5018         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5019         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5020         s2=scalar2(b1(1,i+1),auxvec(1))
5021         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5022         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5023         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5024         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5025      &  *fac_shield(i)*fac_shield(j)
5026 C Cartesian derivatives
5027 C Derivatives of this turn contributions in DC(i+2)
5028         if (j.lt.nres-1) then
5029           do l=1,3
5030             a_temp(1,1)=agg(l,1)
5031             a_temp(1,2)=agg(l,2)
5032             a_temp(2,1)=agg(l,3)
5033             a_temp(2,2)=agg(l,4)
5034             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5035             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5036             s1=scalar2(b1(1,i+2),auxvec(1))
5037             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5038             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5039             s2=scalar2(b1(1,i+1),auxvec(1))
5040             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5041             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5042             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5043             ggg(l)=-(s1+s2+s3)
5044             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5045      &  *fac_shield(i)*fac_shield(j)
5046           enddo
5047         endif
5048 C Remaining derivatives of this turn contribution
5049         do l=1,3
5050           a_temp(1,1)=aggi(l,1)
5051           a_temp(1,2)=aggi(l,2)
5052           a_temp(2,1)=aggi(l,3)
5053           a_temp(2,2)=aggi(l,4)
5054           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5055           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5056           s1=scalar2(b1(1,i+2),auxvec(1))
5057           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5058           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5059           s2=scalar2(b1(1,i+1),auxvec(1))
5060           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5061           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5062           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5063           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5064      &  *fac_shield(i)*fac_shield(j)
5065           a_temp(1,1)=aggi1(l,1)
5066           a_temp(1,2)=aggi1(l,2)
5067           a_temp(2,1)=aggi1(l,3)
5068           a_temp(2,2)=aggi1(l,4)
5069           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5070           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5071           s1=scalar2(b1(1,i+2),auxvec(1))
5072           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5073           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5074           s2=scalar2(b1(1,i+1),auxvec(1))
5075           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5076           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5077           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5078           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5079      &  *fac_shield(i)*fac_shield(j)
5080           a_temp(1,1)=aggj(l,1)
5081           a_temp(1,2)=aggj(l,2)
5082           a_temp(2,1)=aggj(l,3)
5083           a_temp(2,2)=aggj(l,4)
5084           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5085           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5086           s1=scalar2(b1(1,i+2),auxvec(1))
5087           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5088           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5089           s2=scalar2(b1(1,i+1),auxvec(1))
5090           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5091           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5092           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5093           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5094      &  *fac_shield(i)*fac_shield(j)
5095           a_temp(1,1)=aggj1(l,1)
5096           a_temp(1,2)=aggj1(l,2)
5097           a_temp(2,1)=aggj1(l,3)
5098           a_temp(2,2)=aggj1(l,4)
5099           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5100           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5101           s1=scalar2(b1(1,i+2),auxvec(1))
5102           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5103           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5104           s2=scalar2(b1(1,i+1),auxvec(1))
5105           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5106           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5107           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5108 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5109           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5110      &  *fac_shield(i)*fac_shield(j)
5111         enddo
5112       return
5113       end
5114 C-----------------------------------------------------------------------------
5115       subroutine vecpr(u,v,w)
5116       implicit real*8(a-h,o-z)
5117       dimension u(3),v(3),w(3)
5118       w(1)=u(2)*v(3)-u(3)*v(2)
5119       w(2)=-u(1)*v(3)+u(3)*v(1)
5120       w(3)=u(1)*v(2)-u(2)*v(1)
5121       return
5122       end
5123 C-----------------------------------------------------------------------------
5124       subroutine unormderiv(u,ugrad,unorm,ungrad)
5125 C This subroutine computes the derivatives of a normalized vector u, given
5126 C the derivatives computed without normalization conditions, ugrad. Returns
5127 C ungrad.
5128       implicit none
5129       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5130       double precision vec(3)
5131       double precision scalar
5132       integer i,j
5133 c      write (2,*) 'ugrad',ugrad
5134 c      write (2,*) 'u',u
5135       do i=1,3
5136         vec(i)=scalar(ugrad(1,i),u(1))
5137       enddo
5138 c      write (2,*) 'vec',vec
5139       do i=1,3
5140         do j=1,3
5141           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5142         enddo
5143       enddo
5144 c      write (2,*) 'ungrad',ungrad
5145       return
5146       end
5147 C-----------------------------------------------------------------------------
5148       subroutine escp_soft_sphere(evdw2,evdw2_14)
5149 C
5150 C This subroutine calculates the excluded-volume interaction energy between
5151 C peptide-group centers and side chains and its gradient in virtual-bond and
5152 C side-chain vectors.
5153 C
5154       implicit real*8 (a-h,o-z)
5155       include 'DIMENSIONS'
5156       include 'COMMON.GEO'
5157       include 'COMMON.VAR'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.CHAIN'
5160       include 'COMMON.DERIV'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.FFIELD'
5163       include 'COMMON.IOUNITS'
5164       include 'COMMON.CONTROL'
5165       dimension ggg(3)
5166       evdw2=0.0D0
5167       evdw2_14=0.0d0
5168       r0_scp=4.5d0
5169 cd    print '(a)','Enter ESCP'
5170 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5171 C      do xshift=-1,1
5172 C      do yshift=-1,1
5173 C      do zshift=-1,1
5174       do i=iatscp_s,iatscp_e
5175         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5176         iteli=itel(i)
5177         xi=0.5D0*(c(1,i)+c(1,i+1))
5178         yi=0.5D0*(c(2,i)+c(2,i+1))
5179         zi=0.5D0*(c(3,i)+c(3,i+1))
5180 C Return atom into box, boxxsize is size of box in x dimension
5181 c  134   continue
5182 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5183 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5184 C Condition for being inside the proper box
5185 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5186 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5187 c        go to 134
5188 c        endif
5189 c  135   continue
5190 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5191 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5192 C Condition for being inside the proper box
5193 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5194 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5195 c        go to 135
5196 c c       endif
5197 c  136   continue
5198 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5199 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5200 cC Condition for being inside the proper box
5201 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5202 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5203 c        go to 136
5204 c        endif
5205           xi=mod(xi,boxxsize)
5206           if (xi.lt.0) xi=xi+boxxsize
5207           yi=mod(yi,boxysize)
5208           if (yi.lt.0) yi=yi+boxysize
5209           zi=mod(zi,boxzsize)
5210           if (zi.lt.0) zi=zi+boxzsize
5211 C          xi=xi+xshift*boxxsize
5212 C          yi=yi+yshift*boxysize
5213 C          zi=zi+zshift*boxzsize
5214         do iint=1,nscp_gr(i)
5215
5216         do j=iscpstart(i,iint),iscpend(i,iint)
5217           if (itype(j).eq.ntyp1) cycle
5218           itypj=iabs(itype(j))
5219 C Uncomment following three lines for SC-p interactions
5220 c         xj=c(1,nres+j)-xi
5221 c         yj=c(2,nres+j)-yi
5222 c         zj=c(3,nres+j)-zi
5223 C Uncomment following three lines for Ca-p interactions
5224           xj=c(1,j)
5225           yj=c(2,j)
5226           zj=c(3,j)
5227 c  174   continue
5228 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5229 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5230 C Condition for being inside the proper box
5231 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5232 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5233 c        go to 174
5234 c        endif
5235 c  175   continue
5236 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5237 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5238 cC Condition for being inside the proper box
5239 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5240 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5241 c        go to 175
5242 c        endif
5243 c  176   continue
5244 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5245 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5246 C Condition for being inside the proper box
5247 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5248 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5249 c        go to 176
5250           xj=mod(xj,boxxsize)
5251           if (xj.lt.0) xj=xj+boxxsize
5252           yj=mod(yj,boxysize)
5253           if (yj.lt.0) yj=yj+boxysize
5254           zj=mod(zj,boxzsize)
5255           if (zj.lt.0) zj=zj+boxzsize
5256       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5257       xj_safe=xj
5258       yj_safe=yj
5259       zj_safe=zj
5260       subchap=0
5261       do xshift=-1,1
5262       do yshift=-1,1
5263       do zshift=-1,1
5264           xj=xj_safe+xshift*boxxsize
5265           yj=yj_safe+yshift*boxysize
5266           zj=zj_safe+zshift*boxzsize
5267           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5268           if(dist_temp.lt.dist_init) then
5269             dist_init=dist_temp
5270             xj_temp=xj
5271             yj_temp=yj
5272             zj_temp=zj
5273             subchap=1
5274           endif
5275        enddo
5276        enddo
5277        enddo
5278        if (subchap.eq.1) then
5279           xj=xj_temp-xi
5280           yj=yj_temp-yi
5281           zj=zj_temp-zi
5282        else
5283           xj=xj_safe-xi
5284           yj=yj_safe-yi
5285           zj=zj_safe-zi
5286        endif
5287 c c       endif
5288 C          xj=xj-xi
5289 C          yj=yj-yi
5290 C          zj=zj-zi
5291           rij=xj*xj+yj*yj+zj*zj
5292
5293           r0ij=r0_scp
5294           r0ijsq=r0ij*r0ij
5295           if (rij.lt.r0ijsq) then
5296             evdwij=0.25d0*(rij-r0ijsq)**2
5297             fac=rij-r0ijsq
5298           else
5299             evdwij=0.0d0
5300             fac=0.0d0
5301           endif
5302           evdw2=evdw2+evdwij
5303 C
5304 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5305 C
5306           ggg(1)=xj*fac
5307           ggg(2)=yj*fac
5308           ggg(3)=zj*fac
5309 cgrad          if (j.lt.i) then
5310 cd          write (iout,*) 'j<i'
5311 C Uncomment following three lines for SC-p interactions
5312 c           do k=1,3
5313 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5314 c           enddo
5315 cgrad          else
5316 cd          write (iout,*) 'j>i'
5317 cgrad            do k=1,3
5318 cgrad              ggg(k)=-ggg(k)
5319 C Uncomment following line for SC-p interactions
5320 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5321 cgrad            enddo
5322 cgrad          endif
5323 cgrad          do k=1,3
5324 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5325 cgrad          enddo
5326 cgrad          kstart=min0(i+1,j)
5327 cgrad          kend=max0(i-1,j-1)
5328 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5329 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5330 cgrad          do k=kstart,kend
5331 cgrad            do l=1,3
5332 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5333 cgrad            enddo
5334 cgrad          enddo
5335           do k=1,3
5336             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5337             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5338           enddo
5339         enddo
5340
5341         enddo ! iint
5342       enddo ! i
5343 C      enddo !zshift
5344 C      enddo !yshift
5345 C      enddo !xshift
5346       return
5347       end
5348 C-----------------------------------------------------------------------------
5349       subroutine escp(evdw2,evdw2_14)
5350 C
5351 C This subroutine calculates the excluded-volume interaction energy between
5352 C peptide-group centers and side chains and its gradient in virtual-bond and
5353 C side-chain vectors.
5354 C
5355       implicit real*8 (a-h,o-z)
5356       include 'DIMENSIONS'
5357       include 'COMMON.GEO'
5358       include 'COMMON.VAR'
5359       include 'COMMON.LOCAL'
5360       include 'COMMON.CHAIN'
5361       include 'COMMON.DERIV'
5362       include 'COMMON.INTERACT'
5363       include 'COMMON.FFIELD'
5364       include 'COMMON.IOUNITS'
5365       include 'COMMON.CONTROL'
5366       include 'COMMON.SPLITELE'
5367       dimension ggg(3)
5368       evdw2=0.0D0
5369       evdw2_14=0.0d0
5370 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5371 cd    print '(a)','Enter ESCP'
5372 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5373 C      do xshift=-1,1
5374 C      do yshift=-1,1
5375 C      do zshift=-1,1
5376       do i=iatscp_s,iatscp_e
5377         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5378         iteli=itel(i)
5379         xi=0.5D0*(c(1,i)+c(1,i+1))
5380         yi=0.5D0*(c(2,i)+c(2,i+1))
5381         zi=0.5D0*(c(3,i)+c(3,i+1))
5382           xi=mod(xi,boxxsize)
5383           if (xi.lt.0) xi=xi+boxxsize
5384           yi=mod(yi,boxysize)
5385           if (yi.lt.0) yi=yi+boxysize
5386           zi=mod(zi,boxzsize)
5387           if (zi.lt.0) zi=zi+boxzsize
5388 c          xi=xi+xshift*boxxsize
5389 c          yi=yi+yshift*boxysize
5390 c          zi=zi+zshift*boxzsize
5391 c        print *,xi,yi,zi,'polozenie i'
5392 C Return atom into box, boxxsize is size of box in x dimension
5393 c  134   continue
5394 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5395 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5396 C Condition for being inside the proper box
5397 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5398 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5399 c        go to 134
5400 c        endif
5401 c  135   continue
5402 c          print *,xi,boxxsize,"pierwszy"
5403
5404 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5405 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5406 C Condition for being inside the proper box
5407 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5408 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5409 c        go to 135
5410 c        endif
5411 c  136   continue
5412 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5413 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5414 C Condition for being inside the proper box
5415 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5416 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5417 c        go to 136
5418 c        endif
5419         do iint=1,nscp_gr(i)
5420
5421         do j=iscpstart(i,iint),iscpend(i,iint)
5422           itypj=iabs(itype(j))
5423           if (itypj.eq.ntyp1) cycle
5424 C Uncomment following three lines for SC-p interactions
5425 c         xj=c(1,nres+j)-xi
5426 c         yj=c(2,nres+j)-yi
5427 c         zj=c(3,nres+j)-zi
5428 C Uncomment following three lines for Ca-p interactions
5429           xj=c(1,j)
5430           yj=c(2,j)
5431           zj=c(3,j)
5432           xj=mod(xj,boxxsize)
5433           if (xj.lt.0) xj=xj+boxxsize
5434           yj=mod(yj,boxysize)
5435           if (yj.lt.0) yj=yj+boxysize
5436           zj=mod(zj,boxzsize)
5437           if (zj.lt.0) zj=zj+boxzsize
5438 c  174   continue
5439 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5440 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5441 C Condition for being inside the proper box
5442 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5443 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5444 c        go to 174
5445 c        endif
5446 c  175   continue
5447 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5448 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5449 cC Condition for being inside the proper box
5450 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5451 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5452 c        go to 175
5453 c        endif
5454 c  176   continue
5455 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5456 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5457 C Condition for being inside the proper box
5458 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5459 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5460 c        go to 176
5461 c        endif
5462 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5463       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5464       xj_safe=xj
5465       yj_safe=yj
5466       zj_safe=zj
5467       subchap=0
5468       do xshift=-1,1
5469       do yshift=-1,1
5470       do zshift=-1,1
5471           xj=xj_safe+xshift*boxxsize
5472           yj=yj_safe+yshift*boxysize
5473           zj=zj_safe+zshift*boxzsize
5474           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5475           if(dist_temp.lt.dist_init) then
5476             dist_init=dist_temp
5477             xj_temp=xj
5478             yj_temp=yj
5479             zj_temp=zj
5480             subchap=1
5481           endif
5482        enddo
5483        enddo
5484        enddo
5485        if (subchap.eq.1) then
5486           xj=xj_temp-xi
5487           yj=yj_temp-yi
5488           zj=zj_temp-zi
5489        else
5490           xj=xj_safe-xi
5491           yj=yj_safe-yi
5492           zj=zj_safe-zi
5493        endif
5494 c          print *,xj,yj,zj,'polozenie j'
5495           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5496 c          print *,rrij
5497           sss=sscale(1.0d0/(dsqrt(rrij)))
5498 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5499 c          if (sss.eq.0) print *,'czasem jest OK'
5500           if (sss.le.0.0d0) cycle
5501           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5502           fac=rrij**expon2
5503           e1=fac*fac*aad(itypj,iteli)
5504           e2=fac*bad(itypj,iteli)
5505           if (iabs(j-i) .le. 2) then
5506             e1=scal14*e1
5507             e2=scal14*e2
5508             evdw2_14=evdw2_14+(e1+e2)*sss
5509           endif
5510           evdwij=e1+e2
5511           evdw2=evdw2+evdwij*sss
5512           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5513      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5514      &       bad(itypj,iteli)
5515 C
5516 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5517 C
5518           fac=-(evdwij+e1)*rrij*sss
5519           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5520           ggg(1)=xj*fac
5521           ggg(2)=yj*fac
5522           ggg(3)=zj*fac
5523 cgrad          if (j.lt.i) then
5524 cd          write (iout,*) 'j<i'
5525 C Uncomment following three lines for SC-p interactions
5526 c           do k=1,3
5527 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5528 c           enddo
5529 cgrad          else
5530 cd          write (iout,*) 'j>i'
5531 cgrad            do k=1,3
5532 cgrad              ggg(k)=-ggg(k)
5533 C Uncomment following line for SC-p interactions
5534 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5535 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5536 cgrad            enddo
5537 cgrad          endif
5538 cgrad          do k=1,3
5539 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5540 cgrad          enddo
5541 cgrad          kstart=min0(i+1,j)
5542 cgrad          kend=max0(i-1,j-1)
5543 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5544 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5545 cgrad          do k=kstart,kend
5546 cgrad            do l=1,3
5547 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5548 cgrad            enddo
5549 cgrad          enddo
5550           do k=1,3
5551             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5552             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5553           enddo
5554 c        endif !endif for sscale cutoff
5555         enddo ! j
5556
5557         enddo ! iint
5558       enddo ! i
5559 c      enddo !zshift
5560 c      enddo !yshift
5561 c      enddo !xshift
5562       do i=1,nct
5563         do j=1,3
5564           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5565           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5566           gradx_scp(j,i)=expon*gradx_scp(j,i)
5567         enddo
5568       enddo
5569 C******************************************************************************
5570 C
5571 C                              N O T E !!!
5572 C
5573 C To save time the factor EXPON has been extracted from ALL components
5574 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5575 C use!
5576 C
5577 C******************************************************************************
5578       return
5579       end
5580 C--------------------------------------------------------------------------
5581       subroutine edis(ehpb)
5582 C
5583 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5584 C
5585       implicit real*8 (a-h,o-z)
5586       include 'DIMENSIONS'
5587       include 'COMMON.SBRIDGE'
5588       include 'COMMON.CHAIN'
5589       include 'COMMON.DERIV'
5590       include 'COMMON.VAR'
5591       include 'COMMON.INTERACT'
5592       include 'COMMON.IOUNITS'
5593       include 'COMMON.CONTROL'
5594       dimension ggg(3)
5595       ehpb=0.0D0
5596       do i=1,3
5597        ggg(i)=0.0d0
5598       enddo
5599 C      write (iout,*) ,"link_end",link_end,constr_dist
5600 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5601 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5602       if (link_end.eq.0) return
5603       do i=link_start,link_end
5604 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5605 C CA-CA distance used in regularization of structure.
5606         ii=ihpb(i)
5607         jj=jhpb(i)
5608 C iii and jjj point to the residues for which the distance is assigned.
5609         if (ii.gt.nres) then
5610           iii=ii-nres
5611           jjj=jj-nres
5612         else
5613           iii=ii
5614           jjj=jj
5615         endif
5616 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5617 c     &    dhpb(i),dhpb1(i),forcon(i)
5618 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5619 C    distance and angle dependent SS bond potential.
5620 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5621 C     & iabs(itype(jjj)).eq.1) then
5622 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5623 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5624         if (.not.dyn_ss .and. i.le.nss) then
5625 C 15/02/13 CC dynamic SSbond - additional check
5626          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5627      & iabs(itype(jjj)).eq.1) then
5628           call ssbond_ene(iii,jjj,eij)
5629           ehpb=ehpb+2*eij
5630          endif
5631 cd          write (iout,*) "eij",eij
5632 cd   &   ' waga=',waga,' fac=',fac
5633         else if (ii.gt.nres .and. jj.gt.nres) then
5634 c Restraints from contact prediction
5635           dd=dist(ii,jj)
5636           if (constr_dist.eq.11) then
5637             ehpb=ehpb+fordepth(i)**4.0d0
5638      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5639             fac=fordepth(i)**4.0d0
5640      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5641           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5642      &    ehpb,fordepth(i),dd
5643            else
5644           if (dhpb1(i).gt.0.0d0) then
5645             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5646             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5647 c            write (iout,*) "beta nmr",
5648 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5649           else
5650             dd=dist(ii,jj)
5651             rdis=dd-dhpb(i)
5652 C Get the force constant corresponding to this distance.
5653             waga=forcon(i)
5654 C Calculate the contribution to energy.
5655             ehpb=ehpb+waga*rdis*rdis
5656 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5657 C
5658 C Evaluate gradient.
5659 C
5660             fac=waga*rdis/dd
5661           endif
5662           endif
5663           do j=1,3
5664             ggg(j)=fac*(c(j,jj)-c(j,ii))
5665           enddo
5666           do j=1,3
5667             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5668             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5669           enddo
5670           do k=1,3
5671             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5672             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5673           enddo
5674         else
5675 C Calculate the distance between the two points and its difference from the
5676 C target distance.
5677           dd=dist(ii,jj)
5678           if (constr_dist.eq.11) then
5679             ehpb=ehpb+fordepth(i)**4.0d0
5680      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5681             fac=fordepth(i)**4.0d0
5682      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5683           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5684      &    ehpb,fordepth(i),dd
5685            else
5686           if (dhpb1(i).gt.0.0d0) then
5687             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5688             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5689 c            write (iout,*) "alph nmr",
5690 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5691           else
5692             rdis=dd-dhpb(i)
5693 C Get the force constant corresponding to this distance.
5694             waga=forcon(i)
5695 C Calculate the contribution to energy.
5696             ehpb=ehpb+waga*rdis*rdis
5697 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5698 C
5699 C Evaluate gradient.
5700 C
5701             fac=waga*rdis/dd
5702           endif
5703           endif
5704             do j=1,3
5705               ggg(j)=fac*(c(j,jj)-c(j,ii))
5706             enddo
5707 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5708 C If this is a SC-SC distance, we need to calculate the contributions to the
5709 C Cartesian gradient in the SC vectors (ghpbx).
5710           if (iii.lt.ii) then
5711           do j=1,3
5712             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5713             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5714           enddo
5715           endif
5716 cgrad        do j=iii,jjj-1
5717 cgrad          do k=1,3
5718 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5719 cgrad          enddo
5720 cgrad        enddo
5721           do k=1,3
5722             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5723             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5724           enddo
5725         endif
5726       enddo
5727       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5728       return
5729       end
5730 C--------------------------------------------------------------------------
5731       subroutine ssbond_ene(i,j,eij)
5732 C
5733 C Calculate the distance and angle dependent SS-bond potential energy
5734 C using a free-energy function derived based on RHF/6-31G** ab initio
5735 C calculations of diethyl disulfide.
5736 C
5737 C A. Liwo and U. Kozlowska, 11/24/03
5738 C
5739       implicit real*8 (a-h,o-z)
5740       include 'DIMENSIONS'
5741       include 'COMMON.SBRIDGE'
5742       include 'COMMON.CHAIN'
5743       include 'COMMON.DERIV'
5744       include 'COMMON.LOCAL'
5745       include 'COMMON.INTERACT'
5746       include 'COMMON.VAR'
5747       include 'COMMON.IOUNITS'
5748       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5749       itypi=iabs(itype(i))
5750       xi=c(1,nres+i)
5751       yi=c(2,nres+i)
5752       zi=c(3,nres+i)
5753       dxi=dc_norm(1,nres+i)
5754       dyi=dc_norm(2,nres+i)
5755       dzi=dc_norm(3,nres+i)
5756 c      dsci_inv=dsc_inv(itypi)
5757       dsci_inv=vbld_inv(nres+i)
5758       itypj=iabs(itype(j))
5759 c      dscj_inv=dsc_inv(itypj)
5760       dscj_inv=vbld_inv(nres+j)
5761       xj=c(1,nres+j)-xi
5762       yj=c(2,nres+j)-yi
5763       zj=c(3,nres+j)-zi
5764       dxj=dc_norm(1,nres+j)
5765       dyj=dc_norm(2,nres+j)
5766       dzj=dc_norm(3,nres+j)
5767       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5768       rij=dsqrt(rrij)
5769       erij(1)=xj*rij
5770       erij(2)=yj*rij
5771       erij(3)=zj*rij
5772       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5773       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5774       om12=dxi*dxj+dyi*dyj+dzi*dzj
5775       do k=1,3
5776         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5777         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5778       enddo
5779       rij=1.0d0/rij
5780       deltad=rij-d0cm
5781       deltat1=1.0d0-om1
5782       deltat2=1.0d0+om2
5783       deltat12=om2-om1+2.0d0
5784       cosphi=om12-om1*om2
5785       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5786      &  +akct*deltad*deltat12
5787      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5788 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5789 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5790 c     &  " deltat12",deltat12," eij",eij
5791       ed=2*akcm*deltad+akct*deltat12
5792       pom1=akct*deltad
5793       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5794       eom1=-2*akth*deltat1-pom1-om2*pom2
5795       eom2= 2*akth*deltat2+pom1-om1*pom2
5796       eom12=pom2
5797       do k=1,3
5798         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5799         ghpbx(k,i)=ghpbx(k,i)-ggk
5800      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5801      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5802         ghpbx(k,j)=ghpbx(k,j)+ggk
5803      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5804      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5805         ghpbc(k,i)=ghpbc(k,i)-ggk
5806         ghpbc(k,j)=ghpbc(k,j)+ggk
5807       enddo
5808 C
5809 C Calculate the components of the gradient in DC and X
5810 C
5811 cgrad      do k=i,j-1
5812 cgrad        do l=1,3
5813 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5814 cgrad        enddo
5815 cgrad      enddo
5816       return
5817       end
5818 C--------------------------------------------------------------------------
5819       subroutine ebond(estr)
5820 c
5821 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5822 c
5823       implicit real*8 (a-h,o-z)
5824       include 'DIMENSIONS'
5825       include 'COMMON.LOCAL'
5826       include 'COMMON.GEO'
5827       include 'COMMON.INTERACT'
5828       include 'COMMON.DERIV'
5829       include 'COMMON.VAR'
5830       include 'COMMON.CHAIN'
5831       include 'COMMON.IOUNITS'
5832       include 'COMMON.NAMES'
5833       include 'COMMON.FFIELD'
5834       include 'COMMON.CONTROL'
5835       include 'COMMON.SETUP'
5836       double precision u(3),ud(3)
5837       estr=0.0d0
5838       estr1=0.0d0
5839       do i=ibondp_start,ibondp_end
5840         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5841 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5842 c          do j=1,3
5843 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5844 c     &      *dc(j,i-1)/vbld(i)
5845 c          enddo
5846 c          if (energy_dec) write(iout,*)
5847 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5848 c        else
5849 C       Checking if it involves dummy (NH3+ or COO-) group
5850          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5851 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5852         diff = vbld(i)-vbldpDUM
5853         if (energy_dec) write(iout,*) "dum_bond",i,diff
5854          else
5855 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5856         diff = vbld(i)-vbldp0
5857          endif
5858         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5859      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5860         estr=estr+diff*diff
5861         do j=1,3
5862           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5863         enddo
5864 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5865 c        endif
5866       enddo
5867
5868       estr=0.5d0*AKP*estr+estr1
5869 c
5870 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5871 c
5872       do i=ibond_start,ibond_end
5873         iti=iabs(itype(i))
5874         if (iti.ne.10 .and. iti.ne.ntyp1) then
5875           nbi=nbondterm(iti)
5876           if (nbi.eq.1) then
5877             diff=vbld(i+nres)-vbldsc0(1,iti)
5878             if (energy_dec)  write (iout,*)
5879      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5880      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5881             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5882             do j=1,3
5883               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5884             enddo
5885           else
5886             do j=1,nbi
5887               diff=vbld(i+nres)-vbldsc0(j,iti)
5888               ud(j)=aksc(j,iti)*diff
5889               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5890             enddo
5891             uprod=u(1)
5892             do j=2,nbi
5893               uprod=uprod*u(j)
5894             enddo
5895             usum=0.0d0
5896             usumsqder=0.0d0
5897             do j=1,nbi
5898               uprod1=1.0d0
5899               uprod2=1.0d0
5900               do k=1,nbi
5901                 if (k.ne.j) then
5902                   uprod1=uprod1*u(k)
5903                   uprod2=uprod2*u(k)*u(k)
5904                 endif
5905               enddo
5906               usum=usum+uprod1
5907               usumsqder=usumsqder+ud(j)*uprod2
5908             enddo
5909             estr=estr+uprod/usum
5910             do j=1,3
5911              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5912             enddo
5913           endif
5914         endif
5915       enddo
5916       return
5917       end
5918 #ifdef CRYST_THETA
5919 C--------------------------------------------------------------------------
5920       subroutine ebend(etheta,ethetacnstr)
5921 C
5922 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5923 C angles gamma and its derivatives in consecutive thetas and gammas.
5924 C
5925       implicit real*8 (a-h,o-z)
5926       include 'DIMENSIONS'
5927       include 'COMMON.LOCAL'
5928       include 'COMMON.GEO'
5929       include 'COMMON.INTERACT'
5930       include 'COMMON.DERIV'
5931       include 'COMMON.VAR'
5932       include 'COMMON.CHAIN'
5933       include 'COMMON.IOUNITS'
5934       include 'COMMON.NAMES'
5935       include 'COMMON.FFIELD'
5936       include 'COMMON.CONTROL'
5937       include 'COMMON.TORCNSTR'
5938       common /calcthet/ term1,term2,termm,diffak,ratak,
5939      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5940      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5941       double precision y(2),z(2)
5942       delta=0.02d0*pi
5943 c      time11=dexp(-2*time)
5944 c      time12=1.0d0
5945       etheta=0.0D0
5946 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5947       do i=ithet_start,ithet_end
5948         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5949      &  .or.itype(i).eq.ntyp1) cycle
5950 C Zero the energy function and its derivative at 0 or pi.
5951         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5952         it=itype(i-1)
5953         ichir1=isign(1,itype(i-2))
5954         ichir2=isign(1,itype(i))
5955          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5956          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5957          if (itype(i-1).eq.10) then
5958           itype1=isign(10,itype(i-2))
5959           ichir11=isign(1,itype(i-2))
5960           ichir12=isign(1,itype(i-2))
5961           itype2=isign(10,itype(i))
5962           ichir21=isign(1,itype(i))
5963           ichir22=isign(1,itype(i))
5964          endif
5965
5966         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5967 #ifdef OSF
5968           phii=phi(i)
5969           if (phii.ne.phii) phii=150.0
5970 #else
5971           phii=phi(i)
5972 #endif
5973           y(1)=dcos(phii)
5974           y(2)=dsin(phii)
5975         else
5976           y(1)=0.0D0
5977           y(2)=0.0D0
5978         endif
5979         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5980 #ifdef OSF
5981           phii1=phi(i+1)
5982           if (phii1.ne.phii1) phii1=150.0
5983           phii1=pinorm(phii1)
5984           z(1)=cos(phii1)
5985 #else
5986           phii1=phi(i+1)
5987 #endif
5988           z(1)=dcos(phii1)
5989           z(2)=dsin(phii1)
5990         else
5991           z(1)=0.0D0
5992           z(2)=0.0D0
5993         endif
5994 C Calculate the "mean" value of theta from the part of the distribution
5995 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5996 C In following comments this theta will be referred to as t_c.
5997         thet_pred_mean=0.0d0
5998         do k=1,2
5999             athetk=athet(k,it,ichir1,ichir2)
6000             bthetk=bthet(k,it,ichir1,ichir2)
6001           if (it.eq.10) then
6002              athetk=athet(k,itype1,ichir11,ichir12)
6003              bthetk=bthet(k,itype2,ichir21,ichir22)
6004           endif
6005          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6006 c         write(iout,*) 'chuj tu', y(k),z(k)
6007         enddo
6008         dthett=thet_pred_mean*ssd
6009         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6010 C Derivatives of the "mean" values in gamma1 and gamma2.
6011         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6012      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6013          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6014      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6015          if (it.eq.10) then
6016       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6017      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6018         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6019      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6020          endif
6021         if (theta(i).gt.pi-delta) then
6022           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6023      &         E_tc0)
6024           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6025           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6026           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6027      &        E_theta)
6028           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6029      &        E_tc)
6030         else if (theta(i).lt.delta) then
6031           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6032           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6033           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6034      &        E_theta)
6035           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6036           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6037      &        E_tc)
6038         else
6039           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6040      &        E_theta,E_tc)
6041         endif
6042         etheta=etheta+ethetai
6043         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6044      &      'ebend',i,ethetai,theta(i),itype(i)
6045         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6046         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6047         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6048       enddo
6049       ethetacnstr=0.0d0
6050 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6051       do i=ithetaconstr_start,ithetaconstr_end
6052         itheta=itheta_constr(i)
6053         thetiii=theta(itheta)
6054         difi=pinorm(thetiii-theta_constr0(i))
6055         if (difi.gt.theta_drange(i)) then
6056           difi=difi-theta_drange(i)
6057           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6058           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6059      &    +for_thet_constr(i)*difi**3
6060         else if (difi.lt.-drange(i)) then
6061           difi=difi+drange(i)
6062           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6063           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6064      &    +for_thet_constr(i)*difi**3
6065         else
6066           difi=0.0
6067         endif
6068        if (energy_dec) then
6069         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6070      &    i,itheta,rad2deg*thetiii,
6071      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6072      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6073      &    gloc(itheta+nphi-2,icg)
6074         endif
6075       enddo
6076
6077 C Ufff.... We've done all this!!!
6078       return
6079       end
6080 C---------------------------------------------------------------------------
6081       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6082      &     E_tc)
6083       implicit real*8 (a-h,o-z)
6084       include 'DIMENSIONS'
6085       include 'COMMON.LOCAL'
6086       include 'COMMON.IOUNITS'
6087       common /calcthet/ term1,term2,termm,diffak,ratak,
6088      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6089      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6090 C Calculate the contributions to both Gaussian lobes.
6091 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6092 C The "polynomial part" of the "standard deviation" of this part of
6093 C the distributioni.
6094 ccc        write (iout,*) thetai,thet_pred_mean
6095         sig=polthet(3,it)
6096         do j=2,0,-1
6097           sig=sig*thet_pred_mean+polthet(j,it)
6098         enddo
6099 C Derivative of the "interior part" of the "standard deviation of the"
6100 C gamma-dependent Gaussian lobe in t_c.
6101         sigtc=3*polthet(3,it)
6102         do j=2,1,-1
6103           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6104         enddo
6105         sigtc=sig*sigtc
6106 C Set the parameters of both Gaussian lobes of the distribution.
6107 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6108         fac=sig*sig+sigc0(it)
6109         sigcsq=fac+fac
6110         sigc=1.0D0/sigcsq
6111 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6112         sigsqtc=-4.0D0*sigcsq*sigtc
6113 c       print *,i,sig,sigtc,sigsqtc
6114 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6115         sigtc=-sigtc/(fac*fac)
6116 C Following variable is sigma(t_c)**(-2)
6117         sigcsq=sigcsq*sigcsq
6118         sig0i=sig0(it)
6119         sig0inv=1.0D0/sig0i**2
6120         delthec=thetai-thet_pred_mean
6121         delthe0=thetai-theta0i
6122         term1=-0.5D0*sigcsq*delthec*delthec
6123         term2=-0.5D0*sig0inv*delthe0*delthe0
6124 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6125 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6126 C NaNs in taking the logarithm. We extract the largest exponent which is added
6127 C to the energy (this being the log of the distribution) at the end of energy
6128 C term evaluation for this virtual-bond angle.
6129         if (term1.gt.term2) then
6130           termm=term1
6131           term2=dexp(term2-termm)
6132           term1=1.0d0
6133         else
6134           termm=term2
6135           term1=dexp(term1-termm)
6136           term2=1.0d0
6137         endif
6138 C The ratio between the gamma-independent and gamma-dependent lobes of
6139 C the distribution is a Gaussian function of thet_pred_mean too.
6140         diffak=gthet(2,it)-thet_pred_mean
6141         ratak=diffak/gthet(3,it)**2
6142         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6143 C Let's differentiate it in thet_pred_mean NOW.
6144         aktc=ak*ratak
6145 C Now put together the distribution terms to make complete distribution.
6146         termexp=term1+ak*term2
6147         termpre=sigc+ak*sig0i
6148 C Contribution of the bending energy from this theta is just the -log of
6149 C the sum of the contributions from the two lobes and the pre-exponential
6150 C factor. Simple enough, isn't it?
6151         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6152 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6153 C NOW the derivatives!!!
6154 C 6/6/97 Take into account the deformation.
6155         E_theta=(delthec*sigcsq*term1
6156      &       +ak*delthe0*sig0inv*term2)/termexp
6157         E_tc=((sigtc+aktc*sig0i)/termpre
6158      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6159      &       aktc*term2)/termexp)
6160       return
6161       end
6162 c-----------------------------------------------------------------------------
6163       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6164       implicit real*8 (a-h,o-z)
6165       include 'DIMENSIONS'
6166       include 'COMMON.LOCAL'
6167       include 'COMMON.IOUNITS'
6168       common /calcthet/ term1,term2,termm,diffak,ratak,
6169      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6170      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6171       delthec=thetai-thet_pred_mean
6172       delthe0=thetai-theta0i
6173 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6174       t3 = thetai-thet_pred_mean
6175       t6 = t3**2
6176       t9 = term1
6177       t12 = t3*sigcsq
6178       t14 = t12+t6*sigsqtc
6179       t16 = 1.0d0
6180       t21 = thetai-theta0i
6181       t23 = t21**2
6182       t26 = term2
6183       t27 = t21*t26
6184       t32 = termexp
6185       t40 = t32**2
6186       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6187      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6188      & *(-t12*t9-ak*sig0inv*t27)
6189       return
6190       end
6191 #else
6192 C--------------------------------------------------------------------------
6193       subroutine ebend(etheta,ethetacnstr)
6194 C
6195 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6196 C angles gamma and its derivatives in consecutive thetas and gammas.
6197 C ab initio-derived potentials from
6198 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6199 C
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.LOCAL'
6203       include 'COMMON.GEO'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.DERIV'
6206       include 'COMMON.VAR'
6207       include 'COMMON.CHAIN'
6208       include 'COMMON.IOUNITS'
6209       include 'COMMON.NAMES'
6210       include 'COMMON.FFIELD'
6211       include 'COMMON.CONTROL'
6212       include 'COMMON.TORCNSTR'
6213       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6214      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6215      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6216      & sinph1ph2(maxdouble,maxdouble)
6217       logical lprn /.false./, lprn1 /.false./
6218       etheta=0.0D0
6219       do i=ithet_start,ithet_end
6220 c        print *,i,itype(i-1),itype(i),itype(i-2)
6221         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6222      &  .or.itype(i).eq.ntyp1) cycle
6223 C        print *,i,theta(i)
6224         if (iabs(itype(i+1)).eq.20) iblock=2
6225         if (iabs(itype(i+1)).ne.20) iblock=1
6226         dethetai=0.0d0
6227         dephii=0.0d0
6228         dephii1=0.0d0
6229         theti2=0.5d0*theta(i)
6230         ityp2=ithetyp((itype(i-1)))
6231         do k=1,nntheterm
6232           coskt(k)=dcos(k*theti2)
6233           sinkt(k)=dsin(k*theti2)
6234         enddo
6235 C        print *,ethetai
6236         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6237 #ifdef OSF
6238           phii=phi(i)
6239           if (phii.ne.phii) phii=150.0
6240 #else
6241           phii=phi(i)
6242 #endif
6243           ityp1=ithetyp((itype(i-2)))
6244 C propagation of chirality for glycine type
6245           do k=1,nsingle
6246             cosph1(k)=dcos(k*phii)
6247             sinph1(k)=dsin(k*phii)
6248           enddo
6249         else
6250           phii=0.0d0
6251           do k=1,nsingle
6252           ityp1=ithetyp((itype(i-2)))
6253             cosph1(k)=0.0d0
6254             sinph1(k)=0.0d0
6255           enddo
6256         endif
6257         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6258 #ifdef OSF
6259           phii1=phi(i+1)
6260           if (phii1.ne.phii1) phii1=150.0
6261           phii1=pinorm(phii1)
6262 #else
6263           phii1=phi(i+1)
6264 #endif
6265           ityp3=ithetyp((itype(i)))
6266           do k=1,nsingle
6267             cosph2(k)=dcos(k*phii1)
6268             sinph2(k)=dsin(k*phii1)
6269           enddo
6270         else
6271           phii1=0.0d0
6272           ityp3=ithetyp((itype(i)))
6273           do k=1,nsingle
6274             cosph2(k)=0.0d0
6275             sinph2(k)=0.0d0
6276           enddo
6277         endif
6278         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6279         do k=1,ndouble
6280           do l=1,k-1
6281             ccl=cosph1(l)*cosph2(k-l)
6282             ssl=sinph1(l)*sinph2(k-l)
6283             scl=sinph1(l)*cosph2(k-l)
6284             csl=cosph1(l)*sinph2(k-l)
6285             cosph1ph2(l,k)=ccl-ssl
6286             cosph1ph2(k,l)=ccl+ssl
6287             sinph1ph2(l,k)=scl+csl
6288             sinph1ph2(k,l)=scl-csl
6289           enddo
6290         enddo
6291         if (lprn) then
6292         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6293      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6294         write (iout,*) "coskt and sinkt"
6295         do k=1,nntheterm
6296           write (iout,*) k,coskt(k),sinkt(k)
6297         enddo
6298         endif
6299         do k=1,ntheterm
6300           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6301           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6302      &      *coskt(k)
6303           if (lprn)
6304      &    write (iout,*) "k",k,"
6305      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6306      &     " ethetai",ethetai
6307         enddo
6308         if (lprn) then
6309         write (iout,*) "cosph and sinph"
6310         do k=1,nsingle
6311           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6312         enddo
6313         write (iout,*) "cosph1ph2 and sinph2ph2"
6314         do k=2,ndouble
6315           do l=1,k-1
6316             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6317      &         sinph1ph2(l,k),sinph1ph2(k,l)
6318           enddo
6319         enddo
6320         write(iout,*) "ethetai",ethetai
6321         endif
6322 C       print *,ethetai
6323         do m=1,ntheterm2
6324           do k=1,nsingle
6325             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6326      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6327      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6328      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6329             ethetai=ethetai+sinkt(m)*aux
6330             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6331             dephii=dephii+k*sinkt(m)*(
6332      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6333      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6334             dephii1=dephii1+k*sinkt(m)*(
6335      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6336      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6337             if (lprn)
6338      &      write (iout,*) "m",m," k",k," bbthet",
6339      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6340      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6341      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6342      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6343 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6344           enddo
6345         enddo
6346 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6347 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6348 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6349 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6350         if (lprn)
6351      &  write(iout,*) "ethetai",ethetai
6352 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6353         do m=1,ntheterm3
6354           do k=2,ndouble
6355             do l=1,k-1
6356               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6357      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6358      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6359      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6360               ethetai=ethetai+sinkt(m)*aux
6361               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6362               dephii=dephii+l*sinkt(m)*(
6363      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6364      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6365      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6366      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6367               dephii1=dephii1+(k-l)*sinkt(m)*(
6368      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6369      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6370      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6371      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6372               if (lprn) then
6373               write (iout,*) "m",m," k",k," l",l," ffthet",
6374      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6375      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6376      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6377      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6378      &            " ethetai",ethetai
6379               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6380      &            cosph1ph2(k,l)*sinkt(m),
6381      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6382               endif
6383             enddo
6384           enddo
6385         enddo
6386 10      continue
6387 c        lprn1=.true.
6388 C        print *,ethetai
6389         if (lprn1)
6390      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6391      &   i,theta(i)*rad2deg,phii*rad2deg,
6392      &   phii1*rad2deg,ethetai
6393 c        lprn1=.false.
6394         etheta=etheta+ethetai
6395         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6396         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6397         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6398       enddo
6399 C now constrains
6400       ethetacnstr=0.0d0
6401 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6402       do i=ithetaconstr_start,ithetaconstr_end
6403         itheta=itheta_constr(i)
6404         thetiii=theta(itheta)
6405         difi=pinorm(thetiii-theta_constr0(i))
6406         if (difi.gt.theta_drange(i)) then
6407           difi=difi-theta_drange(i)
6408           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6409           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6410      &    +for_thet_constr(i)*difi**3
6411         else if (difi.lt.-drange(i)) then
6412           difi=difi+drange(i)
6413           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6414           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6415      &    +for_thet_constr(i)*difi**3
6416         else
6417           difi=0.0
6418         endif
6419        if (energy_dec) then
6420         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6421      &    i,itheta,rad2deg*thetiii,
6422      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6423      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6424      &    gloc(itheta+nphi-2,icg)
6425         endif
6426       enddo
6427
6428       return
6429       end
6430 #endif
6431 #ifdef CRYST_SC
6432 c-----------------------------------------------------------------------------
6433       subroutine esc(escloc)
6434 C Calculate the local energy of a side chain and its derivatives in the
6435 C corresponding virtual-bond valence angles THETA and the spherical angles
6436 C ALPHA and OMEGA.
6437       implicit real*8 (a-h,o-z)
6438       include 'DIMENSIONS'
6439       include 'COMMON.GEO'
6440       include 'COMMON.LOCAL'
6441       include 'COMMON.VAR'
6442       include 'COMMON.INTERACT'
6443       include 'COMMON.DERIV'
6444       include 'COMMON.CHAIN'
6445       include 'COMMON.IOUNITS'
6446       include 'COMMON.NAMES'
6447       include 'COMMON.FFIELD'
6448       include 'COMMON.CONTROL'
6449       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6450      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6451       common /sccalc/ time11,time12,time112,theti,it,nlobit
6452       delta=0.02d0*pi
6453       escloc=0.0D0
6454 c     write (iout,'(a)') 'ESC'
6455       do i=loc_start,loc_end
6456         it=itype(i)
6457         if (it.eq.ntyp1) cycle
6458         if (it.eq.10) goto 1
6459         nlobit=nlob(iabs(it))
6460 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6461 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6462         theti=theta(i+1)-pipol
6463         x(1)=dtan(theti)
6464         x(2)=alph(i)
6465         x(3)=omeg(i)
6466
6467         if (x(2).gt.pi-delta) then
6468           xtemp(1)=x(1)
6469           xtemp(2)=pi-delta
6470           xtemp(3)=x(3)
6471           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6472           xtemp(2)=pi
6473           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6474           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6475      &        escloci,dersc(2))
6476           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6477      &        ddersc0(1),dersc(1))
6478           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6479      &        ddersc0(3),dersc(3))
6480           xtemp(2)=pi-delta
6481           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6482           xtemp(2)=pi
6483           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6484           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6485      &            dersc0(2),esclocbi,dersc02)
6486           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6487      &            dersc12,dersc01)
6488           call splinthet(x(2),0.5d0*delta,ss,ssd)
6489           dersc0(1)=dersc01
6490           dersc0(2)=dersc02
6491           dersc0(3)=0.0d0
6492           do k=1,3
6493             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6494           enddo
6495           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6496 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6497 c    &             esclocbi,ss,ssd
6498           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6499 c         escloci=esclocbi
6500 c         write (iout,*) escloci
6501         else if (x(2).lt.delta) then
6502           xtemp(1)=x(1)
6503           xtemp(2)=delta
6504           xtemp(3)=x(3)
6505           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6506           xtemp(2)=0.0d0
6507           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6508           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6509      &        escloci,dersc(2))
6510           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6511      &        ddersc0(1),dersc(1))
6512           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6513      &        ddersc0(3),dersc(3))
6514           xtemp(2)=delta
6515           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6516           xtemp(2)=0.0d0
6517           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6518           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6519      &            dersc0(2),esclocbi,dersc02)
6520           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6521      &            dersc12,dersc01)
6522           dersc0(1)=dersc01
6523           dersc0(2)=dersc02
6524           dersc0(3)=0.0d0
6525           call splinthet(x(2),0.5d0*delta,ss,ssd)
6526           do k=1,3
6527             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6528           enddo
6529           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6530 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6531 c    &             esclocbi,ss,ssd
6532           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6533 c         write (iout,*) escloci
6534         else
6535           call enesc(x,escloci,dersc,ddummy,.false.)
6536         endif
6537
6538         escloc=escloc+escloci
6539         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6540      &     'escloc',i,escloci
6541 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6542
6543         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6544      &   wscloc*dersc(1)
6545         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6546         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6547     1   continue
6548       enddo
6549       return
6550       end
6551 C---------------------------------------------------------------------------
6552       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6553       implicit real*8 (a-h,o-z)
6554       include 'DIMENSIONS'
6555       include 'COMMON.GEO'
6556       include 'COMMON.LOCAL'
6557       include 'COMMON.IOUNITS'
6558       common /sccalc/ time11,time12,time112,theti,it,nlobit
6559       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6560       double precision contr(maxlob,-1:1)
6561       logical mixed
6562 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6563         escloc_i=0.0D0
6564         do j=1,3
6565           dersc(j)=0.0D0
6566           if (mixed) ddersc(j)=0.0d0
6567         enddo
6568         x3=x(3)
6569
6570 C Because of periodicity of the dependence of the SC energy in omega we have
6571 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6572 C To avoid underflows, first compute & store the exponents.
6573
6574         do iii=-1,1
6575
6576           x(3)=x3+iii*dwapi
6577
6578           do j=1,nlobit
6579             do k=1,3
6580               z(k)=x(k)-censc(k,j,it)
6581             enddo
6582             do k=1,3
6583               Axk=0.0D0
6584               do l=1,3
6585                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6586               enddo
6587               Ax(k,j,iii)=Axk
6588             enddo
6589             expfac=0.0D0
6590             do k=1,3
6591               expfac=expfac+Ax(k,j,iii)*z(k)
6592             enddo
6593             contr(j,iii)=expfac
6594           enddo ! j
6595
6596         enddo ! iii
6597
6598         x(3)=x3
6599 C As in the case of ebend, we want to avoid underflows in exponentiation and
6600 C subsequent NaNs and INFs in energy calculation.
6601 C Find the largest exponent
6602         emin=contr(1,-1)
6603         do iii=-1,1
6604           do j=1,nlobit
6605             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6606           enddo
6607         enddo
6608         emin=0.5D0*emin
6609 cd      print *,'it=',it,' emin=',emin
6610
6611 C Compute the contribution to SC energy and derivatives
6612         do iii=-1,1
6613
6614           do j=1,nlobit
6615 #ifdef OSF
6616             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6617             if(adexp.ne.adexp) adexp=1.0
6618             expfac=dexp(adexp)
6619 #else
6620             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6621 #endif
6622 cd          print *,'j=',j,' expfac=',expfac
6623             escloc_i=escloc_i+expfac
6624             do k=1,3
6625               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6626             enddo
6627             if (mixed) then
6628               do k=1,3,2
6629                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6630      &            +gaussc(k,2,j,it))*expfac
6631               enddo
6632             endif
6633           enddo
6634
6635         enddo ! iii
6636
6637         dersc(1)=dersc(1)/cos(theti)**2
6638         ddersc(1)=ddersc(1)/cos(theti)**2
6639         ddersc(3)=ddersc(3)
6640
6641         escloci=-(dlog(escloc_i)-emin)
6642         do j=1,3
6643           dersc(j)=dersc(j)/escloc_i
6644         enddo
6645         if (mixed) then
6646           do j=1,3,2
6647             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6648           enddo
6649         endif
6650       return
6651       end
6652 C------------------------------------------------------------------------------
6653       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6654       implicit real*8 (a-h,o-z)
6655       include 'DIMENSIONS'
6656       include 'COMMON.GEO'
6657       include 'COMMON.LOCAL'
6658       include 'COMMON.IOUNITS'
6659       common /sccalc/ time11,time12,time112,theti,it,nlobit
6660       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6661       double precision contr(maxlob)
6662       logical mixed
6663
6664       escloc_i=0.0D0
6665
6666       do j=1,3
6667         dersc(j)=0.0D0
6668       enddo
6669
6670       do j=1,nlobit
6671         do k=1,2
6672           z(k)=x(k)-censc(k,j,it)
6673         enddo
6674         z(3)=dwapi
6675         do k=1,3
6676           Axk=0.0D0
6677           do l=1,3
6678             Axk=Axk+gaussc(l,k,j,it)*z(l)
6679           enddo
6680           Ax(k,j)=Axk
6681         enddo
6682         expfac=0.0D0
6683         do k=1,3
6684           expfac=expfac+Ax(k,j)*z(k)
6685         enddo
6686         contr(j)=expfac
6687       enddo ! j
6688
6689 C As in the case of ebend, we want to avoid underflows in exponentiation and
6690 C subsequent NaNs and INFs in energy calculation.
6691 C Find the largest exponent
6692       emin=contr(1)
6693       do j=1,nlobit
6694         if (emin.gt.contr(j)) emin=contr(j)
6695       enddo
6696       emin=0.5D0*emin
6697
6698 C Compute the contribution to SC energy and derivatives
6699
6700       dersc12=0.0d0
6701       do j=1,nlobit
6702         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6703         escloc_i=escloc_i+expfac
6704         do k=1,2
6705           dersc(k)=dersc(k)+Ax(k,j)*expfac
6706         enddo
6707         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6708      &            +gaussc(1,2,j,it))*expfac
6709         dersc(3)=0.0d0
6710       enddo
6711
6712       dersc(1)=dersc(1)/cos(theti)**2
6713       dersc12=dersc12/cos(theti)**2
6714       escloci=-(dlog(escloc_i)-emin)
6715       do j=1,2
6716         dersc(j)=dersc(j)/escloc_i
6717       enddo
6718       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6719       return
6720       end
6721 #else
6722 c----------------------------------------------------------------------------------
6723       subroutine esc(escloc)
6724 C Calculate the local energy of a side chain and its derivatives in the
6725 C corresponding virtual-bond valence angles THETA and the spherical angles
6726 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6727 C added by Urszula Kozlowska. 07/11/2007
6728 C
6729       implicit real*8 (a-h,o-z)
6730       include 'DIMENSIONS'
6731       include 'COMMON.GEO'
6732       include 'COMMON.LOCAL'
6733       include 'COMMON.VAR'
6734       include 'COMMON.SCROT'
6735       include 'COMMON.INTERACT'
6736       include 'COMMON.DERIV'
6737       include 'COMMON.CHAIN'
6738       include 'COMMON.IOUNITS'
6739       include 'COMMON.NAMES'
6740       include 'COMMON.FFIELD'
6741       include 'COMMON.CONTROL'
6742       include 'COMMON.VECTORS'
6743       double precision x_prime(3),y_prime(3),z_prime(3)
6744      &    , sumene,dsc_i,dp2_i,x(65),
6745      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6746      &    de_dxx,de_dyy,de_dzz,de_dt
6747       double precision s1_t,s1_6_t,s2_t,s2_6_t
6748       double precision
6749      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6750      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6751      & dt_dCi(3),dt_dCi1(3)
6752       common /sccalc/ time11,time12,time112,theti,it,nlobit
6753       delta=0.02d0*pi
6754       escloc=0.0D0
6755       do i=loc_start,loc_end
6756         if (itype(i).eq.ntyp1) cycle
6757         costtab(i+1) =dcos(theta(i+1))
6758         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6759         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6760         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6761         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6762         cosfac=dsqrt(cosfac2)
6763         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6764         sinfac=dsqrt(sinfac2)
6765         it=iabs(itype(i))
6766         if (it.eq.10) goto 1
6767 c
6768 C  Compute the axes of tghe local cartesian coordinates system; store in
6769 c   x_prime, y_prime and z_prime
6770 c
6771         do j=1,3
6772           x_prime(j) = 0.00
6773           y_prime(j) = 0.00
6774           z_prime(j) = 0.00
6775         enddo
6776 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6777 C     &   dc_norm(3,i+nres)
6778         do j = 1,3
6779           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6780           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6781         enddo
6782         do j = 1,3
6783           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6784         enddo
6785 c       write (2,*) "i",i
6786 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6787 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6788 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6789 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6790 c      & " xy",scalar(x_prime(1),y_prime(1)),
6791 c      & " xz",scalar(x_prime(1),z_prime(1)),
6792 c      & " yy",scalar(y_prime(1),y_prime(1)),
6793 c      & " yz",scalar(y_prime(1),z_prime(1)),
6794 c      & " zz",scalar(z_prime(1),z_prime(1))
6795 c
6796 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6797 C to local coordinate system. Store in xx, yy, zz.
6798 c
6799         xx=0.0d0
6800         yy=0.0d0
6801         zz=0.0d0
6802         do j = 1,3
6803           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6804           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6805           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6806         enddo
6807
6808         xxtab(i)=xx
6809         yytab(i)=yy
6810         zztab(i)=zz
6811 C
6812 C Compute the energy of the ith side cbain
6813 C
6814 c        write (2,*) "xx",xx," yy",yy," zz",zz
6815         it=iabs(itype(i))
6816         do j = 1,65
6817           x(j) = sc_parmin(j,it)
6818         enddo
6819 #ifdef CHECK_COORD
6820 Cc diagnostics - remove later
6821         xx1 = dcos(alph(2))
6822         yy1 = dsin(alph(2))*dcos(omeg(2))
6823         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6824         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6825      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6826      &    xx1,yy1,zz1
6827 C,"  --- ", xx_w,yy_w,zz_w
6828 c end diagnostics
6829 #endif
6830         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6831      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6832      &   + x(10)*yy*zz
6833         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6834      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6835      & + x(20)*yy*zz
6836         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6837      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6838      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6839      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6840      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6841      &  +x(40)*xx*yy*zz
6842         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6843      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6844      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6845      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6846      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6847      &  +x(60)*xx*yy*zz
6848         dsc_i   = 0.743d0+x(61)
6849         dp2_i   = 1.9d0+x(62)
6850         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6851      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6852         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6853      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6854         s1=(1+x(63))/(0.1d0 + dscp1)
6855         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6856         s2=(1+x(65))/(0.1d0 + dscp2)
6857         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6858         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6859      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6860 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6861 c     &   sumene4,
6862 c     &   dscp1,dscp2,sumene
6863 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6864         escloc = escloc + sumene
6865 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6866 c     & ,zz,xx,yy
6867 c#define DEBUG
6868 #ifdef DEBUG
6869 C
6870 C This section to check the numerical derivatives of the energy of ith side
6871 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6872 C #define DEBUG in the code to turn it on.
6873 C
6874         write (2,*) "sumene               =",sumene
6875         aincr=1.0d-7
6876         xxsave=xx
6877         xx=xx+aincr
6878         write (2,*) xx,yy,zz
6879         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6880         de_dxx_num=(sumenep-sumene)/aincr
6881         xx=xxsave
6882         write (2,*) "xx+ sumene from enesc=",sumenep
6883         yysave=yy
6884         yy=yy+aincr
6885         write (2,*) xx,yy,zz
6886         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6887         de_dyy_num=(sumenep-sumene)/aincr
6888         yy=yysave
6889         write (2,*) "yy+ sumene from enesc=",sumenep
6890         zzsave=zz
6891         zz=zz+aincr
6892         write (2,*) xx,yy,zz
6893         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6894         de_dzz_num=(sumenep-sumene)/aincr
6895         zz=zzsave
6896         write (2,*) "zz+ sumene from enesc=",sumenep
6897         costsave=cost2tab(i+1)
6898         sintsave=sint2tab(i+1)
6899         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6900         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6901         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6902         de_dt_num=(sumenep-sumene)/aincr
6903         write (2,*) " t+ sumene from enesc=",sumenep
6904         cost2tab(i+1)=costsave
6905         sint2tab(i+1)=sintsave
6906 C End of diagnostics section.
6907 #endif
6908 C
6909 C Compute the gradient of esc
6910 C
6911 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6912         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6913         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6914         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6915         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6916         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6917         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6918         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6919         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6920         pom1=(sumene3*sint2tab(i+1)+sumene1)
6921      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6922         pom2=(sumene4*cost2tab(i+1)+sumene2)
6923      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6924         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6925         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6926      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6927      &  +x(40)*yy*zz
6928         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6929         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6930      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6931      &  +x(60)*yy*zz
6932         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6933      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6934      &        +(pom1+pom2)*pom_dx
6935 #ifdef DEBUG
6936         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6937 #endif
6938 C
6939         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6940         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6941      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6942      &  +x(40)*xx*zz
6943         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6944         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6945      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6946      &  +x(59)*zz**2 +x(60)*xx*zz
6947         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6948      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6949      &        +(pom1-pom2)*pom_dy
6950 #ifdef DEBUG
6951         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6952 #endif
6953 C
6954         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6955      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6956      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6957      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6958      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6959      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6960      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6961      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6962 #ifdef DEBUG
6963         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6964 #endif
6965 C
6966         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6967      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6968      &  +pom1*pom_dt1+pom2*pom_dt2
6969 #ifdef DEBUG
6970         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6971 #endif
6972 c#undef DEBUG
6973 c
6974 C
6975        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6976        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6977        cosfac2xx=cosfac2*xx
6978        sinfac2yy=sinfac2*yy
6979        do k = 1,3
6980          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6981      &      vbld_inv(i+1)
6982          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6983      &      vbld_inv(i)
6984          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6985          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6986 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6987 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6988 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6989 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6990          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6991          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6992          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6993          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6994          dZZ_Ci1(k)=0.0d0
6995          dZZ_Ci(k)=0.0d0
6996          do j=1,3
6997            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6998      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6999            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7000      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7001          enddo
7002
7003          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7004          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7005          dZZ_XYZ(k)=vbld_inv(i+nres)*
7006      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7007 c
7008          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7009          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7010        enddo
7011
7012        do k=1,3
7013          dXX_Ctab(k,i)=dXX_Ci(k)
7014          dXX_C1tab(k,i)=dXX_Ci1(k)
7015          dYY_Ctab(k,i)=dYY_Ci(k)
7016          dYY_C1tab(k,i)=dYY_Ci1(k)
7017          dZZ_Ctab(k,i)=dZZ_Ci(k)
7018          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7019          dXX_XYZtab(k,i)=dXX_XYZ(k)
7020          dYY_XYZtab(k,i)=dYY_XYZ(k)
7021          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7022        enddo
7023
7024        do k = 1,3
7025 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7026 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7027 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7028 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7029 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7030 c     &    dt_dci(k)
7031 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7032 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7033          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7034      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7035          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7036      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7037          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7038      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7039        enddo
7040 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7041 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7042
7043 C to check gradient call subroutine check_grad
7044
7045     1 continue
7046       enddo
7047       return
7048       end
7049 c------------------------------------------------------------------------------
7050       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7051       implicit none
7052       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7053      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7054       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7055      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7056      &   + x(10)*yy*zz
7057       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7058      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7059      & + x(20)*yy*zz
7060       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7061      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7062      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7063      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7064      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7065      &  +x(40)*xx*yy*zz
7066       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7067      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7068      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7069      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7070      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7071      &  +x(60)*xx*yy*zz
7072       dsc_i   = 0.743d0+x(61)
7073       dp2_i   = 1.9d0+x(62)
7074       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7075      &          *(xx*cost2+yy*sint2))
7076       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7077      &          *(xx*cost2-yy*sint2))
7078       s1=(1+x(63))/(0.1d0 + dscp1)
7079       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7080       s2=(1+x(65))/(0.1d0 + dscp2)
7081       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7082       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7083      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7084       enesc=sumene
7085       return
7086       end
7087 #endif
7088 c------------------------------------------------------------------------------
7089       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7090 C
7091 C This procedure calculates two-body contact function g(rij) and its derivative:
7092 C
7093 C           eps0ij                                     !       x < -1
7094 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7095 C            0                                         !       x > 1
7096 C
7097 C where x=(rij-r0ij)/delta
7098 C
7099 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7100 C
7101       implicit none
7102       double precision rij,r0ij,eps0ij,fcont,fprimcont
7103       double precision x,x2,x4,delta
7104 c     delta=0.02D0*r0ij
7105 c      delta=0.2D0*r0ij
7106       x=(rij-r0ij)/delta
7107       if (x.lt.-1.0D0) then
7108         fcont=eps0ij
7109         fprimcont=0.0D0
7110       else if (x.le.1.0D0) then
7111         x2=x*x
7112         x4=x2*x2
7113         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7114         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7115       else
7116         fcont=0.0D0
7117         fprimcont=0.0D0
7118       endif
7119       return
7120       end
7121 c------------------------------------------------------------------------------
7122       subroutine splinthet(theti,delta,ss,ssder)
7123       implicit real*8 (a-h,o-z)
7124       include 'DIMENSIONS'
7125       include 'COMMON.VAR'
7126       include 'COMMON.GEO'
7127       thetup=pi-delta
7128       thetlow=delta
7129       if (theti.gt.pipol) then
7130         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7131       else
7132         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7133         ssder=-ssder
7134       endif
7135       return
7136       end
7137 c------------------------------------------------------------------------------
7138       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7139       implicit none
7140       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7141       double precision ksi,ksi2,ksi3,a1,a2,a3
7142       a1=fprim0*delta/(f1-f0)
7143       a2=3.0d0-2.0d0*a1
7144       a3=a1-2.0d0
7145       ksi=(x-x0)/delta
7146       ksi2=ksi*ksi
7147       ksi3=ksi2*ksi
7148       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7149       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7150       return
7151       end
7152 c------------------------------------------------------------------------------
7153       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7154       implicit none
7155       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7156       double precision ksi,ksi2,ksi3,a1,a2,a3
7157       ksi=(x-x0)/delta
7158       ksi2=ksi*ksi
7159       ksi3=ksi2*ksi
7160       a1=fprim0x*delta
7161       a2=3*(f1x-f0x)-2*fprim0x*delta
7162       a3=fprim0x*delta-2*(f1x-f0x)
7163       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7164       return
7165       end
7166 C-----------------------------------------------------------------------------
7167 #ifdef CRYST_TOR
7168 C-----------------------------------------------------------------------------
7169       subroutine etor(etors,edihcnstr)
7170       implicit real*8 (a-h,o-z)
7171       include 'DIMENSIONS'
7172       include 'COMMON.VAR'
7173       include 'COMMON.GEO'
7174       include 'COMMON.LOCAL'
7175       include 'COMMON.TORSION'
7176       include 'COMMON.INTERACT'
7177       include 'COMMON.DERIV'
7178       include 'COMMON.CHAIN'
7179       include 'COMMON.NAMES'
7180       include 'COMMON.IOUNITS'
7181       include 'COMMON.FFIELD'
7182       include 'COMMON.TORCNSTR'
7183       include 'COMMON.CONTROL'
7184       logical lprn
7185 C Set lprn=.true. for debugging
7186       lprn=.false.
7187 c      lprn=.true.
7188       etors=0.0D0
7189       do i=iphi_start,iphi_end
7190       etors_ii=0.0D0
7191         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7192      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7193         itori=itortyp(itype(i-2))
7194         itori1=itortyp(itype(i-1))
7195         phii=phi(i)
7196         gloci=0.0D0
7197 C Proline-Proline pair is a special case...
7198         if (itori.eq.3 .and. itori1.eq.3) then
7199           if (phii.gt.-dwapi3) then
7200             cosphi=dcos(3*phii)
7201             fac=1.0D0/(1.0D0-cosphi)
7202             etorsi=v1(1,3,3)*fac
7203             etorsi=etorsi+etorsi
7204             etors=etors+etorsi-v1(1,3,3)
7205             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7206             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7207           endif
7208           do j=1,3
7209             v1ij=v1(j+1,itori,itori1)
7210             v2ij=v2(j+1,itori,itori1)
7211             cosphi=dcos(j*phii)
7212             sinphi=dsin(j*phii)
7213             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7214             if (energy_dec) etors_ii=etors_ii+
7215      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7216             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7217           enddo
7218         else
7219           do j=1,nterm_old
7220             v1ij=v1(j,itori,itori1)
7221             v2ij=v2(j,itori,itori1)
7222             cosphi=dcos(j*phii)
7223             sinphi=dsin(j*phii)
7224             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7225             if (energy_dec) etors_ii=etors_ii+
7226      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7227             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7228           enddo
7229         endif
7230         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7231              'etor',i,etors_ii
7232         if (lprn)
7233      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7234      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7235      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7236         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7237 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7238       enddo
7239 ! 6/20/98 - dihedral angle constraints
7240       edihcnstr=0.0d0
7241       do i=1,ndih_constr
7242         itori=idih_constr(i)
7243         phii=phi(itori)
7244         difi=phii-phi0(i)
7245         if (difi.gt.drange(i)) then
7246           difi=difi-drange(i)
7247           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7248           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7249         else if (difi.lt.-drange(i)) then
7250           difi=difi+drange(i)
7251           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7252           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7253         endif
7254 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7255 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7256       enddo
7257 !      write (iout,*) 'edihcnstr',edihcnstr
7258       return
7259       end
7260 c------------------------------------------------------------------------------
7261       subroutine etor_d(etors_d)
7262       etors_d=0.0d0
7263       return
7264       end
7265 c----------------------------------------------------------------------------
7266 #else
7267       subroutine etor(etors,edihcnstr)
7268       implicit real*8 (a-h,o-z)
7269       include 'DIMENSIONS'
7270       include 'COMMON.VAR'
7271       include 'COMMON.GEO'
7272       include 'COMMON.LOCAL'
7273       include 'COMMON.TORSION'
7274       include 'COMMON.INTERACT'
7275       include 'COMMON.DERIV'
7276       include 'COMMON.CHAIN'
7277       include 'COMMON.NAMES'
7278       include 'COMMON.IOUNITS'
7279       include 'COMMON.FFIELD'
7280       include 'COMMON.TORCNSTR'
7281       include 'COMMON.CONTROL'
7282       logical lprn
7283 C Set lprn=.true. for debugging
7284       lprn=.false.
7285 c     lprn=.true.
7286       etors=0.0D0
7287       do i=iphi_start,iphi_end
7288 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7289 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7290 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7291 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7292         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7293      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7294 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7295 C For introducing the NH3+ and COO- group please check the etor_d for reference
7296 C and guidance
7297         etors_ii=0.0D0
7298          if (iabs(itype(i)).eq.20) then
7299          iblock=2
7300          else
7301          iblock=1
7302          endif
7303         itori=itortyp(itype(i-2))
7304         itori1=itortyp(itype(i-1))
7305         phii=phi(i)
7306         gloci=0.0D0
7307 C Regular cosine and sine terms
7308         do j=1,nterm(itori,itori1,iblock)
7309           v1ij=v1(j,itori,itori1,iblock)
7310           v2ij=v2(j,itori,itori1,iblock)
7311           cosphi=dcos(j*phii)
7312           sinphi=dsin(j*phii)
7313           etors=etors+v1ij*cosphi+v2ij*sinphi
7314           if (energy_dec) etors_ii=etors_ii+
7315      &                v1ij*cosphi+v2ij*sinphi
7316           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7317         enddo
7318 C Lorentz terms
7319 C                         v1
7320 C  E = SUM ----------------------------------- - v1
7321 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7322 C
7323         cosphi=dcos(0.5d0*phii)
7324         sinphi=dsin(0.5d0*phii)
7325         do j=1,nlor(itori,itori1,iblock)
7326           vl1ij=vlor1(j,itori,itori1)
7327           vl2ij=vlor2(j,itori,itori1)
7328           vl3ij=vlor3(j,itori,itori1)
7329           pom=vl2ij*cosphi+vl3ij*sinphi
7330           pom1=1.0d0/(pom*pom+1.0d0)
7331           etors=etors+vl1ij*pom1
7332           if (energy_dec) etors_ii=etors_ii+
7333      &                vl1ij*pom1
7334           pom=-pom*pom1*pom1
7335           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7336         enddo
7337 C Subtract the constant term
7338         etors=etors-v0(itori,itori1,iblock)
7339           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7340      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7341         if (lprn)
7342      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7343      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7344      &  (v1(j,itori,itori1,iblock),j=1,6),
7345      &  (v2(j,itori,itori1,iblock),j=1,6)
7346         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7347 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7348       enddo
7349 ! 6/20/98 - dihedral angle constraints
7350       edihcnstr=0.0d0
7351 c      do i=1,ndih_constr
7352       do i=idihconstr_start,idihconstr_end
7353         itori=idih_constr(i)
7354         phii=phi(itori)
7355         difi=pinorm(phii-phi0(i))
7356         if (difi.gt.drange(i)) then
7357           difi=difi-drange(i)
7358           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7359           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7360         else if (difi.lt.-drange(i)) then
7361           difi=difi+drange(i)
7362           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7363           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7364         else
7365           difi=0.0
7366         endif
7367        if (energy_dec) then
7368         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7369      &    i,itori,rad2deg*phii,
7370      &    rad2deg*phi0(i),  rad2deg*drange(i),
7371      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7372         endif
7373       enddo
7374 cd       write (iout,*) 'edihcnstr',edihcnstr
7375       return
7376       end
7377 c----------------------------------------------------------------------------
7378       subroutine etor_d(etors_d)
7379 C 6/23/01 Compute double torsional energy
7380       implicit real*8 (a-h,o-z)
7381       include 'DIMENSIONS'
7382       include 'COMMON.VAR'
7383       include 'COMMON.GEO'
7384       include 'COMMON.LOCAL'
7385       include 'COMMON.TORSION'
7386       include 'COMMON.INTERACT'
7387       include 'COMMON.DERIV'
7388       include 'COMMON.CHAIN'
7389       include 'COMMON.NAMES'
7390       include 'COMMON.IOUNITS'
7391       include 'COMMON.FFIELD'
7392       include 'COMMON.TORCNSTR'
7393       logical lprn
7394 C Set lprn=.true. for debugging
7395       lprn=.false.
7396 c     lprn=.true.
7397       etors_d=0.0D0
7398 c      write(iout,*) "a tu??"
7399       do i=iphid_start,iphid_end
7400 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7401 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7402 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7403 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7404 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7405          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7406      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7407      &  (itype(i+1).eq.ntyp1)) cycle
7408 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7409         itori=itortyp(itype(i-2))
7410         itori1=itortyp(itype(i-1))
7411         itori2=itortyp(itype(i))
7412         phii=phi(i)
7413         phii1=phi(i+1)
7414         gloci1=0.0D0
7415         gloci2=0.0D0
7416         iblock=1
7417         if (iabs(itype(i+1)).eq.20) iblock=2
7418 C Iblock=2 Proline type
7419 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7420 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7421 C        if (itype(i+1).eq.ntyp1) iblock=3
7422 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7423 C IS or IS NOT need for this
7424 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7425 C        is (itype(i-3).eq.ntyp1) ntblock=2
7426 C        ntblock is N-terminal blocking group
7427
7428 C Regular cosine and sine terms
7429         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7430 C Example of changes for NH3+ blocking group
7431 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7432 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7433           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7434           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7435           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7436           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7437           cosphi1=dcos(j*phii)
7438           sinphi1=dsin(j*phii)
7439           cosphi2=dcos(j*phii1)
7440           sinphi2=dsin(j*phii1)
7441           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7442      &     v2cij*cosphi2+v2sij*sinphi2
7443           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7444           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7445         enddo
7446         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7447           do l=1,k-1
7448             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7449             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7450             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7451             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7452             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7453             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7454             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7455             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7456             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7457      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7458             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7459      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7460             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7461      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7462           enddo
7463         enddo
7464         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7465         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7466       enddo
7467       return
7468       end
7469 #endif
7470 C----------------------------------------------------------------------------------
7471 C The rigorous attempt to derive energy function
7472       subroutine etor_kcc(etors,edihcnstr)
7473       implicit real*8 (a-h,o-z)
7474       include 'DIMENSIONS'
7475       include 'COMMON.VAR'
7476       include 'COMMON.GEO'
7477       include 'COMMON.LOCAL'
7478       include 'COMMON.TORSION'
7479       include 'COMMON.INTERACT'
7480       include 'COMMON.DERIV'
7481       include 'COMMON.CHAIN'
7482       include 'COMMON.NAMES'
7483       include 'COMMON.IOUNITS'
7484       include 'COMMON.FFIELD'
7485       include 'COMMON.TORCNSTR'
7486       include 'COMMON.CONTROL'
7487       logical lprn
7488 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7489 C Set lprn=.true. for debugging
7490       lprn=.false.
7491 c     lprn=.true.
7492 C      print *,"wchodze kcc"
7493       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7494       if (tor_mode.ne.2) then
7495       etors=0.0D0
7496       endif
7497       do i=iphi_start,iphi_end
7498 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7499 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7500 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7501 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7502         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7503      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7504         itori=itortyp_kcc(itype(i-2))
7505         itori1=itortyp_kcc(itype(i-1))
7506         phii=phi(i)
7507         glocig=0.0D0
7508         glocit1=0.0d0
7509         glocit2=0.0d0
7510         sumnonchebyshev=0.0d0
7511         sumchebyshev=0.0d0
7512 C to avoid multiple devision by 2
7513 c        theti22=0.5d0*theta(i)
7514 C theta 12 is the theta_1 /2
7515 C theta 22 is theta_2 /2
7516 c        theti12=0.5d0*theta(i-1)
7517 C and appropriate sinus function
7518         sinthet1=dsin(theta(i-1))
7519         sinthet2=dsin(theta(i))
7520         costhet1=dcos(theta(i-1))
7521         costhet2=dcos(theta(i))
7522 c Cosines of halves thetas
7523         costheti12=0.5d0*(1.0d0+costhet1)
7524         costheti22=0.5d0*(1.0d0+costhet2)
7525 C to speed up lets store its mutliplication
7526         sint1t2=sinthet2*sinthet1
7527         sint1t2n=1.0d0
7528 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7529 C +d_n*sin(n*gamma)) *
7530 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7531 C we have two sum 1) Non-Chebyshev which is with n and gamma
7532         etori=0.0d0
7533         do j=1,nterm_kcc(itori,itori1)
7534
7535           nval=nterm_kcc_Tb(itori,itori1)
7536           v1ij=v1_kcc(j,itori,itori1)
7537           v2ij=v2_kcc(j,itori,itori1)
7538 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7539 C v1ij is c_n and d_n in euation above
7540           cosphi=dcos(j*phii)
7541           sinphi=dsin(j*phii)
7542           sint1t2n1=sint1t2n
7543           sint1t2n=sint1t2n*sint1t2
7544           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7545      &        costheti12)
7546           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7547      &        v11_chyb(1,j,itori,itori1),costheti12)
7548 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7549 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7550           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7551      &        costheti22)
7552           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7553      &        v21_chyb(1,j,itori,itori1),costheti22)
7554 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7555 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7556           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7557      &        costheti12)
7558           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7559      &        v12_chyb(1,j,itori,itori1),costheti12)
7560 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7561 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7562           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7563      &        costheti22)
7564           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7565      &        v22_chyb(1,j,itori,itori1),costheti22)
7566 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7567 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7568 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7569 C          if (energy_dec) etors_ii=etors_ii+
7570 C     &                v1ij*cosphi+v2ij*sinphi
7571 C glocig is the gradient local i site in gamma
7572           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7573           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7574           etori=etori+sint1t2n*(actval1+actval2)
7575           glocig=glocig+
7576      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7577      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7578 C now gradient over theta_1
7579           glocit1=glocit1+
7580      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7581      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7582           glocit2=glocit2+
7583      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7584      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7585
7586 C now the Czebyshev polinominal sum
7587 c        do k=1,nterm_kcc_Tb(itori,itori1)
7588 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7589 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7590 C         thybt1(k)=0.0
7591 C         thybt2(k)=0.0
7592 c        enddo
7593 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7594 C     &         gradtschebyshev
7595 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7596 C     &         dcos(theti22)**2),
7597 C     &         dsin(theti22)
7598
7599 C now overal sumation
7600 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7601         enddo ! j
7602         etors=etors+etori
7603 C derivative over gamma
7604         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7605 C derivative over theta1
7606         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7607 C now derivative over theta2
7608         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7609         if (lprn)
7610      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7611      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7612       enddo
7613 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7614 ! 6/20/98 - dihedral angle constraints
7615       if (tor_mode.ne.2) then
7616       edihcnstr=0.0d0
7617 c      do i=1,ndih_constr
7618       do i=idihconstr_start,idihconstr_end
7619         itori=idih_constr(i)
7620         phii=phi(itori)
7621         difi=pinorm(phii-phi0(i))
7622         if (difi.gt.drange(i)) then
7623           difi=difi-drange(i)
7624           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7625           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7626         else if (difi.lt.-drange(i)) then
7627           difi=difi+drange(i)
7628           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7629           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7630         else
7631           difi=0.0
7632         endif
7633        enddo
7634        endif
7635       return
7636       end
7637
7638 C The rigorous attempt to derive energy function
7639       subroutine ebend_kcc(etheta,ethetacnstr)
7640
7641       implicit real*8 (a-h,o-z)
7642       include 'DIMENSIONS'
7643       include 'COMMON.VAR'
7644       include 'COMMON.GEO'
7645       include 'COMMON.LOCAL'
7646       include 'COMMON.TORSION'
7647       include 'COMMON.INTERACT'
7648       include 'COMMON.DERIV'
7649       include 'COMMON.CHAIN'
7650       include 'COMMON.NAMES'
7651       include 'COMMON.IOUNITS'
7652       include 'COMMON.FFIELD'
7653       include 'COMMON.TORCNSTR'
7654       include 'COMMON.CONTROL'
7655       logical lprn
7656       double precision thybt1(maxtermkcc)
7657 C Set lprn=.true. for debugging
7658       lprn=.false.
7659 c     lprn=.true.
7660 C      print *,"wchodze kcc"
7661       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7662       if (tor_mode.ne.2) etheta=0.0D0
7663       do i=ithet_start,ithet_end
7664 c        print *,i,itype(i-1),itype(i),itype(i-2)
7665         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7666      &  .or.itype(i).eq.ntyp1) cycle
7667          iti=itortyp_kcc(itype(i-1))
7668         sinthet=dsin(theta(i)/2.0d0)
7669         costhet=dcos(theta(i)/2.0d0)
7670          do j=1,nbend_kcc_Tb(iti)
7671           thybt1(j)=v1bend_chyb(j,iti)
7672          enddo
7673          sumth1thyb=tschebyshev
7674      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7675         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7676      &    sumth1thyb
7677         ihelp=nbend_kcc_Tb(iti)-1
7678         gradthybt1=gradtschebyshev
7679      &         (0,ihelp,thybt1(1),costhet)
7680         etheta=etheta+sumth1thyb
7681 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7682         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7683      &   gradthybt1*sinthet*(-0.5d0)
7684       enddo
7685       if (tor_mode.ne.2) then
7686       ethetacnstr=0.0d0
7687 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7688       do i=ithetaconstr_start,ithetaconstr_end
7689         itheta=itheta_constr(i)
7690         thetiii=theta(itheta)
7691         difi=pinorm(thetiii-theta_constr0(i))
7692         if (difi.gt.theta_drange(i)) then
7693           difi=difi-theta_drange(i)
7694           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7695           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7696      &    +for_thet_constr(i)*difi**3
7697         else if (difi.lt.-drange(i)) then
7698           difi=difi+drange(i)
7699           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7700           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7701      &    +for_thet_constr(i)*difi**3
7702         else
7703           difi=0.0
7704         endif
7705        if (energy_dec) then
7706         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7707      &    i,itheta,rad2deg*thetiii,
7708      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7709      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7710      &    gloc(itheta+nphi-2,icg)
7711         endif
7712       enddo
7713       endif
7714       return
7715       end
7716 c------------------------------------------------------------------------------
7717       subroutine eback_sc_corr(esccor)
7718 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7719 c        conformational states; temporarily implemented as differences
7720 c        between UNRES torsional potentials (dependent on three types of
7721 c        residues) and the torsional potentials dependent on all 20 types
7722 c        of residues computed from AM1  energy surfaces of terminally-blocked
7723 c        amino-acid residues.
7724       implicit real*8 (a-h,o-z)
7725       include 'DIMENSIONS'
7726       include 'COMMON.VAR'
7727       include 'COMMON.GEO'
7728       include 'COMMON.LOCAL'
7729       include 'COMMON.TORSION'
7730       include 'COMMON.SCCOR'
7731       include 'COMMON.INTERACT'
7732       include 'COMMON.DERIV'
7733       include 'COMMON.CHAIN'
7734       include 'COMMON.NAMES'
7735       include 'COMMON.IOUNITS'
7736       include 'COMMON.FFIELD'
7737       include 'COMMON.CONTROL'
7738       logical lprn
7739 C Set lprn=.true. for debugging
7740       lprn=.false.
7741 c      lprn=.true.
7742 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7743       esccor=0.0D0
7744       do i=itau_start,itau_end
7745         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7746         esccor_ii=0.0D0
7747         isccori=isccortyp(itype(i-2))
7748         isccori1=isccortyp(itype(i-1))
7749 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7750         phii=phi(i)
7751         do intertyp=1,3 !intertyp
7752 cc Added 09 May 2012 (Adasko)
7753 cc  Intertyp means interaction type of backbone mainchain correlation:
7754 c   1 = SC...Ca...Ca...Ca
7755 c   2 = Ca...Ca...Ca...SC
7756 c   3 = SC...Ca...Ca...SCi
7757         gloci=0.0D0
7758         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7759      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7760      &      (itype(i-1).eq.ntyp1)))
7761      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7762      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7763      &     .or.(itype(i).eq.ntyp1)))
7764      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7765      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7766      &      (itype(i-3).eq.ntyp1)))) cycle
7767         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7768         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7769      & cycle
7770        do j=1,nterm_sccor(isccori,isccori1)
7771           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7772           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7773           cosphi=dcos(j*tauangle(intertyp,i))
7774           sinphi=dsin(j*tauangle(intertyp,i))
7775           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7776           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7777         enddo
7778 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7779         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7780         if (lprn)
7781      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7782      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7783      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7784      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7785         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7786        enddo !intertyp
7787       enddo
7788
7789       return
7790       end
7791 c----------------------------------------------------------------------------
7792       subroutine multibody(ecorr)
7793 C This subroutine calculates multi-body contributions to energy following
7794 C the idea of Skolnick et al. If side chains I and J make a contact and
7795 C at the same time side chains I+1 and J+1 make a contact, an extra
7796 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7797       implicit real*8 (a-h,o-z)
7798       include 'DIMENSIONS'
7799       include 'COMMON.IOUNITS'
7800       include 'COMMON.DERIV'
7801       include 'COMMON.INTERACT'
7802       include 'COMMON.CONTACTS'
7803       double precision gx(3),gx1(3)
7804       logical lprn
7805
7806 C Set lprn=.true. for debugging
7807       lprn=.false.
7808
7809       if (lprn) then
7810         write (iout,'(a)') 'Contact function values:'
7811         do i=nnt,nct-2
7812           write (iout,'(i2,20(1x,i2,f10.5))')
7813      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7814         enddo
7815       endif
7816       ecorr=0.0D0
7817       do i=nnt,nct
7818         do j=1,3
7819           gradcorr(j,i)=0.0D0
7820           gradxorr(j,i)=0.0D0
7821         enddo
7822       enddo
7823       do i=nnt,nct-2
7824
7825         DO ISHIFT = 3,4
7826
7827         i1=i+ishift
7828         num_conti=num_cont(i)
7829         num_conti1=num_cont(i1)
7830         do jj=1,num_conti
7831           j=jcont(jj,i)
7832           do kk=1,num_conti1
7833             j1=jcont(kk,i1)
7834             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7835 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7836 cd   &                   ' ishift=',ishift
7837 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7838 C The system gains extra energy.
7839               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7840             endif   ! j1==j+-ishift
7841           enddo     ! kk
7842         enddo       ! jj
7843
7844         ENDDO ! ISHIFT
7845
7846       enddo         ! i
7847       return
7848       end
7849 c------------------------------------------------------------------------------
7850       double precision function esccorr(i,j,k,l,jj,kk)
7851       implicit real*8 (a-h,o-z)
7852       include 'DIMENSIONS'
7853       include 'COMMON.IOUNITS'
7854       include 'COMMON.DERIV'
7855       include 'COMMON.INTERACT'
7856       include 'COMMON.CONTACTS'
7857       include 'COMMON.SHIELD'
7858       double precision gx(3),gx1(3)
7859       logical lprn
7860       lprn=.false.
7861       eij=facont(jj,i)
7862       ekl=facont(kk,k)
7863 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7864 C Calculate the multi-body contribution to energy.
7865 C Calculate multi-body contributions to the gradient.
7866 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7867 cd   & k,l,(gacont(m,kk,k),m=1,3)
7868       do m=1,3
7869         gx(m) =ekl*gacont(m,jj,i)
7870         gx1(m)=eij*gacont(m,kk,k)
7871         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7872         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7873         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7874         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7875       enddo
7876       do m=i,j-1
7877         do ll=1,3
7878           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7879         enddo
7880       enddo
7881       do m=k,l-1
7882         do ll=1,3
7883           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7884         enddo
7885       enddo
7886       esccorr=-eij*ekl
7887       return
7888       end
7889 c------------------------------------------------------------------------------
7890       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7891 C This subroutine calculates multi-body contributions to hydrogen-bonding
7892       implicit real*8 (a-h,o-z)
7893       include 'DIMENSIONS'
7894       include 'COMMON.IOUNITS'
7895 #ifdef MPI
7896       include "mpif.h"
7897       parameter (max_cont=maxconts)
7898       parameter (max_dim=26)
7899       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7900       double precision zapas(max_dim,maxconts,max_fg_procs),
7901      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7902       common /przechowalnia/ zapas
7903       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7904      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7905 #endif
7906       include 'COMMON.SETUP'
7907       include 'COMMON.FFIELD'
7908       include 'COMMON.DERIV'
7909       include 'COMMON.INTERACT'
7910       include 'COMMON.CONTACTS'
7911       include 'COMMON.CONTROL'
7912       include 'COMMON.LOCAL'
7913       double precision gx(3),gx1(3),time00
7914       logical lprn,ldone
7915
7916 C Set lprn=.true. for debugging
7917       lprn=.false.
7918 #ifdef MPI
7919       n_corr=0
7920       n_corr1=0
7921       if (nfgtasks.le.1) goto 30
7922       if (lprn) then
7923         write (iout,'(a)') 'Contact function values before RECEIVE:'
7924         do i=nnt,nct-2
7925           write (iout,'(2i3,50(1x,i2,f5.2))')
7926      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7927      &    j=1,num_cont_hb(i))
7928         enddo
7929       endif
7930       call flush(iout)
7931       do i=1,ntask_cont_from
7932         ncont_recv(i)=0
7933       enddo
7934       do i=1,ntask_cont_to
7935         ncont_sent(i)=0
7936       enddo
7937 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7938 c     & ntask_cont_to
7939 C Make the list of contacts to send to send to other procesors
7940 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7941 c      call flush(iout)
7942       do i=iturn3_start,iturn3_end
7943 c        write (iout,*) "make contact list turn3",i," num_cont",
7944 c     &    num_cont_hb(i)
7945         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7946       enddo
7947       do i=iturn4_start,iturn4_end
7948 c        write (iout,*) "make contact list turn4",i," num_cont",
7949 c     &   num_cont_hb(i)
7950         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7951       enddo
7952       do ii=1,nat_sent
7953         i=iat_sent(ii)
7954 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7955 c     &    num_cont_hb(i)
7956         do j=1,num_cont_hb(i)
7957         do k=1,4
7958           jjc=jcont_hb(j,i)
7959           iproc=iint_sent_local(k,jjc,ii)
7960 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7961           if (iproc.gt.0) then
7962             ncont_sent(iproc)=ncont_sent(iproc)+1
7963             nn=ncont_sent(iproc)
7964             zapas(1,nn,iproc)=i
7965             zapas(2,nn,iproc)=jjc
7966             zapas(3,nn,iproc)=facont_hb(j,i)
7967             zapas(4,nn,iproc)=ees0p(j,i)
7968             zapas(5,nn,iproc)=ees0m(j,i)
7969             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7970             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7971             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7972             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7973             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7974             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7975             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7976             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7977             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7978             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7979             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7980             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7981             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7982             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7983             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7984             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7985             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7986             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7987             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7988             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7989             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7990           endif
7991         enddo
7992         enddo
7993       enddo
7994       if (lprn) then
7995       write (iout,*)
7996      &  "Numbers of contacts to be sent to other processors",
7997      &  (ncont_sent(i),i=1,ntask_cont_to)
7998       write (iout,*) "Contacts sent"
7999       do ii=1,ntask_cont_to
8000         nn=ncont_sent(ii)
8001         iproc=itask_cont_to(ii)
8002         write (iout,*) nn," contacts to processor",iproc,
8003      &   " of CONT_TO_COMM group"
8004         do i=1,nn
8005           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8006         enddo
8007       enddo
8008       call flush(iout)
8009       endif
8010       CorrelType=477
8011       CorrelID=fg_rank+1
8012       CorrelType1=478
8013       CorrelID1=nfgtasks+fg_rank+1
8014       ireq=0
8015 C Receive the numbers of needed contacts from other processors
8016       do ii=1,ntask_cont_from
8017         iproc=itask_cont_from(ii)
8018         ireq=ireq+1
8019         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8020      &    FG_COMM,req(ireq),IERR)
8021       enddo
8022 c      write (iout,*) "IRECV ended"
8023 c      call flush(iout)
8024 C Send the number of contacts needed by other processors
8025       do ii=1,ntask_cont_to
8026         iproc=itask_cont_to(ii)
8027         ireq=ireq+1
8028         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8029      &    FG_COMM,req(ireq),IERR)
8030       enddo
8031 c      write (iout,*) "ISEND ended"
8032 c      write (iout,*) "number of requests (nn)",ireq
8033       call flush(iout)
8034       if (ireq.gt.0)
8035      &  call MPI_Waitall(ireq,req,status_array,ierr)
8036 c      write (iout,*)
8037 c     &  "Numbers of contacts to be received from other processors",
8038 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8039 c      call flush(iout)
8040 C Receive contacts
8041       ireq=0
8042       do ii=1,ntask_cont_from
8043         iproc=itask_cont_from(ii)
8044         nn=ncont_recv(ii)
8045 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8046 c     &   " of CONT_TO_COMM group"
8047         call flush(iout)
8048         if (nn.gt.0) then
8049           ireq=ireq+1
8050           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8051      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8052 c          write (iout,*) "ireq,req",ireq,req(ireq)
8053         endif
8054       enddo
8055 C Send the contacts to processors that need them
8056       do ii=1,ntask_cont_to
8057         iproc=itask_cont_to(ii)
8058         nn=ncont_sent(ii)
8059 c        write (iout,*) nn," contacts to processor",iproc,
8060 c     &   " of CONT_TO_COMM group"
8061         if (nn.gt.0) then
8062           ireq=ireq+1
8063           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8064      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8065 c          write (iout,*) "ireq,req",ireq,req(ireq)
8066 c          do i=1,nn
8067 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8068 c          enddo
8069         endif
8070       enddo
8071 c      write (iout,*) "number of requests (contacts)",ireq
8072 c      write (iout,*) "req",(req(i),i=1,4)
8073 c      call flush(iout)
8074       if (ireq.gt.0)
8075      & call MPI_Waitall(ireq,req,status_array,ierr)
8076       do iii=1,ntask_cont_from
8077         iproc=itask_cont_from(iii)
8078         nn=ncont_recv(iii)
8079         if (lprn) then
8080         write (iout,*) "Received",nn," contacts from processor",iproc,
8081      &   " of CONT_FROM_COMM group"
8082         call flush(iout)
8083         do i=1,nn
8084           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8085         enddo
8086         call flush(iout)
8087         endif
8088         do i=1,nn
8089           ii=zapas_recv(1,i,iii)
8090 c Flag the received contacts to prevent double-counting
8091           jj=-zapas_recv(2,i,iii)
8092 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8093 c          call flush(iout)
8094           nnn=num_cont_hb(ii)+1
8095           num_cont_hb(ii)=nnn
8096           jcont_hb(nnn,ii)=jj
8097           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8098           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8099           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8100           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8101           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8102           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8103           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8104           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8105           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8106           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8107           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8108           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8109           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8110           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8111           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8112           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8113           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8114           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8115           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8116           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8117           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8118           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8119           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8120           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8121         enddo
8122       enddo
8123       call flush(iout)
8124       if (lprn) then
8125         write (iout,'(a)') 'Contact function values after receive:'
8126         do i=nnt,nct-2
8127           write (iout,'(2i3,50(1x,i3,f5.2))')
8128      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8129      &    j=1,num_cont_hb(i))
8130         enddo
8131         call flush(iout)
8132       endif
8133    30 continue
8134 #endif
8135       if (lprn) then
8136         write (iout,'(a)') 'Contact function values:'
8137         do i=nnt,nct-2
8138           write (iout,'(2i3,50(1x,i3,f5.2))')
8139      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8140      &    j=1,num_cont_hb(i))
8141         enddo
8142       endif
8143       ecorr=0.0D0
8144 C Remove the loop below after debugging !!!
8145       do i=nnt,nct
8146         do j=1,3
8147           gradcorr(j,i)=0.0D0
8148           gradxorr(j,i)=0.0D0
8149         enddo
8150       enddo
8151 C Calculate the local-electrostatic correlation terms
8152       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8153         i1=i+1
8154         num_conti=num_cont_hb(i)
8155         num_conti1=num_cont_hb(i+1)
8156         do jj=1,num_conti
8157           j=jcont_hb(jj,i)
8158           jp=iabs(j)
8159           do kk=1,num_conti1
8160             j1=jcont_hb(kk,i1)
8161             jp1=iabs(j1)
8162 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8163 c     &         ' jj=',jj,' kk=',kk
8164             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8165      &          .or. j.lt.0 .and. j1.gt.0) .and.
8166      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8167 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8168 C The system gains extra energy.
8169               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8170               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8171      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8172               n_corr=n_corr+1
8173             else if (j1.eq.j) then
8174 C Contacts I-J and I-(J+1) occur simultaneously.
8175 C The system loses extra energy.
8176 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8177             endif
8178           enddo ! kk
8179           do kk=1,num_conti
8180             j1=jcont_hb(kk,i)
8181 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8182 c    &         ' jj=',jj,' kk=',kk
8183             if (j1.eq.j+1) then
8184 C Contacts I-J and (I+1)-J occur simultaneously.
8185 C The system loses extra energy.
8186 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8187             endif ! j1==j+1
8188           enddo ! kk
8189         enddo ! jj
8190       enddo ! i
8191       return
8192       end
8193 c------------------------------------------------------------------------------
8194       subroutine add_hb_contact(ii,jj,itask)
8195       implicit real*8 (a-h,o-z)
8196       include "DIMENSIONS"
8197       include "COMMON.IOUNITS"
8198       integer max_cont
8199       integer max_dim
8200       parameter (max_cont=maxconts)
8201       parameter (max_dim=26)
8202       include "COMMON.CONTACTS"
8203       double precision zapas(max_dim,maxconts,max_fg_procs),
8204      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8205       common /przechowalnia/ zapas
8206       integer i,j,ii,jj,iproc,itask(4),nn
8207 c      write (iout,*) "itask",itask
8208       do i=1,2
8209         iproc=itask(i)
8210         if (iproc.gt.0) then
8211           do j=1,num_cont_hb(ii)
8212             jjc=jcont_hb(j,ii)
8213 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8214             if (jjc.eq.jj) then
8215               ncont_sent(iproc)=ncont_sent(iproc)+1
8216               nn=ncont_sent(iproc)
8217               zapas(1,nn,iproc)=ii
8218               zapas(2,nn,iproc)=jjc
8219               zapas(3,nn,iproc)=facont_hb(j,ii)
8220               zapas(4,nn,iproc)=ees0p(j,ii)
8221               zapas(5,nn,iproc)=ees0m(j,ii)
8222               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8223               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8224               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8225               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8226               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8227               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8228               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8229               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8230               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8231               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8232               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8233               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8234               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8235               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8236               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8237               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8238               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8239               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8240               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8241               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8242               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8243               exit
8244             endif
8245           enddo
8246         endif
8247       enddo
8248       return
8249       end
8250 c------------------------------------------------------------------------------
8251       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8252      &  n_corr1)
8253 C This subroutine calculates multi-body contributions to hydrogen-bonding
8254       implicit real*8 (a-h,o-z)
8255       include 'DIMENSIONS'
8256       include 'COMMON.IOUNITS'
8257 #ifdef MPI
8258       include "mpif.h"
8259       parameter (max_cont=maxconts)
8260       parameter (max_dim=70)
8261       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8262       double precision zapas(max_dim,maxconts,max_fg_procs),
8263      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8264       common /przechowalnia/ zapas
8265       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8266      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8267 #endif
8268       include 'COMMON.SETUP'
8269       include 'COMMON.FFIELD'
8270       include 'COMMON.DERIV'
8271       include 'COMMON.LOCAL'
8272       include 'COMMON.INTERACT'
8273       include 'COMMON.CONTACTS'
8274       include 'COMMON.CHAIN'
8275       include 'COMMON.CONTROL'
8276       include 'COMMON.SHIELD'
8277       double precision gx(3),gx1(3)
8278       integer num_cont_hb_old(maxres)
8279       logical lprn,ldone
8280       double precision eello4,eello5,eelo6,eello_turn6
8281       external eello4,eello5,eello6,eello_turn6
8282 C Set lprn=.true. for debugging
8283       lprn=.false.
8284       eturn6=0.0d0
8285 #ifdef MPI
8286       do i=1,nres
8287         num_cont_hb_old(i)=num_cont_hb(i)
8288       enddo
8289       n_corr=0
8290       n_corr1=0
8291       if (nfgtasks.le.1) goto 30
8292       if (lprn) then
8293         write (iout,'(a)') 'Contact function values before RECEIVE:'
8294         do i=nnt,nct-2
8295           write (iout,'(2i3,50(1x,i2,f5.2))')
8296      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8297      &    j=1,num_cont_hb(i))
8298         enddo
8299       endif
8300       call flush(iout)
8301       do i=1,ntask_cont_from
8302         ncont_recv(i)=0
8303       enddo
8304       do i=1,ntask_cont_to
8305         ncont_sent(i)=0
8306       enddo
8307 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8308 c     & ntask_cont_to
8309 C Make the list of contacts to send to send to other procesors
8310       do i=iturn3_start,iturn3_end
8311 c        write (iout,*) "make contact list turn3",i," num_cont",
8312 c     &    num_cont_hb(i)
8313         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8314       enddo
8315       do i=iturn4_start,iturn4_end
8316 c        write (iout,*) "make contact list turn4",i," num_cont",
8317 c     &   num_cont_hb(i)
8318         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8319       enddo
8320       do ii=1,nat_sent
8321         i=iat_sent(ii)
8322 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8323 c     &    num_cont_hb(i)
8324         do j=1,num_cont_hb(i)
8325         do k=1,4
8326           jjc=jcont_hb(j,i)
8327           iproc=iint_sent_local(k,jjc,ii)
8328 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8329           if (iproc.ne.0) then
8330             ncont_sent(iproc)=ncont_sent(iproc)+1
8331             nn=ncont_sent(iproc)
8332             zapas(1,nn,iproc)=i
8333             zapas(2,nn,iproc)=jjc
8334             zapas(3,nn,iproc)=d_cont(j,i)
8335             ind=3
8336             do kk=1,3
8337               ind=ind+1
8338               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8339             enddo
8340             do kk=1,2
8341               do ll=1,2
8342                 ind=ind+1
8343                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8344               enddo
8345             enddo
8346             do jj=1,5
8347               do kk=1,3
8348                 do ll=1,2
8349                   do mm=1,2
8350                     ind=ind+1
8351                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8352                   enddo
8353                 enddo
8354               enddo
8355             enddo
8356           endif
8357         enddo
8358         enddo
8359       enddo
8360       if (lprn) then
8361       write (iout,*)
8362      &  "Numbers of contacts to be sent to other processors",
8363      &  (ncont_sent(i),i=1,ntask_cont_to)
8364       write (iout,*) "Contacts sent"
8365       do ii=1,ntask_cont_to
8366         nn=ncont_sent(ii)
8367         iproc=itask_cont_to(ii)
8368         write (iout,*) nn," contacts to processor",iproc,
8369      &   " of CONT_TO_COMM group"
8370         do i=1,nn
8371           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8372         enddo
8373       enddo
8374       call flush(iout)
8375       endif
8376       CorrelType=477
8377       CorrelID=fg_rank+1
8378       CorrelType1=478
8379       CorrelID1=nfgtasks+fg_rank+1
8380       ireq=0
8381 C Receive the numbers of needed contacts from other processors
8382       do ii=1,ntask_cont_from
8383         iproc=itask_cont_from(ii)
8384         ireq=ireq+1
8385         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8386      &    FG_COMM,req(ireq),IERR)
8387       enddo
8388 c      write (iout,*) "IRECV ended"
8389 c      call flush(iout)
8390 C Send the number of contacts needed by other processors
8391       do ii=1,ntask_cont_to
8392         iproc=itask_cont_to(ii)
8393         ireq=ireq+1
8394         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8395      &    FG_COMM,req(ireq),IERR)
8396       enddo
8397 c      write (iout,*) "ISEND ended"
8398 c      write (iout,*) "number of requests (nn)",ireq
8399       call flush(iout)
8400       if (ireq.gt.0)
8401      &  call MPI_Waitall(ireq,req,status_array,ierr)
8402 c      write (iout,*)
8403 c     &  "Numbers of contacts to be received from other processors",
8404 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8405 c      call flush(iout)
8406 C Receive contacts
8407       ireq=0
8408       do ii=1,ntask_cont_from
8409         iproc=itask_cont_from(ii)
8410         nn=ncont_recv(ii)
8411 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8412 c     &   " of CONT_TO_COMM group"
8413         call flush(iout)
8414         if (nn.gt.0) then
8415           ireq=ireq+1
8416           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8417      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8418 c          write (iout,*) "ireq,req",ireq,req(ireq)
8419         endif
8420       enddo
8421 C Send the contacts to processors that need them
8422       do ii=1,ntask_cont_to
8423         iproc=itask_cont_to(ii)
8424         nn=ncont_sent(ii)
8425 c        write (iout,*) nn," contacts to processor",iproc,
8426 c     &   " of CONT_TO_COMM group"
8427         if (nn.gt.0) then
8428           ireq=ireq+1
8429           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8430      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8431 c          write (iout,*) "ireq,req",ireq,req(ireq)
8432 c          do i=1,nn
8433 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8434 c          enddo
8435         endif
8436       enddo
8437 c      write (iout,*) "number of requests (contacts)",ireq
8438 c      write (iout,*) "req",(req(i),i=1,4)
8439 c      call flush(iout)
8440       if (ireq.gt.0)
8441      & call MPI_Waitall(ireq,req,status_array,ierr)
8442       do iii=1,ntask_cont_from
8443         iproc=itask_cont_from(iii)
8444         nn=ncont_recv(iii)
8445         if (lprn) then
8446         write (iout,*) "Received",nn," contacts from processor",iproc,
8447      &   " of CONT_FROM_COMM group"
8448         call flush(iout)
8449         do i=1,nn
8450           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8451         enddo
8452         call flush(iout)
8453         endif
8454         do i=1,nn
8455           ii=zapas_recv(1,i,iii)
8456 c Flag the received contacts to prevent double-counting
8457           jj=-zapas_recv(2,i,iii)
8458 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8459 c          call flush(iout)
8460           nnn=num_cont_hb(ii)+1
8461           num_cont_hb(ii)=nnn
8462           jcont_hb(nnn,ii)=jj
8463           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8464           ind=3
8465           do kk=1,3
8466             ind=ind+1
8467             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8468           enddo
8469           do kk=1,2
8470             do ll=1,2
8471               ind=ind+1
8472               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8473             enddo
8474           enddo
8475           do jj=1,5
8476             do kk=1,3
8477               do ll=1,2
8478                 do mm=1,2
8479                   ind=ind+1
8480                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8481                 enddo
8482               enddo
8483             enddo
8484           enddo
8485         enddo
8486       enddo
8487       call flush(iout)
8488       if (lprn) then
8489         write (iout,'(a)') 'Contact function values after receive:'
8490         do i=nnt,nct-2
8491           write (iout,'(2i3,50(1x,i3,5f6.3))')
8492      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8493      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8494         enddo
8495         call flush(iout)
8496       endif
8497    30 continue
8498 #endif
8499       if (lprn) then
8500         write (iout,'(a)') 'Contact function values:'
8501         do i=nnt,nct-2
8502           write (iout,'(2i3,50(1x,i2,5f6.3))')
8503      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8504      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8505         enddo
8506       endif
8507       ecorr=0.0D0
8508       ecorr5=0.0d0
8509       ecorr6=0.0d0
8510 C Remove the loop below after debugging !!!
8511       do i=nnt,nct
8512         do j=1,3
8513           gradcorr(j,i)=0.0D0
8514           gradxorr(j,i)=0.0D0
8515         enddo
8516       enddo
8517 C Calculate the dipole-dipole interaction energies
8518       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8519       do i=iatel_s,iatel_e+1
8520         num_conti=num_cont_hb(i)
8521         do jj=1,num_conti
8522           j=jcont_hb(jj,i)
8523 #ifdef MOMENT
8524           call dipole(i,j,jj)
8525 #endif
8526         enddo
8527       enddo
8528       endif
8529 C Calculate the local-electrostatic correlation terms
8530 c                write (iout,*) "gradcorr5 in eello5 before loop"
8531 c                do iii=1,nres
8532 c                  write (iout,'(i5,3f10.5)')
8533 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8534 c                enddo
8535       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8536 c        write (iout,*) "corr loop i",i
8537         i1=i+1
8538         num_conti=num_cont_hb(i)
8539         num_conti1=num_cont_hb(i+1)
8540         do jj=1,num_conti
8541           j=jcont_hb(jj,i)
8542           jp=iabs(j)
8543           do kk=1,num_conti1
8544             j1=jcont_hb(kk,i1)
8545             jp1=iabs(j1)
8546 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8547 c     &         ' jj=',jj,' kk=',kk
8548 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8549             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8550      &          .or. j.lt.0 .and. j1.gt.0) .and.
8551      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8552 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8553 C The system gains extra energy.
8554               n_corr=n_corr+1
8555               sqd1=dsqrt(d_cont(jj,i))
8556               sqd2=dsqrt(d_cont(kk,i1))
8557               sred_geom = sqd1*sqd2
8558               IF (sred_geom.lt.cutoff_corr) THEN
8559                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8560      &            ekont,fprimcont)
8561 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8562 cd     &         ' jj=',jj,' kk=',kk
8563                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8564                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8565                 do l=1,3
8566                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8567                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8568                 enddo
8569                 n_corr1=n_corr1+1
8570 cd               write (iout,*) 'sred_geom=',sred_geom,
8571 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8572 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8573 cd               write (iout,*) "g_contij",g_contij
8574 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8575 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8576                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8577                 if (wcorr4.gt.0.0d0)
8578      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8579 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8580                   if (energy_dec.and.wcorr4.gt.0.0d0)
8581      1                 write (iout,'(a6,4i5,0pf7.3)')
8582      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8583 c                write (iout,*) "gradcorr5 before eello5"
8584 c                do iii=1,nres
8585 c                  write (iout,'(i5,3f10.5)')
8586 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8587 c                enddo
8588                 if (wcorr5.gt.0.0d0)
8589      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8590 c                write (iout,*) "gradcorr5 after eello5"
8591 c                do iii=1,nres
8592 c                  write (iout,'(i5,3f10.5)')
8593 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8594 c                enddo
8595                   if (energy_dec.and.wcorr5.gt.0.0d0)
8596      1                 write (iout,'(a6,4i5,0pf7.3)')
8597      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8598 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8599 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8600                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8601      &               .or. wturn6.eq.0.0d0))then
8602 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8603                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8604                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8605      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8606 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8607 cd     &            'ecorr6=',ecorr6
8608 cd                write (iout,'(4e15.5)') sred_geom,
8609 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8610 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8611 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8612                 else if (wturn6.gt.0.0d0
8613      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8614 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8615                   eturn6=eturn6+eello_turn6(i,jj,kk)
8616                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8617      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8618 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8619                 endif
8620               ENDIF
8621 1111          continue
8622             endif
8623           enddo ! kk
8624         enddo ! jj
8625       enddo ! i
8626       do i=1,nres
8627         num_cont_hb(i)=num_cont_hb_old(i)
8628       enddo
8629 c                write (iout,*) "gradcorr5 in eello5"
8630 c                do iii=1,nres
8631 c                  write (iout,'(i5,3f10.5)')
8632 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8633 c                enddo
8634       return
8635       end
8636 c------------------------------------------------------------------------------
8637       subroutine add_hb_contact_eello(ii,jj,itask)
8638       implicit real*8 (a-h,o-z)
8639       include "DIMENSIONS"
8640       include "COMMON.IOUNITS"
8641       integer max_cont
8642       integer max_dim
8643       parameter (max_cont=maxconts)
8644       parameter (max_dim=70)
8645       include "COMMON.CONTACTS"
8646       double precision zapas(max_dim,maxconts,max_fg_procs),
8647      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8648       common /przechowalnia/ zapas
8649       integer i,j,ii,jj,iproc,itask(4),nn
8650 c      write (iout,*) "itask",itask
8651       do i=1,2
8652         iproc=itask(i)
8653         if (iproc.gt.0) then
8654           do j=1,num_cont_hb(ii)
8655             jjc=jcont_hb(j,ii)
8656 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8657             if (jjc.eq.jj) then
8658               ncont_sent(iproc)=ncont_sent(iproc)+1
8659               nn=ncont_sent(iproc)
8660               zapas(1,nn,iproc)=ii
8661               zapas(2,nn,iproc)=jjc
8662               zapas(3,nn,iproc)=d_cont(j,ii)
8663               ind=3
8664               do kk=1,3
8665                 ind=ind+1
8666                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8667               enddo
8668               do kk=1,2
8669                 do ll=1,2
8670                   ind=ind+1
8671                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8672                 enddo
8673               enddo
8674               do jj=1,5
8675                 do kk=1,3
8676                   do ll=1,2
8677                     do mm=1,2
8678                       ind=ind+1
8679                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8680                     enddo
8681                   enddo
8682                 enddo
8683               enddo
8684               exit
8685             endif
8686           enddo
8687         endif
8688       enddo
8689       return
8690       end
8691 c------------------------------------------------------------------------------
8692       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8693       implicit real*8 (a-h,o-z)
8694       include 'DIMENSIONS'
8695       include 'COMMON.IOUNITS'
8696       include 'COMMON.DERIV'
8697       include 'COMMON.INTERACT'
8698       include 'COMMON.CONTACTS'
8699       include 'COMMON.SHIELD'
8700       include 'COMMON.CONTROL'
8701       double precision gx(3),gx1(3)
8702       logical lprn
8703       lprn=.false.
8704 C      print *,"wchodze",fac_shield(i),shield_mode
8705       eij=facont_hb(jj,i)
8706       ekl=facont_hb(kk,k)
8707       ees0pij=ees0p(jj,i)
8708       ees0pkl=ees0p(kk,k)
8709       ees0mij=ees0m(jj,i)
8710       ees0mkl=ees0m(kk,k)
8711       ekont=eij*ekl
8712       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8713 C*
8714 C     & fac_shield(i)**2*fac_shield(j)**2
8715 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8716 C Following 4 lines for diagnostics.
8717 cd    ees0pkl=0.0D0
8718 cd    ees0pij=1.0D0
8719 cd    ees0mkl=0.0D0
8720 cd    ees0mij=1.0D0
8721 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8722 c     & 'Contacts ',i,j,
8723 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8724 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8725 c     & 'gradcorr_long'
8726 C Calculate the multi-body contribution to energy.
8727 C      ecorr=ecorr+ekont*ees
8728 C Calculate multi-body contributions to the gradient.
8729       coeffpees0pij=coeffp*ees0pij
8730       coeffmees0mij=coeffm*ees0mij
8731       coeffpees0pkl=coeffp*ees0pkl
8732       coeffmees0mkl=coeffm*ees0mkl
8733       do ll=1,3
8734 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8735         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8736      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8737      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8738         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8739      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8740      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8741 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8742         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8743      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8744      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8745         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8746      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8747      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8748         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8749      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8750      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8751         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8752         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8753         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8754      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8755      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8756         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8757         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8758 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8759       enddo
8760 c      write (iout,*)
8761 cgrad      do m=i+1,j-1
8762 cgrad        do ll=1,3
8763 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8764 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8765 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8766 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8767 cgrad        enddo
8768 cgrad      enddo
8769 cgrad      do m=k+1,l-1
8770 cgrad        do ll=1,3
8771 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8772 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8773 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8774 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8775 cgrad        enddo
8776 cgrad      enddo
8777 c      write (iout,*) "ehbcorr",ekont*ees
8778 C      print *,ekont,ees,i,k
8779       ehbcorr=ekont*ees
8780 C now gradient over shielding
8781 C      return
8782       if (shield_mode.gt.0) then
8783        j=ees0plist(jj,i)
8784        l=ees0plist(kk,k)
8785 C        print *,i,j,fac_shield(i),fac_shield(j),
8786 C     &fac_shield(k),fac_shield(l)
8787         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8788      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8789           do ilist=1,ishield_list(i)
8790            iresshield=shield_list(ilist,i)
8791            do m=1,3
8792            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8793 C     &      *2.0
8794            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8795      &              rlocshield
8796      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8797             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8798      &+rlocshield
8799            enddo
8800           enddo
8801           do ilist=1,ishield_list(j)
8802            iresshield=shield_list(ilist,j)
8803            do m=1,3
8804            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8805 C     &     *2.0
8806            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8807      &              rlocshield
8808      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8809            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8810      &     +rlocshield
8811            enddo
8812           enddo
8813
8814           do ilist=1,ishield_list(k)
8815            iresshield=shield_list(ilist,k)
8816            do m=1,3
8817            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8818 C     &     *2.0
8819            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8820      &              rlocshield
8821      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8822            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8823      &     +rlocshield
8824            enddo
8825           enddo
8826           do ilist=1,ishield_list(l)
8827            iresshield=shield_list(ilist,l)
8828            do m=1,3
8829            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8830 C     &     *2.0
8831            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8832      &              rlocshield
8833      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8834            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8835      &     +rlocshield
8836            enddo
8837           enddo
8838 C          print *,gshieldx(m,iresshield)
8839           do m=1,3
8840             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8841      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8842             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8843      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8844             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8845      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8846             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8847      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8848
8849             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8850      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8851             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8852      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8853             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8854      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8855             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8856      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8857
8858            enddo
8859       endif
8860       endif
8861       return
8862       end
8863 #ifdef MOMENT
8864 C---------------------------------------------------------------------------
8865       subroutine dipole(i,j,jj)
8866       implicit real*8 (a-h,o-z)
8867       include 'DIMENSIONS'
8868       include 'COMMON.IOUNITS'
8869       include 'COMMON.CHAIN'
8870       include 'COMMON.FFIELD'
8871       include 'COMMON.DERIV'
8872       include 'COMMON.INTERACT'
8873       include 'COMMON.CONTACTS'
8874       include 'COMMON.TORSION'
8875       include 'COMMON.VAR'
8876       include 'COMMON.GEO'
8877       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8878      &  auxmat(2,2)
8879       iti1 = itortyp(itype(i+1))
8880       if (j.lt.nres-1) then
8881         itj1 = itype2loc(itype(j+1))
8882       else
8883         itj1=nloctyp
8884       endif
8885       do iii=1,2
8886         dipi(iii,1)=Ub2(iii,i)
8887         dipderi(iii)=Ub2der(iii,i)
8888         dipi(iii,2)=b1(iii,i+1)
8889         dipj(iii,1)=Ub2(iii,j)
8890         dipderj(iii)=Ub2der(iii,j)
8891         dipj(iii,2)=b1(iii,j+1)
8892       enddo
8893       kkk=0
8894       do iii=1,2
8895         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8896         do jjj=1,2
8897           kkk=kkk+1
8898           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8899         enddo
8900       enddo
8901       do kkk=1,5
8902         do lll=1,3
8903           mmm=0
8904           do iii=1,2
8905             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8906      &        auxvec(1))
8907             do jjj=1,2
8908               mmm=mmm+1
8909               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8910             enddo
8911           enddo
8912         enddo
8913       enddo
8914       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8915       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8916       do iii=1,2
8917         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8918       enddo
8919       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8920       do iii=1,2
8921         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8922       enddo
8923       return
8924       end
8925 #endif
8926 C---------------------------------------------------------------------------
8927       subroutine calc_eello(i,j,k,l,jj,kk)
8928 C
8929 C This subroutine computes matrices and vectors needed to calculate
8930 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8931 C
8932       implicit real*8 (a-h,o-z)
8933       include 'DIMENSIONS'
8934       include 'COMMON.IOUNITS'
8935       include 'COMMON.CHAIN'
8936       include 'COMMON.DERIV'
8937       include 'COMMON.INTERACT'
8938       include 'COMMON.CONTACTS'
8939       include 'COMMON.TORSION'
8940       include 'COMMON.VAR'
8941       include 'COMMON.GEO'
8942       include 'COMMON.FFIELD'
8943       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8944      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8945       logical lprn
8946       common /kutas/ lprn
8947 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8948 cd     & ' jj=',jj,' kk=',kk
8949 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8950 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8951 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8952       do iii=1,2
8953         do jjj=1,2
8954           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8955           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8956         enddo
8957       enddo
8958       call transpose2(aa1(1,1),aa1t(1,1))
8959       call transpose2(aa2(1,1),aa2t(1,1))
8960       do kkk=1,5
8961         do lll=1,3
8962           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8963      &      aa1tder(1,1,lll,kkk))
8964           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8965      &      aa2tder(1,1,lll,kkk))
8966         enddo
8967       enddo
8968       if (l.eq.j+1) then
8969 C parallel orientation of the two CA-CA-CA frames.
8970         if (i.gt.1) then
8971           iti=itype2loc(itype(i))
8972         else
8973           iti=nloctyp
8974         endif
8975         itk1=itype2loc(itype(k+1))
8976         itj=itype2loc(itype(j))
8977         if (l.lt.nres-1) then
8978           itl1=itype2loc(itype(l+1))
8979         else
8980           itl1=nloctyp
8981         endif
8982 C A1 kernel(j+1) A2T
8983 cd        do iii=1,2
8984 cd          write (iout,'(3f10.5,5x,3f10.5)')
8985 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8986 cd        enddo
8987         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8988      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8989      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8990 C Following matrices are needed only for 6-th order cumulants
8991         IF (wcorr6.gt.0.0d0) THEN
8992         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8993      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8994      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8995         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8996      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8997      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8998      &   ADtEAderx(1,1,1,1,1,1))
8999         lprn=.false.
9000         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9001      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9002      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9003      &   ADtEA1derx(1,1,1,1,1,1))
9004         ENDIF
9005 C End 6-th order cumulants
9006 cd        lprn=.false.
9007 cd        if (lprn) then
9008 cd        write (2,*) 'In calc_eello6'
9009 cd        do iii=1,2
9010 cd          write (2,*) 'iii=',iii
9011 cd          do kkk=1,5
9012 cd            write (2,*) 'kkk=',kkk
9013 cd            do jjj=1,2
9014 cd              write (2,'(3(2f10.5),5x)')
9015 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9016 cd            enddo
9017 cd          enddo
9018 cd        enddo
9019 cd        endif
9020         call transpose2(EUgder(1,1,k),auxmat(1,1))
9021         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9022         call transpose2(EUg(1,1,k),auxmat(1,1))
9023         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9024         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9025         do iii=1,2
9026           do kkk=1,5
9027             do lll=1,3
9028               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9029      &          EAEAderx(1,1,lll,kkk,iii,1))
9030             enddo
9031           enddo
9032         enddo
9033 C A1T kernel(i+1) A2
9034         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9035      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9036      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9037 C Following matrices are needed only for 6-th order cumulants
9038         IF (wcorr6.gt.0.0d0) THEN
9039         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9040      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9041      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9042         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9043      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9044      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9045      &   ADtEAderx(1,1,1,1,1,2))
9046         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9047      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9048      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9049      &   ADtEA1derx(1,1,1,1,1,2))
9050         ENDIF
9051 C End 6-th order cumulants
9052         call transpose2(EUgder(1,1,l),auxmat(1,1))
9053         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9054         call transpose2(EUg(1,1,l),auxmat(1,1))
9055         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9056         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9057         do iii=1,2
9058           do kkk=1,5
9059             do lll=1,3
9060               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9061      &          EAEAderx(1,1,lll,kkk,iii,2))
9062             enddo
9063           enddo
9064         enddo
9065 C AEAb1 and AEAb2
9066 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9067 C They are needed only when the fifth- or the sixth-order cumulants are
9068 C indluded.
9069         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9070         call transpose2(AEA(1,1,1),auxmat(1,1))
9071         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9072         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9073         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9074         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9075         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9076         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9077         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9078         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9079         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9080         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9081         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9082         call transpose2(AEA(1,1,2),auxmat(1,1))
9083         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9084         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9085         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9086         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9087         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9088         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9089         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9090         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9091         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9092         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9093         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9094 C Calculate the Cartesian derivatives of the vectors.
9095         do iii=1,2
9096           do kkk=1,5
9097             do lll=1,3
9098               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9099               call matvec2(auxmat(1,1),b1(1,i),
9100      &          AEAb1derx(1,lll,kkk,iii,1,1))
9101               call matvec2(auxmat(1,1),Ub2(1,i),
9102      &          AEAb2derx(1,lll,kkk,iii,1,1))
9103               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9104      &          AEAb1derx(1,lll,kkk,iii,2,1))
9105               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9106      &          AEAb2derx(1,lll,kkk,iii,2,1))
9107               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9108               call matvec2(auxmat(1,1),b1(1,j),
9109      &          AEAb1derx(1,lll,kkk,iii,1,2))
9110               call matvec2(auxmat(1,1),Ub2(1,j),
9111      &          AEAb2derx(1,lll,kkk,iii,1,2))
9112               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9113      &          AEAb1derx(1,lll,kkk,iii,2,2))
9114               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9115      &          AEAb2derx(1,lll,kkk,iii,2,2))
9116             enddo
9117           enddo
9118         enddo
9119         ENDIF
9120 C End vectors
9121       else
9122 C Antiparallel orientation of the two CA-CA-CA frames.
9123         if (i.gt.1) then
9124           iti=itype2loc(itype(i))
9125         else
9126           iti=nloctyp
9127         endif
9128         itk1=itype2loc(itype(k+1))
9129         itl=itype2loc(itype(l))
9130         itj=itype2loc(itype(j))
9131         if (j.lt.nres-1) then
9132           itj1=itype2loc(itype(j+1))
9133         else
9134           itj1=nloctyp
9135         endif
9136 C A2 kernel(j-1)T A1T
9137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9138      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9139      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9140 C Following matrices are needed only for 6-th order cumulants
9141         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9142      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9143         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9144      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9145      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9146         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9147      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9148      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9149      &   ADtEAderx(1,1,1,1,1,1))
9150         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9151      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9152      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9153      &   ADtEA1derx(1,1,1,1,1,1))
9154         ENDIF
9155 C End 6-th order cumulants
9156         call transpose2(EUgder(1,1,k),auxmat(1,1))
9157         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9158         call transpose2(EUg(1,1,k),auxmat(1,1))
9159         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9160         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9161         do iii=1,2
9162           do kkk=1,5
9163             do lll=1,3
9164               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9165      &          EAEAderx(1,1,lll,kkk,iii,1))
9166             enddo
9167           enddo
9168         enddo
9169 C A2T kernel(i+1)T A1
9170         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9171      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9172      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9173 C Following matrices are needed only for 6-th order cumulants
9174         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9175      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9176         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9177      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9178      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9179         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9180      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9181      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9182      &   ADtEAderx(1,1,1,1,1,2))
9183         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9184      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9185      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9186      &   ADtEA1derx(1,1,1,1,1,2))
9187         ENDIF
9188 C End 6-th order cumulants
9189         call transpose2(EUgder(1,1,j),auxmat(1,1))
9190         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9191         call transpose2(EUg(1,1,j),auxmat(1,1))
9192         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9193         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9194         do iii=1,2
9195           do kkk=1,5
9196             do lll=1,3
9197               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9198      &          EAEAderx(1,1,lll,kkk,iii,2))
9199             enddo
9200           enddo
9201         enddo
9202 C AEAb1 and AEAb2
9203 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9204 C They are needed only when the fifth- or the sixth-order cumulants are
9205 C indluded.
9206         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9207      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9208         call transpose2(AEA(1,1,1),auxmat(1,1))
9209         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9210         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9211         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9212         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9213         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9214         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9215         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9216         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9217         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9218         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9219         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9220         call transpose2(AEA(1,1,2),auxmat(1,1))
9221         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9222         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9223         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9224         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9225         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9226         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9227         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9228         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9229         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9230         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9231         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9232 C Calculate the Cartesian derivatives of the vectors.
9233         do iii=1,2
9234           do kkk=1,5
9235             do lll=1,3
9236               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9237               call matvec2(auxmat(1,1),b1(1,i),
9238      &          AEAb1derx(1,lll,kkk,iii,1,1))
9239               call matvec2(auxmat(1,1),Ub2(1,i),
9240      &          AEAb2derx(1,lll,kkk,iii,1,1))
9241               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9242      &          AEAb1derx(1,lll,kkk,iii,2,1))
9243               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9244      &          AEAb2derx(1,lll,kkk,iii,2,1))
9245               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9246               call matvec2(auxmat(1,1),b1(1,l),
9247      &          AEAb1derx(1,lll,kkk,iii,1,2))
9248               call matvec2(auxmat(1,1),Ub2(1,l),
9249      &          AEAb2derx(1,lll,kkk,iii,1,2))
9250               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9251      &          AEAb1derx(1,lll,kkk,iii,2,2))
9252               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9253      &          AEAb2derx(1,lll,kkk,iii,2,2))
9254             enddo
9255           enddo
9256         enddo
9257         ENDIF
9258 C End vectors
9259       endif
9260       return
9261       end
9262 C---------------------------------------------------------------------------
9263       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9264      &  KK,KKderg,AKA,AKAderg,AKAderx)
9265       implicit none
9266       integer nderg
9267       logical transp
9268       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9269      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9270      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9271       integer iii,kkk,lll
9272       integer jjj,mmm
9273       logical lprn
9274       common /kutas/ lprn
9275       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9276       do iii=1,nderg
9277         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9278      &    AKAderg(1,1,iii))
9279       enddo
9280 cd      if (lprn) write (2,*) 'In kernel'
9281       do kkk=1,5
9282 cd        if (lprn) write (2,*) 'kkk=',kkk
9283         do lll=1,3
9284           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9285      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9286 cd          if (lprn) then
9287 cd            write (2,*) 'lll=',lll
9288 cd            write (2,*) 'iii=1'
9289 cd            do jjj=1,2
9290 cd              write (2,'(3(2f10.5),5x)')
9291 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9292 cd            enddo
9293 cd          endif
9294           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9295      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9296 cd          if (lprn) then
9297 cd            write (2,*) 'lll=',lll
9298 cd            write (2,*) 'iii=2'
9299 cd            do jjj=1,2
9300 cd              write (2,'(3(2f10.5),5x)')
9301 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9302 cd            enddo
9303 cd          endif
9304         enddo
9305       enddo
9306       return
9307       end
9308 C---------------------------------------------------------------------------
9309       double precision function eello4(i,j,k,l,jj,kk)
9310       implicit real*8 (a-h,o-z)
9311       include 'DIMENSIONS'
9312       include 'COMMON.IOUNITS'
9313       include 'COMMON.CHAIN'
9314       include 'COMMON.DERIV'
9315       include 'COMMON.INTERACT'
9316       include 'COMMON.CONTACTS'
9317       include 'COMMON.TORSION'
9318       include 'COMMON.VAR'
9319       include 'COMMON.GEO'
9320       double precision pizda(2,2),ggg1(3),ggg2(3)
9321 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9322 cd        eello4=0.0d0
9323 cd        return
9324 cd      endif
9325 cd      print *,'eello4:',i,j,k,l,jj,kk
9326 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9327 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9328 cold      eij=facont_hb(jj,i)
9329 cold      ekl=facont_hb(kk,k)
9330 cold      ekont=eij*ekl
9331       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9332 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9333       gcorr_loc(k-1)=gcorr_loc(k-1)
9334      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9335       if (l.eq.j+1) then
9336         gcorr_loc(l-1)=gcorr_loc(l-1)
9337      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9338       else
9339         gcorr_loc(j-1)=gcorr_loc(j-1)
9340      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9341       endif
9342       do iii=1,2
9343         do kkk=1,5
9344           do lll=1,3
9345             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9346      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9347 cd            derx(lll,kkk,iii)=0.0d0
9348           enddo
9349         enddo
9350       enddo
9351 cd      gcorr_loc(l-1)=0.0d0
9352 cd      gcorr_loc(j-1)=0.0d0
9353 cd      gcorr_loc(k-1)=0.0d0
9354 cd      eel4=1.0d0
9355 cd      write (iout,*)'Contacts have occurred for peptide groups',
9356 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9357 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9358       if (j.lt.nres-1) then
9359         j1=j+1
9360         j2=j-1
9361       else
9362         j1=j-1
9363         j2=j-2
9364       endif
9365       if (l.lt.nres-1) then
9366         l1=l+1
9367         l2=l-1
9368       else
9369         l1=l-1
9370         l2=l-2
9371       endif
9372       do ll=1,3
9373 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9374 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9375         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9376         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9377 cgrad        ghalf=0.5d0*ggg1(ll)
9378         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9379         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9380         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9381         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9382         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9383         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9384 cgrad        ghalf=0.5d0*ggg2(ll)
9385         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9386         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9387         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9388         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9389         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9390         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9391       enddo
9392 cgrad      do m=i+1,j-1
9393 cgrad        do ll=1,3
9394 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9395 cgrad        enddo
9396 cgrad      enddo
9397 cgrad      do m=k+1,l-1
9398 cgrad        do ll=1,3
9399 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9400 cgrad        enddo
9401 cgrad      enddo
9402 cgrad      do m=i+2,j2
9403 cgrad        do ll=1,3
9404 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9405 cgrad        enddo
9406 cgrad      enddo
9407 cgrad      do m=k+2,l2
9408 cgrad        do ll=1,3
9409 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9410 cgrad        enddo
9411 cgrad      enddo
9412 cd      do iii=1,nres-3
9413 cd        write (2,*) iii,gcorr_loc(iii)
9414 cd      enddo
9415       eello4=ekont*eel4
9416 cd      write (2,*) 'ekont',ekont
9417 cd      write (iout,*) 'eello4',ekont*eel4
9418       return
9419       end
9420 C---------------------------------------------------------------------------
9421       double precision function eello5(i,j,k,l,jj,kk)
9422       implicit real*8 (a-h,o-z)
9423       include 'DIMENSIONS'
9424       include 'COMMON.IOUNITS'
9425       include 'COMMON.CHAIN'
9426       include 'COMMON.DERIV'
9427       include 'COMMON.INTERACT'
9428       include 'COMMON.CONTACTS'
9429       include 'COMMON.TORSION'
9430       include 'COMMON.VAR'
9431       include 'COMMON.GEO'
9432       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9433       double precision ggg1(3),ggg2(3)
9434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9435 C                                                                              C
9436 C                            Parallel chains                                   C
9437 C                                                                              C
9438 C          o             o                   o             o                   C
9439 C         /l\           / \             \   / \           / \   /              C
9440 C        /   \         /   \             \ /   \         /   \ /               C
9441 C       j| o |l1       | o |              o| o |         | o |o                C
9442 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9443 C      \i/   \         /   \ /             /   \         /   \                 C
9444 C       o    k1             o                                                  C
9445 C         (I)          (II)                (III)          (IV)                 C
9446 C                                                                              C
9447 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9448 C                                                                              C
9449 C                            Antiparallel chains                               C
9450 C                                                                              C
9451 C          o             o                   o             o                   C
9452 C         /j\           / \             \   / \           / \   /              C
9453 C        /   \         /   \             \ /   \         /   \ /               C
9454 C      j1| o |l        | o |              o| o |         | o |o                C
9455 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9456 C      \i/   \         /   \ /             /   \         /   \                 C
9457 C       o     k1            o                                                  C
9458 C         (I)          (II)                (III)          (IV)                 C
9459 C                                                                              C
9460 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9461 C                                                                              C
9462 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9463 C                                                                              C
9464 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9465 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9466 cd        eello5=0.0d0
9467 cd        return
9468 cd      endif
9469 cd      write (iout,*)
9470 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9471 cd     &   ' and',k,l
9472       itk=itype2loc(itype(k))
9473       itl=itype2loc(itype(l))
9474       itj=itype2loc(itype(j))
9475       eello5_1=0.0d0
9476       eello5_2=0.0d0
9477       eello5_3=0.0d0
9478       eello5_4=0.0d0
9479 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9480 cd     &   eel5_3_num,eel5_4_num)
9481       do iii=1,2
9482         do kkk=1,5
9483           do lll=1,3
9484             derx(lll,kkk,iii)=0.0d0
9485           enddo
9486         enddo
9487       enddo
9488 cd      eij=facont_hb(jj,i)
9489 cd      ekl=facont_hb(kk,k)
9490 cd      ekont=eij*ekl
9491 cd      write (iout,*)'Contacts have occurred for peptide groups',
9492 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9493 cd      goto 1111
9494 C Contribution from the graph I.
9495 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9496 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9497       call transpose2(EUg(1,1,k),auxmat(1,1))
9498       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9499       vv(1)=pizda(1,1)-pizda(2,2)
9500       vv(2)=pizda(1,2)+pizda(2,1)
9501       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9502      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9503 C Explicit gradient in virtual-dihedral angles.
9504       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9505      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9506      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9507       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9508       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9509       vv(1)=pizda(1,1)-pizda(2,2)
9510       vv(2)=pizda(1,2)+pizda(2,1)
9511       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9512      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9513      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9514       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9515       vv(1)=pizda(1,1)-pizda(2,2)
9516       vv(2)=pizda(1,2)+pizda(2,1)
9517       if (l.eq.j+1) then
9518         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9519      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9521       else
9522         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9523      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9524      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9525       endif
9526 C Cartesian gradient
9527       do iii=1,2
9528         do kkk=1,5
9529           do lll=1,3
9530             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9531      &        pizda(1,1))
9532             vv(1)=pizda(1,1)-pizda(2,2)
9533             vv(2)=pizda(1,2)+pizda(2,1)
9534             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9535      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9536      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9537           enddo
9538         enddo
9539       enddo
9540 c      goto 1112
9541 c1111  continue
9542 C Contribution from graph II
9543       call transpose2(EE(1,1,k),auxmat(1,1))
9544       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9545       vv(1)=pizda(1,1)+pizda(2,2)
9546       vv(2)=pizda(2,1)-pizda(1,2)
9547       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9548      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9549 C Explicit gradient in virtual-dihedral angles.
9550       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9551      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9552       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9553       vv(1)=pizda(1,1)+pizda(2,2)
9554       vv(2)=pizda(2,1)-pizda(1,2)
9555       if (l.eq.j+1) then
9556         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9557      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9558      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9559       else
9560         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9561      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9562      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9563       endif
9564 C Cartesian gradient
9565       do iii=1,2
9566         do kkk=1,5
9567           do lll=1,3
9568             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9569      &        pizda(1,1))
9570             vv(1)=pizda(1,1)+pizda(2,2)
9571             vv(2)=pizda(2,1)-pizda(1,2)
9572             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9573      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9574      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9575           enddo
9576         enddo
9577       enddo
9578 cd      goto 1112
9579 cd1111  continue
9580       if (l.eq.j+1) then
9581 cd        goto 1110
9582 C Parallel orientation
9583 C Contribution from graph III
9584         call transpose2(EUg(1,1,l),auxmat(1,1))
9585         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9586         vv(1)=pizda(1,1)-pizda(2,2)
9587         vv(2)=pizda(1,2)+pizda(2,1)
9588         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9589      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9590 C Explicit gradient in virtual-dihedral angles.
9591         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9592      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9593      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9594         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9595         vv(1)=pizda(1,1)-pizda(2,2)
9596         vv(2)=pizda(1,2)+pizda(2,1)
9597         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9598      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9599      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9600         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9601         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9602         vv(1)=pizda(1,1)-pizda(2,2)
9603         vv(2)=pizda(1,2)+pizda(2,1)
9604         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9605      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9606      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9607 C Cartesian gradient
9608         do iii=1,2
9609           do kkk=1,5
9610             do lll=1,3
9611               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9612      &          pizda(1,1))
9613               vv(1)=pizda(1,1)-pizda(2,2)
9614               vv(2)=pizda(1,2)+pizda(2,1)
9615               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9616      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9617      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9618             enddo
9619           enddo
9620         enddo
9621 cd        goto 1112
9622 C Contribution from graph IV
9623 cd1110    continue
9624         call transpose2(EE(1,1,l),auxmat(1,1))
9625         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9626         vv(1)=pizda(1,1)+pizda(2,2)
9627         vv(2)=pizda(2,1)-pizda(1,2)
9628         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9629      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9630 C Explicit gradient in virtual-dihedral angles.
9631         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9632      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9633         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9634         vv(1)=pizda(1,1)+pizda(2,2)
9635         vv(2)=pizda(2,1)-pizda(1,2)
9636         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9637      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9638      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9639 C Cartesian gradient
9640         do iii=1,2
9641           do kkk=1,5
9642             do lll=1,3
9643               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9644      &          pizda(1,1))
9645               vv(1)=pizda(1,1)+pizda(2,2)
9646               vv(2)=pizda(2,1)-pizda(1,2)
9647               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9648      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9649      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9650             enddo
9651           enddo
9652         enddo
9653       else
9654 C Antiparallel orientation
9655 C Contribution from graph III
9656 c        goto 1110
9657         call transpose2(EUg(1,1,j),auxmat(1,1))
9658         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9659         vv(1)=pizda(1,1)-pizda(2,2)
9660         vv(2)=pizda(1,2)+pizda(2,1)
9661         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9663 C Explicit gradient in virtual-dihedral angles.
9664         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9665      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9666      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9667         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9668         vv(1)=pizda(1,1)-pizda(2,2)
9669         vv(2)=pizda(1,2)+pizda(2,1)
9670         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9671      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9672      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9673         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9674         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9675         vv(1)=pizda(1,1)-pizda(2,2)
9676         vv(2)=pizda(1,2)+pizda(2,1)
9677         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9678      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9679      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9680 C Cartesian gradient
9681         do iii=1,2
9682           do kkk=1,5
9683             do lll=1,3
9684               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9685      &          pizda(1,1))
9686               vv(1)=pizda(1,1)-pizda(2,2)
9687               vv(2)=pizda(1,2)+pizda(2,1)
9688               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9689      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9690      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9691             enddo
9692           enddo
9693         enddo
9694 cd        goto 1112
9695 C Contribution from graph IV
9696 1110    continue
9697         call transpose2(EE(1,1,j),auxmat(1,1))
9698         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9699         vv(1)=pizda(1,1)+pizda(2,2)
9700         vv(2)=pizda(2,1)-pizda(1,2)
9701         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9702      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9703 C Explicit gradient in virtual-dihedral angles.
9704         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9705      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9706         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9707         vv(1)=pizda(1,1)+pizda(2,2)
9708         vv(2)=pizda(2,1)-pizda(1,2)
9709         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9710      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9711      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9712 C Cartesian gradient
9713         do iii=1,2
9714           do kkk=1,5
9715             do lll=1,3
9716               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9717      &          pizda(1,1))
9718               vv(1)=pizda(1,1)+pizda(2,2)
9719               vv(2)=pizda(2,1)-pizda(1,2)
9720               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9721      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9722      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9723             enddo
9724           enddo
9725         enddo
9726       endif
9727 1112  continue
9728       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9729 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9730 cd        write (2,*) 'ijkl',i,j,k,l
9731 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9732 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9733 cd      endif
9734 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9735 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9736 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9737 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9738       if (j.lt.nres-1) then
9739         j1=j+1
9740         j2=j-1
9741       else
9742         j1=j-1
9743         j2=j-2
9744       endif
9745       if (l.lt.nres-1) then
9746         l1=l+1
9747         l2=l-1
9748       else
9749         l1=l-1
9750         l2=l-2
9751       endif
9752 cd      eij=1.0d0
9753 cd      ekl=1.0d0
9754 cd      ekont=1.0d0
9755 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9756 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9757 C        summed up outside the subrouine as for the other subroutines
9758 C        handling long-range interactions. The old code is commented out
9759 C        with "cgrad" to keep track of changes.
9760       do ll=1,3
9761 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9762 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9763         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9764         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9765 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9766 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9767 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9768 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9769 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9770 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9771 c     &   gradcorr5ij,
9772 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9773 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9774 cgrad        ghalf=0.5d0*ggg1(ll)
9775 cd        ghalf=0.0d0
9776         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9777         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9778         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9779         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9780         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9781         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9782 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9783 cgrad        ghalf=0.5d0*ggg2(ll)
9784 cd        ghalf=0.0d0
9785         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9786         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9787         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9788         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9789         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9790         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9791       enddo
9792 cd      goto 1112
9793 cgrad      do m=i+1,j-1
9794 cgrad        do ll=1,3
9795 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9796 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9797 cgrad        enddo
9798 cgrad      enddo
9799 cgrad      do m=k+1,l-1
9800 cgrad        do ll=1,3
9801 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9802 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9803 cgrad        enddo
9804 cgrad      enddo
9805 c1112  continue
9806 cgrad      do m=i+2,j2
9807 cgrad        do ll=1,3
9808 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9809 cgrad        enddo
9810 cgrad      enddo
9811 cgrad      do m=k+2,l2
9812 cgrad        do ll=1,3
9813 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9814 cgrad        enddo
9815 cgrad      enddo
9816 cd      do iii=1,nres-3
9817 cd        write (2,*) iii,g_corr5_loc(iii)
9818 cd      enddo
9819       eello5=ekont*eel5
9820 cd      write (2,*) 'ekont',ekont
9821 cd      write (iout,*) 'eello5',ekont*eel5
9822       return
9823       end
9824 c--------------------------------------------------------------------------
9825       double precision function eello6(i,j,k,l,jj,kk)
9826       implicit real*8 (a-h,o-z)
9827       include 'DIMENSIONS'
9828       include 'COMMON.IOUNITS'
9829       include 'COMMON.CHAIN'
9830       include 'COMMON.DERIV'
9831       include 'COMMON.INTERACT'
9832       include 'COMMON.CONTACTS'
9833       include 'COMMON.TORSION'
9834       include 'COMMON.VAR'
9835       include 'COMMON.GEO'
9836       include 'COMMON.FFIELD'
9837       double precision ggg1(3),ggg2(3)
9838 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9839 cd        eello6=0.0d0
9840 cd        return
9841 cd      endif
9842 cd      write (iout,*)
9843 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9844 cd     &   ' and',k,l
9845       eello6_1=0.0d0
9846       eello6_2=0.0d0
9847       eello6_3=0.0d0
9848       eello6_4=0.0d0
9849       eello6_5=0.0d0
9850       eello6_6=0.0d0
9851 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9852 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9853       do iii=1,2
9854         do kkk=1,5
9855           do lll=1,3
9856             derx(lll,kkk,iii)=0.0d0
9857           enddo
9858         enddo
9859       enddo
9860 cd      eij=facont_hb(jj,i)
9861 cd      ekl=facont_hb(kk,k)
9862 cd      ekont=eij*ekl
9863 cd      eij=1.0d0
9864 cd      ekl=1.0d0
9865 cd      ekont=1.0d0
9866       if (l.eq.j+1) then
9867         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9868         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9869         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9870         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9871         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9872         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9873       else
9874         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9875         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9876         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9877         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9878         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9879           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9880         else
9881           eello6_5=0.0d0
9882         endif
9883         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9884       endif
9885 C If turn contributions are considered, they will be handled separately.
9886       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9887 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9888 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9889 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9890 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9891 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9892 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9893 cd      goto 1112
9894       if (j.lt.nres-1) then
9895         j1=j+1
9896         j2=j-1
9897       else
9898         j1=j-1
9899         j2=j-2
9900       endif
9901       if (l.lt.nres-1) then
9902         l1=l+1
9903         l2=l-1
9904       else
9905         l1=l-1
9906         l2=l-2
9907       endif
9908       do ll=1,3
9909 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9910 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9911 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9912 cgrad        ghalf=0.5d0*ggg1(ll)
9913 cd        ghalf=0.0d0
9914         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9915         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9916         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9917         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9918         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9919         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9920         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9921         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9922 cgrad        ghalf=0.5d0*ggg2(ll)
9923 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9924 cd        ghalf=0.0d0
9925         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9926         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9927         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9928         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9929         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9930         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9931       enddo
9932 cd      goto 1112
9933 cgrad      do m=i+1,j-1
9934 cgrad        do ll=1,3
9935 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9936 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9937 cgrad        enddo
9938 cgrad      enddo
9939 cgrad      do m=k+1,l-1
9940 cgrad        do ll=1,3
9941 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9942 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9943 cgrad        enddo
9944 cgrad      enddo
9945 cgrad1112  continue
9946 cgrad      do m=i+2,j2
9947 cgrad        do ll=1,3
9948 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9949 cgrad        enddo
9950 cgrad      enddo
9951 cgrad      do m=k+2,l2
9952 cgrad        do ll=1,3
9953 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9954 cgrad        enddo
9955 cgrad      enddo
9956 cd      do iii=1,nres-3
9957 cd        write (2,*) iii,g_corr6_loc(iii)
9958 cd      enddo
9959       eello6=ekont*eel6
9960 cd      write (2,*) 'ekont',ekont
9961 cd      write (iout,*) 'eello6',ekont*eel6
9962       return
9963       end
9964 c--------------------------------------------------------------------------
9965       double precision function eello6_graph1(i,j,k,l,imat,swap)
9966       implicit real*8 (a-h,o-z)
9967       include 'DIMENSIONS'
9968       include 'COMMON.IOUNITS'
9969       include 'COMMON.CHAIN'
9970       include 'COMMON.DERIV'
9971       include 'COMMON.INTERACT'
9972       include 'COMMON.CONTACTS'
9973       include 'COMMON.TORSION'
9974       include 'COMMON.VAR'
9975       include 'COMMON.GEO'
9976       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9977       logical swap
9978       logical lprn
9979       common /kutas/ lprn
9980 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9981 C                                                                              C
9982 C      Parallel       Antiparallel                                             C
9983 C                                                                              C
9984 C          o             o                                                     C
9985 C         /l\           /j\                                                    C
9986 C        /   \         /   \                                                   C
9987 C       /| o |         | o |\                                                  C
9988 C     \ j|/k\|  /   \  |/k\|l /                                                C
9989 C      \ /   \ /     \ /   \ /                                                 C
9990 C       o     o       o     o                                                  C
9991 C       i             i                                                        C
9992 C                                                                              C
9993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9994       itk=itype2loc(itype(k))
9995       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9996       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9997       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9998       call transpose2(EUgC(1,1,k),auxmat(1,1))
9999       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10000       vv1(1)=pizda1(1,1)-pizda1(2,2)
10001       vv1(2)=pizda1(1,2)+pizda1(2,1)
10002       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10003       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10004       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10005       s5=scalar2(vv(1),Dtobr2(1,i))
10006 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10007       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10008       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10009      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10010      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10011      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10012      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10013      & +scalar2(vv(1),Dtobr2der(1,i)))
10014       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10015       vv1(1)=pizda1(1,1)-pizda1(2,2)
10016       vv1(2)=pizda1(1,2)+pizda1(2,1)
10017       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10018       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10019       if (l.eq.j+1) then
10020         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10021      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10022      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10023      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10024      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10025       else
10026         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10027      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10028      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10029      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10030      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10031       endif
10032       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10033       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10034       vv1(1)=pizda1(1,1)-pizda1(2,2)
10035       vv1(2)=pizda1(1,2)+pizda1(2,1)
10036       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10037      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10038      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10039      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10040       do iii=1,2
10041         if (swap) then
10042           ind=3-iii
10043         else
10044           ind=iii
10045         endif
10046         do kkk=1,5
10047           do lll=1,3
10048             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10049             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10050             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10051             call transpose2(EUgC(1,1,k),auxmat(1,1))
10052             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10053      &        pizda1(1,1))
10054             vv1(1)=pizda1(1,1)-pizda1(2,2)
10055             vv1(2)=pizda1(1,2)+pizda1(2,1)
10056             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10057             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10058      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10059             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10060      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10061             s5=scalar2(vv(1),Dtobr2(1,i))
10062             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10063           enddo
10064         enddo
10065       enddo
10066       return
10067       end
10068 c----------------------------------------------------------------------------
10069       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10070       implicit real*8 (a-h,o-z)
10071       include 'DIMENSIONS'
10072       include 'COMMON.IOUNITS'
10073       include 'COMMON.CHAIN'
10074       include 'COMMON.DERIV'
10075       include 'COMMON.INTERACT'
10076       include 'COMMON.CONTACTS'
10077       include 'COMMON.TORSION'
10078       include 'COMMON.VAR'
10079       include 'COMMON.GEO'
10080       logical swap
10081       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10082      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10083       logical lprn
10084       common /kutas/ lprn
10085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10086 C                                                                              C
10087 C      Parallel       Antiparallel                                             C
10088 C                                                                              C
10089 C          o             o                                                     C
10090 C     \   /l\           /j\   /                                                C
10091 C      \ /   \         /   \ /                                                 C
10092 C       o| o |         | o |o                                                  C
10093 C     \ j|/k\|      \  |/k\|l                                                  C
10094 C      \ /   \       \ /   \                                                   C
10095 C       o             o                                                        C
10096 C       i             i                                                        C
10097 C                                                                              C
10098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10099 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10100 C AL 7/4/01 s1 would occur in the sixth-order moment,
10101 C           but not in a cluster cumulant
10102 #ifdef MOMENT
10103       s1=dip(1,jj,i)*dip(1,kk,k)
10104 #endif
10105       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10106       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10107       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10108       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10109       call transpose2(EUg(1,1,k),auxmat(1,1))
10110       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10111       vv(1)=pizda(1,1)-pizda(2,2)
10112       vv(2)=pizda(1,2)+pizda(2,1)
10113       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10114 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10115 #ifdef MOMENT
10116       eello6_graph2=-(s1+s2+s3+s4)
10117 #else
10118       eello6_graph2=-(s2+s3+s4)
10119 #endif
10120 c      eello6_graph2=-s3
10121 C Derivatives in gamma(i-1)
10122       if (i.gt.1) then
10123 #ifdef MOMENT
10124         s1=dipderg(1,jj,i)*dip(1,kk,k)
10125 #endif
10126         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10127         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10128         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10129         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10130 #ifdef MOMENT
10131         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10132 #else
10133         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10134 #endif
10135 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10136       endif
10137 C Derivatives in gamma(k-1)
10138 #ifdef MOMENT
10139       s1=dip(1,jj,i)*dipderg(1,kk,k)
10140 #endif
10141       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10142       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10143       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10144       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10145       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10146       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10147       vv(1)=pizda(1,1)-pizda(2,2)
10148       vv(2)=pizda(1,2)+pizda(2,1)
10149       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10150 #ifdef MOMENT
10151       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10152 #else
10153       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10154 #endif
10155 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10156 C Derivatives in gamma(j-1) or gamma(l-1)
10157       if (j.gt.1) then
10158 #ifdef MOMENT
10159         s1=dipderg(3,jj,i)*dip(1,kk,k)
10160 #endif
10161         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10162         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10163         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10164         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10165         vv(1)=pizda(1,1)-pizda(2,2)
10166         vv(2)=pizda(1,2)+pizda(2,1)
10167         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10168 #ifdef MOMENT
10169         if (swap) then
10170           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10171         else
10172           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10173         endif
10174 #endif
10175         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10176 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10177       endif
10178 C Derivatives in gamma(l-1) or gamma(j-1)
10179       if (l.gt.1) then
10180 #ifdef MOMENT
10181         s1=dip(1,jj,i)*dipderg(3,kk,k)
10182 #endif
10183         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10184         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10185         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10186         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10187         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10188         vv(1)=pizda(1,1)-pizda(2,2)
10189         vv(2)=pizda(1,2)+pizda(2,1)
10190         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10191 #ifdef MOMENT
10192         if (swap) then
10193           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10194         else
10195           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10196         endif
10197 #endif
10198         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10199 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10200       endif
10201 C Cartesian derivatives.
10202       if (lprn) then
10203         write (2,*) 'In eello6_graph2'
10204         do iii=1,2
10205           write (2,*) 'iii=',iii
10206           do kkk=1,5
10207             write (2,*) 'kkk=',kkk
10208             do jjj=1,2
10209               write (2,'(3(2f10.5),5x)')
10210      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10211             enddo
10212           enddo
10213         enddo
10214       endif
10215       do iii=1,2
10216         do kkk=1,5
10217           do lll=1,3
10218 #ifdef MOMENT
10219             if (iii.eq.1) then
10220               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10221             else
10222               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10223             endif
10224 #endif
10225             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10226      &        auxvec(1))
10227             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10228             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10229      &        auxvec(1))
10230             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10231             call transpose2(EUg(1,1,k),auxmat(1,1))
10232             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10233      &        pizda(1,1))
10234             vv(1)=pizda(1,1)-pizda(2,2)
10235             vv(2)=pizda(1,2)+pizda(2,1)
10236             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10237 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10238 #ifdef MOMENT
10239             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10240 #else
10241             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10242 #endif
10243             if (swap) then
10244               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10245             else
10246               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10247             endif
10248           enddo
10249         enddo
10250       enddo
10251       return
10252       end
10253 c----------------------------------------------------------------------------
10254       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10255       implicit real*8 (a-h,o-z)
10256       include 'DIMENSIONS'
10257       include 'COMMON.IOUNITS'
10258       include 'COMMON.CHAIN'
10259       include 'COMMON.DERIV'
10260       include 'COMMON.INTERACT'
10261       include 'COMMON.CONTACTS'
10262       include 'COMMON.TORSION'
10263       include 'COMMON.VAR'
10264       include 'COMMON.GEO'
10265       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10266       logical swap
10267 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10268 C                                                                              C
10269 C      Parallel       Antiparallel                                             C
10270 C                                                                              C
10271 C          o             o                                                     C
10272 C         /l\   /   \   /j\                                                    C
10273 C        /   \ /     \ /   \                                                   C
10274 C       /| o |o       o| o |\                                                  C
10275 C       j|/k\|  /      |/k\|l /                                                C
10276 C        /   \ /       /   \ /                                                 C
10277 C       /     o       /     o                                                  C
10278 C       i             i                                                        C
10279 C                                                                              C
10280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10281 C
10282 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10283 C           energy moment and not to the cluster cumulant.
10284       iti=itortyp(itype(i))
10285       if (j.lt.nres-1) then
10286         itj1=itype2loc(itype(j+1))
10287       else
10288         itj1=nloctyp
10289       endif
10290       itk=itype2loc(itype(k))
10291       itk1=itype2loc(itype(k+1))
10292       if (l.lt.nres-1) then
10293         itl1=itype2loc(itype(l+1))
10294       else
10295         itl1=nloctyp
10296       endif
10297 #ifdef MOMENT
10298       s1=dip(4,jj,i)*dip(4,kk,k)
10299 #endif
10300       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10301       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10302       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10303       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10304       call transpose2(EE(1,1,k),auxmat(1,1))
10305       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10306       vv(1)=pizda(1,1)+pizda(2,2)
10307       vv(2)=pizda(2,1)-pizda(1,2)
10308       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10309 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10310 cd     & "sum",-(s2+s3+s4)
10311 #ifdef MOMENT
10312       eello6_graph3=-(s1+s2+s3+s4)
10313 #else
10314       eello6_graph3=-(s2+s3+s4)
10315 #endif
10316 c      eello6_graph3=-s4
10317 C Derivatives in gamma(k-1)
10318       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10319       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10320       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10321       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10322 C Derivatives in gamma(l-1)
10323       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10324       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10325       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10326       vv(1)=pizda(1,1)+pizda(2,2)
10327       vv(2)=pizda(2,1)-pizda(1,2)
10328       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10329       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10330 C Cartesian derivatives.
10331       do iii=1,2
10332         do kkk=1,5
10333           do lll=1,3
10334 #ifdef MOMENT
10335             if (iii.eq.1) then
10336               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10337             else
10338               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10339             endif
10340 #endif
10341             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10342      &        auxvec(1))
10343             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10344             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10345      &        auxvec(1))
10346             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10347             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10348      &        pizda(1,1))
10349             vv(1)=pizda(1,1)+pizda(2,2)
10350             vv(2)=pizda(2,1)-pizda(1,2)
10351             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10352 #ifdef MOMENT
10353             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10354 #else
10355             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10356 #endif
10357             if (swap) then
10358               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10359             else
10360               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10361             endif
10362 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10363           enddo
10364         enddo
10365       enddo
10366       return
10367       end
10368 c----------------------------------------------------------------------------
10369       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10370       implicit real*8 (a-h,o-z)
10371       include 'DIMENSIONS'
10372       include 'COMMON.IOUNITS'
10373       include 'COMMON.CHAIN'
10374       include 'COMMON.DERIV'
10375       include 'COMMON.INTERACT'
10376       include 'COMMON.CONTACTS'
10377       include 'COMMON.TORSION'
10378       include 'COMMON.VAR'
10379       include 'COMMON.GEO'
10380       include 'COMMON.FFIELD'
10381       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10382      & auxvec1(2),auxmat1(2,2)
10383       logical swap
10384 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10385 C                                                                              C
10386 C      Parallel       Antiparallel                                             C
10387 C                                                                              C
10388 C          o             o                                                     C
10389 C         /l\   /   \   /j\                                                    C
10390 C        /   \ /     \ /   \                                                   C
10391 C       /| o |o       o| o |\                                                  C
10392 C     \ j|/k\|      \  |/k\|l                                                  C
10393 C      \ /   \       \ /   \                                                   C
10394 C       o     \       o     \                                                  C
10395 C       i             i                                                        C
10396 C                                                                              C
10397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10398 C
10399 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10400 C           energy moment and not to the cluster cumulant.
10401 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10402       iti=itype2loc(itype(i))
10403       itj=itype2loc(itype(j))
10404       if (j.lt.nres-1) then
10405         itj1=itype2loc(itype(j+1))
10406       else
10407         itj1=nloctyp
10408       endif
10409       itk=itype2loc(itype(k))
10410       if (k.lt.nres-1) then
10411         itk1=itype2loc(itype(k+1))
10412       else
10413         itk1=nloctyp
10414       endif
10415       itl=itype2loc(itype(l))
10416       if (l.lt.nres-1) then
10417         itl1=itype2loc(itype(l+1))
10418       else
10419         itl1=nloctyp
10420       endif
10421 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10422 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10423 cd     & ' itl',itl,' itl1',itl1
10424 #ifdef MOMENT
10425       if (imat.eq.1) then
10426         s1=dip(3,jj,i)*dip(3,kk,k)
10427       else
10428         s1=dip(2,jj,j)*dip(2,kk,l)
10429       endif
10430 #endif
10431       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10432       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10433       if (j.eq.l+1) then
10434         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10435         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10436       else
10437         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10438         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10439       endif
10440       call transpose2(EUg(1,1,k),auxmat(1,1))
10441       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10442       vv(1)=pizda(1,1)-pizda(2,2)
10443       vv(2)=pizda(2,1)+pizda(1,2)
10444       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10445 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10446 #ifdef MOMENT
10447       eello6_graph4=-(s1+s2+s3+s4)
10448 #else
10449       eello6_graph4=-(s2+s3+s4)
10450 #endif
10451 C Derivatives in gamma(i-1)
10452       if (i.gt.1) then
10453 #ifdef MOMENT
10454         if (imat.eq.1) then
10455           s1=dipderg(2,jj,i)*dip(3,kk,k)
10456         else
10457           s1=dipderg(4,jj,j)*dip(2,kk,l)
10458         endif
10459 #endif
10460         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10461         if (j.eq.l+1) then
10462           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10463           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10464         else
10465           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10466           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10467         endif
10468         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10469         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10470 cd          write (2,*) 'turn6 derivatives'
10471 #ifdef MOMENT
10472           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10473 #else
10474           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10475 #endif
10476         else
10477 #ifdef MOMENT
10478           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10479 #else
10480           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10481 #endif
10482         endif
10483       endif
10484 C Derivatives in gamma(k-1)
10485 #ifdef MOMENT
10486       if (imat.eq.1) then
10487         s1=dip(3,jj,i)*dipderg(2,kk,k)
10488       else
10489         s1=dip(2,jj,j)*dipderg(4,kk,l)
10490       endif
10491 #endif
10492       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10493       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10494       if (j.eq.l+1) then
10495         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10496         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10497       else
10498         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10499         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10500       endif
10501       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10502       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10503       vv(1)=pizda(1,1)-pizda(2,2)
10504       vv(2)=pizda(2,1)+pizda(1,2)
10505       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10506       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10507 #ifdef MOMENT
10508         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10509 #else
10510         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10511 #endif
10512       else
10513 #ifdef MOMENT
10514         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10515 #else
10516         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10517 #endif
10518       endif
10519 C Derivatives in gamma(j-1) or gamma(l-1)
10520       if (l.eq.j+1 .and. l.gt.1) then
10521         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10522         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10523         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10524         vv(1)=pizda(1,1)-pizda(2,2)
10525         vv(2)=pizda(2,1)+pizda(1,2)
10526         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10527         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10528       else if (j.gt.1) then
10529         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10530         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10531         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10532         vv(1)=pizda(1,1)-pizda(2,2)
10533         vv(2)=pizda(2,1)+pizda(1,2)
10534         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10535         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10536           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10537         else
10538           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10539         endif
10540       endif
10541 C Cartesian derivatives.
10542       do iii=1,2
10543         do kkk=1,5
10544           do lll=1,3
10545 #ifdef MOMENT
10546             if (iii.eq.1) then
10547               if (imat.eq.1) then
10548                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10549               else
10550                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10551               endif
10552             else
10553               if (imat.eq.1) then
10554                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10555               else
10556                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10557               endif
10558             endif
10559 #endif
10560             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10561      &        auxvec(1))
10562             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10563             if (j.eq.l+1) then
10564               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10565      &          b1(1,j+1),auxvec(1))
10566               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10567             else
10568               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10569      &          b1(1,l+1),auxvec(1))
10570               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10571             endif
10572             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10573      &        pizda(1,1))
10574             vv(1)=pizda(1,1)-pizda(2,2)
10575             vv(2)=pizda(2,1)+pizda(1,2)
10576             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10577             if (swap) then
10578               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10579 #ifdef MOMENT
10580                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10581      &             -(s1+s2+s4)
10582 #else
10583                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10584      &             -(s2+s4)
10585 #endif
10586                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10587               else
10588 #ifdef MOMENT
10589                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10590 #else
10591                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10592 #endif
10593                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10594               endif
10595             else
10596 #ifdef MOMENT
10597               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10598 #else
10599               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10600 #endif
10601               if (l.eq.j+1) then
10602                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10603               else
10604                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10605               endif
10606             endif
10607           enddo
10608         enddo
10609       enddo
10610       return
10611       end
10612 c----------------------------------------------------------------------------
10613       double precision function eello_turn6(i,jj,kk)
10614       implicit real*8 (a-h,o-z)
10615       include 'DIMENSIONS'
10616       include 'COMMON.IOUNITS'
10617       include 'COMMON.CHAIN'
10618       include 'COMMON.DERIV'
10619       include 'COMMON.INTERACT'
10620       include 'COMMON.CONTACTS'
10621       include 'COMMON.TORSION'
10622       include 'COMMON.VAR'
10623       include 'COMMON.GEO'
10624       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10625      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10626      &  ggg1(3),ggg2(3)
10627       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10628      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10629 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10630 C           the respective energy moment and not to the cluster cumulant.
10631       s1=0.0d0
10632       s8=0.0d0
10633       s13=0.0d0
10634 c
10635       eello_turn6=0.0d0
10636       j=i+4
10637       k=i+1
10638       l=i+3
10639       iti=itype2loc(itype(i))
10640       itk=itype2loc(itype(k))
10641       itk1=itype2loc(itype(k+1))
10642       itl=itype2loc(itype(l))
10643       itj=itype2loc(itype(j))
10644 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10645 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10646 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10647 cd        eello6=0.0d0
10648 cd        return
10649 cd      endif
10650 cd      write (iout,*)
10651 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10652 cd     &   ' and',k,l
10653 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10654       do iii=1,2
10655         do kkk=1,5
10656           do lll=1,3
10657             derx_turn(lll,kkk,iii)=0.0d0
10658           enddo
10659         enddo
10660       enddo
10661 cd      eij=1.0d0
10662 cd      ekl=1.0d0
10663 cd      ekont=1.0d0
10664       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10665 cd      eello6_5=0.0d0
10666 cd      write (2,*) 'eello6_5',eello6_5
10667 #ifdef MOMENT
10668       call transpose2(AEA(1,1,1),auxmat(1,1))
10669       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10670       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10671       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10672 #endif
10673       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10674       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10675       s2 = scalar2(b1(1,k),vtemp1(1))
10676 #ifdef MOMENT
10677       call transpose2(AEA(1,1,2),atemp(1,1))
10678       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10679       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10680       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10681 #endif
10682       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10683       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10684       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10685 #ifdef MOMENT
10686       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10687       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10688       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10689       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10690       ss13 = scalar2(b1(1,k),vtemp4(1))
10691       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10692 #endif
10693 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10694 c      s1=0.0d0
10695 c      s2=0.0d0
10696 c      s8=0.0d0
10697 c      s12=0.0d0
10698 c      s13=0.0d0
10699       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10700 C Derivatives in gamma(i+2)
10701       s1d =0.0d0
10702       s8d =0.0d0
10703 #ifdef MOMENT
10704       call transpose2(AEA(1,1,1),auxmatd(1,1))
10705       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10706       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10707       call transpose2(AEAderg(1,1,2),atempd(1,1))
10708       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10709       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10710 #endif
10711       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10712       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10713       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10714 c      s1d=0.0d0
10715 c      s2d=0.0d0
10716 c      s8d=0.0d0
10717 c      s12d=0.0d0
10718 c      s13d=0.0d0
10719       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10720 C Derivatives in gamma(i+3)
10721 #ifdef MOMENT
10722       call transpose2(AEA(1,1,1),auxmatd(1,1))
10723       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10724       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10725       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10726 #endif
10727       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10728       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10729       s2d = scalar2(b1(1,k),vtemp1d(1))
10730 #ifdef MOMENT
10731       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10732       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10733 #endif
10734       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10735 #ifdef MOMENT
10736       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10737       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10738       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10739 #endif
10740 c      s1d=0.0d0
10741 c      s2d=0.0d0
10742 c      s8d=0.0d0
10743 c      s12d=0.0d0
10744 c      s13d=0.0d0
10745 #ifdef MOMENT
10746       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10747      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10748 #else
10749       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10750      &               -0.5d0*ekont*(s2d+s12d)
10751 #endif
10752 C Derivatives in gamma(i+4)
10753       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10754       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10755       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10756 #ifdef MOMENT
10757       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10758       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10759       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10760 #endif
10761 c      s1d=0.0d0
10762 c      s2d=0.0d0
10763 c      s8d=0.0d0
10764 C      s12d=0.0d0
10765 c      s13d=0.0d0
10766 #ifdef MOMENT
10767       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10768 #else
10769       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10770 #endif
10771 C Derivatives in gamma(i+5)
10772 #ifdef MOMENT
10773       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10774       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10775       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10776 #endif
10777       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10778       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10779       s2d = scalar2(b1(1,k),vtemp1d(1))
10780 #ifdef MOMENT
10781       call transpose2(AEA(1,1,2),atempd(1,1))
10782       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10783       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10784 #endif
10785       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10786       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10787 #ifdef MOMENT
10788       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10789       ss13d = scalar2(b1(1,k),vtemp4d(1))
10790       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10791 #endif
10792 c      s1d=0.0d0
10793 c      s2d=0.0d0
10794 c      s8d=0.0d0
10795 c      s12d=0.0d0
10796 c      s13d=0.0d0
10797 #ifdef MOMENT
10798       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10799      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10800 #else
10801       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10802      &               -0.5d0*ekont*(s2d+s12d)
10803 #endif
10804 C Cartesian derivatives
10805       do iii=1,2
10806         do kkk=1,5
10807           do lll=1,3
10808 #ifdef MOMENT
10809             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10810             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10811             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10812 #endif
10813             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10814             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10815      &          vtemp1d(1))
10816             s2d = scalar2(b1(1,k),vtemp1d(1))
10817 #ifdef MOMENT
10818             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10819             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10820             s8d = -(atempd(1,1)+atempd(2,2))*
10821      &           scalar2(cc(1,1,itl),vtemp2(1))
10822 #endif
10823             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10824      &           auxmatd(1,1))
10825             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10826             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10827 c      s1d=0.0d0
10828 c      s2d=0.0d0
10829 c      s8d=0.0d0
10830 c      s12d=0.0d0
10831 c      s13d=0.0d0
10832 #ifdef MOMENT
10833             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10834      &        - 0.5d0*(s1d+s2d)
10835 #else
10836             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10837      &        - 0.5d0*s2d
10838 #endif
10839 #ifdef MOMENT
10840             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10841      &        - 0.5d0*(s8d+s12d)
10842 #else
10843             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10844      &        - 0.5d0*s12d
10845 #endif
10846           enddo
10847         enddo
10848       enddo
10849 #ifdef MOMENT
10850       do kkk=1,5
10851         do lll=1,3
10852           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10853      &      achuj_tempd(1,1))
10854           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10855           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10856           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10857           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10858           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10859      &      vtemp4d(1))
10860           ss13d = scalar2(b1(1,k),vtemp4d(1))
10861           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10862           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10863         enddo
10864       enddo
10865 #endif
10866 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10867 cd     &  16*eel_turn6_num
10868 cd      goto 1112
10869       if (j.lt.nres-1) then
10870         j1=j+1
10871         j2=j-1
10872       else
10873         j1=j-1
10874         j2=j-2
10875       endif
10876       if (l.lt.nres-1) then
10877         l1=l+1
10878         l2=l-1
10879       else
10880         l1=l-1
10881         l2=l-2
10882       endif
10883       do ll=1,3
10884 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10885 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10886 cgrad        ghalf=0.5d0*ggg1(ll)
10887 cd        ghalf=0.0d0
10888         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10889         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10890         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10891      &    +ekont*derx_turn(ll,2,1)
10892         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10893         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10894      &    +ekont*derx_turn(ll,4,1)
10895         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10896         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10897         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10898 cgrad        ghalf=0.5d0*ggg2(ll)
10899 cd        ghalf=0.0d0
10900         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10901      &    +ekont*derx_turn(ll,2,2)
10902         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10903         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10904      &    +ekont*derx_turn(ll,4,2)
10905         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10906         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10907         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10908       enddo
10909 cd      goto 1112
10910 cgrad      do m=i+1,j-1
10911 cgrad        do ll=1,3
10912 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10913 cgrad        enddo
10914 cgrad      enddo
10915 cgrad      do m=k+1,l-1
10916 cgrad        do ll=1,3
10917 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10918 cgrad        enddo
10919 cgrad      enddo
10920 cgrad1112  continue
10921 cgrad      do m=i+2,j2
10922 cgrad        do ll=1,3
10923 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10924 cgrad        enddo
10925 cgrad      enddo
10926 cgrad      do m=k+2,l2
10927 cgrad        do ll=1,3
10928 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10929 cgrad        enddo
10930 cgrad      enddo
10931 cd      do iii=1,nres-3
10932 cd        write (2,*) iii,g_corr6_loc(iii)
10933 cd      enddo
10934       eello_turn6=ekont*eel_turn6
10935 cd      write (2,*) 'ekont',ekont
10936 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10937       return
10938       end
10939
10940 C-----------------------------------------------------------------------------
10941       double precision function scalar(u,v)
10942 !DIR$ INLINEALWAYS scalar
10943 #ifndef OSF
10944 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10945 #endif
10946       implicit none
10947       double precision u(3),v(3)
10948 cd      double precision sc
10949 cd      integer i
10950 cd      sc=0.0d0
10951 cd      do i=1,3
10952 cd        sc=sc+u(i)*v(i)
10953 cd      enddo
10954 cd      scalar=sc
10955
10956       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10957       return
10958       end
10959 crc-------------------------------------------------
10960       SUBROUTINE MATVEC2(A1,V1,V2)
10961 !DIR$ INLINEALWAYS MATVEC2
10962 #ifndef OSF
10963 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10964 #endif
10965       implicit real*8 (a-h,o-z)
10966       include 'DIMENSIONS'
10967       DIMENSION A1(2,2),V1(2),V2(2)
10968 c      DO 1 I=1,2
10969 c        VI=0.0
10970 c        DO 3 K=1,2
10971 c    3     VI=VI+A1(I,K)*V1(K)
10972 c        Vaux(I)=VI
10973 c    1 CONTINUE
10974
10975       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10976       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10977
10978       v2(1)=vaux1
10979       v2(2)=vaux2
10980       END
10981 C---------------------------------------
10982       SUBROUTINE MATMAT2(A1,A2,A3)
10983 #ifndef OSF
10984 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10985 #endif
10986       implicit real*8 (a-h,o-z)
10987       include 'DIMENSIONS'
10988       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10989 c      DIMENSION AI3(2,2)
10990 c        DO  J=1,2
10991 c          A3IJ=0.0
10992 c          DO K=1,2
10993 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10994 c          enddo
10995 c          A3(I,J)=A3IJ
10996 c       enddo
10997 c      enddo
10998
10999       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11000       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11001       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11002       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11003
11004       A3(1,1)=AI3_11
11005       A3(2,1)=AI3_21
11006       A3(1,2)=AI3_12
11007       A3(2,2)=AI3_22
11008       END
11009
11010 c-------------------------------------------------------------------------
11011       double precision function scalar2(u,v)
11012 !DIR$ INLINEALWAYS scalar2
11013       implicit none
11014       double precision u(2),v(2)
11015       double precision sc
11016       integer i
11017       scalar2=u(1)*v(1)+u(2)*v(2)
11018       return
11019       end
11020
11021 C-----------------------------------------------------------------------------
11022
11023       subroutine transpose2(a,at)
11024 !DIR$ INLINEALWAYS transpose2
11025 #ifndef OSF
11026 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11027 #endif
11028       implicit none
11029       double precision a(2,2),at(2,2)
11030       at(1,1)=a(1,1)
11031       at(1,2)=a(2,1)
11032       at(2,1)=a(1,2)
11033       at(2,2)=a(2,2)
11034       return
11035       end
11036 c--------------------------------------------------------------------------
11037       subroutine transpose(n,a,at)
11038       implicit none
11039       integer n,i,j
11040       double precision a(n,n),at(n,n)
11041       do i=1,n
11042         do j=1,n
11043           at(j,i)=a(i,j)
11044         enddo
11045       enddo
11046       return
11047       end
11048 C---------------------------------------------------------------------------
11049       subroutine prodmat3(a1,a2,kk,transp,prod)
11050 !DIR$ INLINEALWAYS prodmat3
11051 #ifndef OSF
11052 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11053 #endif
11054       implicit none
11055       integer i,j
11056       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11057       logical transp
11058 crc      double precision auxmat(2,2),prod_(2,2)
11059
11060       if (transp) then
11061 crc        call transpose2(kk(1,1),auxmat(1,1))
11062 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11063 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11064
11065            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11066      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11067            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11068      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11069            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11070      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11071            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11072      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11073
11074       else
11075 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11076 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11077
11078            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11079      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11080            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11081      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11082            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11083      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11084            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11085      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11086
11087       endif
11088 c      call transpose2(a2(1,1),a2t(1,1))
11089
11090 crc      print *,transp
11091 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11092 crc      print *,((prod(i,j),i=1,2),j=1,2)
11093
11094       return
11095       end
11096 CCC----------------------------------------------
11097       subroutine Eliptransfer(eliptran)
11098       implicit real*8 (a-h,o-z)
11099       include 'DIMENSIONS'
11100       include 'COMMON.GEO'
11101       include 'COMMON.VAR'
11102       include 'COMMON.LOCAL'
11103       include 'COMMON.CHAIN'
11104       include 'COMMON.DERIV'
11105       include 'COMMON.NAMES'
11106       include 'COMMON.INTERACT'
11107       include 'COMMON.IOUNITS'
11108       include 'COMMON.CALC'
11109       include 'COMMON.CONTROL'
11110       include 'COMMON.SPLITELE'
11111       include 'COMMON.SBRIDGE'
11112 C this is done by Adasko
11113 C      print *,"wchodze"
11114 C structure of box:
11115 C      water
11116 C--bordliptop-- buffore starts
11117 C--bufliptop--- here true lipid starts
11118 C      lipid
11119 C--buflipbot--- lipid ends buffore starts
11120 C--bordlipbot--buffore ends
11121       eliptran=0.0
11122       do i=ilip_start,ilip_end
11123 C       do i=1,1
11124         if (itype(i).eq.ntyp1) cycle
11125
11126         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11127         if (positi.le.0.0) positi=positi+boxzsize
11128 C        print *,i
11129 C first for peptide groups
11130 c for each residue check if it is in lipid or lipid water border area
11131        if ((positi.gt.bordlipbot)
11132      &.and.(positi.lt.bordliptop)) then
11133 C the energy transfer exist
11134         if (positi.lt.buflipbot) then
11135 C what fraction I am in
11136          fracinbuf=1.0d0-
11137      &        ((positi-bordlipbot)/lipbufthick)
11138 C lipbufthick is thickenes of lipid buffore
11139          sslip=sscalelip(fracinbuf)
11140          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11141          eliptran=eliptran+sslip*pepliptran
11142          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11143          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11144 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11145
11146 C        print *,"doing sccale for lower part"
11147 C         print *,i,sslip,fracinbuf,ssgradlip
11148         elseif (positi.gt.bufliptop) then
11149          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11150          sslip=sscalelip(fracinbuf)
11151          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11152          eliptran=eliptran+sslip*pepliptran
11153          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11154          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11155 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11156 C          print *, "doing sscalefor top part"
11157 C         print *,i,sslip,fracinbuf,ssgradlip
11158         else
11159          eliptran=eliptran+pepliptran
11160 C         print *,"I am in true lipid"
11161         endif
11162 C       else
11163 C       eliptran=elpitran+0.0 ! I am in water
11164        endif
11165        enddo
11166 C       print *, "nic nie bylo w lipidzie?"
11167 C now multiply all by the peptide group transfer factor
11168 C       eliptran=eliptran*pepliptran
11169 C now the same for side chains
11170 CV       do i=1,1
11171        do i=ilip_start,ilip_end
11172         if (itype(i).eq.ntyp1) cycle
11173         positi=(mod(c(3,i+nres),boxzsize))
11174         if (positi.le.0) positi=positi+boxzsize
11175 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11176 c for each residue check if it is in lipid or lipid water border area
11177 C       respos=mod(c(3,i+nres),boxzsize)
11178 C       print *,positi,bordlipbot,buflipbot
11179        if ((positi.gt.bordlipbot)
11180      & .and.(positi.lt.bordliptop)) then
11181 C the energy transfer exist
11182         if (positi.lt.buflipbot) then
11183          fracinbuf=1.0d0-
11184      &     ((positi-bordlipbot)/lipbufthick)
11185 C lipbufthick is thickenes of lipid buffore
11186          sslip=sscalelip(fracinbuf)
11187          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11188          eliptran=eliptran+sslip*liptranene(itype(i))
11189          gliptranx(3,i)=gliptranx(3,i)
11190      &+ssgradlip*liptranene(itype(i))
11191          gliptranc(3,i-1)= gliptranc(3,i-1)
11192      &+ssgradlip*liptranene(itype(i))
11193 C         print *,"doing sccale for lower part"
11194         elseif (positi.gt.bufliptop) then
11195          fracinbuf=1.0d0-
11196      &((bordliptop-positi)/lipbufthick)
11197          sslip=sscalelip(fracinbuf)
11198          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11199          eliptran=eliptran+sslip*liptranene(itype(i))
11200          gliptranx(3,i)=gliptranx(3,i)
11201      &+ssgradlip*liptranene(itype(i))
11202          gliptranc(3,i-1)= gliptranc(3,i-1)
11203      &+ssgradlip*liptranene(itype(i))
11204 C          print *, "doing sscalefor top part",sslip,fracinbuf
11205         else
11206          eliptran=eliptran+liptranene(itype(i))
11207 C         print *,"I am in true lipid"
11208         endif
11209         endif ! if in lipid or buffor
11210 C       else
11211 C       eliptran=elpitran+0.0 ! I am in water
11212        enddo
11213        return
11214        end
11215 C---------------------------------------------------------
11216 C AFM soubroutine for constant force
11217        subroutine AFMforce(Eafmforce)
11218        implicit real*8 (a-h,o-z)
11219       include 'DIMENSIONS'
11220       include 'COMMON.GEO'
11221       include 'COMMON.VAR'
11222       include 'COMMON.LOCAL'
11223       include 'COMMON.CHAIN'
11224       include 'COMMON.DERIV'
11225       include 'COMMON.NAMES'
11226       include 'COMMON.INTERACT'
11227       include 'COMMON.IOUNITS'
11228       include 'COMMON.CALC'
11229       include 'COMMON.CONTROL'
11230       include 'COMMON.SPLITELE'
11231       include 'COMMON.SBRIDGE'
11232       real*8 diffafm(3)
11233       dist=0.0d0
11234       Eafmforce=0.0d0
11235       do i=1,3
11236       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11237       dist=dist+diffafm(i)**2
11238       enddo
11239       dist=dsqrt(dist)
11240       Eafmforce=-forceAFMconst*(dist-distafminit)
11241       do i=1,3
11242       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11243       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11244       enddo
11245 C      print *,'AFM',Eafmforce
11246       return
11247       end
11248 C---------------------------------------------------------
11249 C AFM subroutine with pseudoconstant velocity
11250        subroutine AFMvel(Eafmforce)
11251        implicit real*8 (a-h,o-z)
11252       include 'DIMENSIONS'
11253       include 'COMMON.GEO'
11254       include 'COMMON.VAR'
11255       include 'COMMON.LOCAL'
11256       include 'COMMON.CHAIN'
11257       include 'COMMON.DERIV'
11258       include 'COMMON.NAMES'
11259       include 'COMMON.INTERACT'
11260       include 'COMMON.IOUNITS'
11261       include 'COMMON.CALC'
11262       include 'COMMON.CONTROL'
11263       include 'COMMON.SPLITELE'
11264       include 'COMMON.SBRIDGE'
11265       real*8 diffafm(3)
11266 C Only for check grad COMMENT if not used for checkgrad
11267 C      totT=3.0d0
11268 C--------------------------------------------------------
11269 C      print *,"wchodze"
11270       dist=0.0d0
11271       Eafmforce=0.0d0
11272       do i=1,3
11273       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11274       dist=dist+diffafm(i)**2
11275       enddo
11276       dist=dsqrt(dist)
11277       Eafmforce=0.5d0*forceAFMconst
11278      & *(distafminit+totTafm*velAFMconst-dist)**2
11279 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11280       do i=1,3
11281       gradafm(i,afmend-1)=-forceAFMconst*
11282      &(distafminit+totTafm*velAFMconst-dist)
11283      &*diffafm(i)/dist
11284       gradafm(i,afmbeg-1)=forceAFMconst*
11285      &(distafminit+totTafm*velAFMconst-dist)
11286      &*diffafm(i)/dist
11287       enddo
11288 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11289       return
11290       end
11291 C-----------------------------------------------------------
11292 C first for shielding is setting of function of side-chains
11293        subroutine set_shield_fac
11294       implicit real*8 (a-h,o-z)
11295       include 'DIMENSIONS'
11296       include 'COMMON.CHAIN'
11297       include 'COMMON.DERIV'
11298       include 'COMMON.IOUNITS'
11299       include 'COMMON.SHIELD'
11300       include 'COMMON.INTERACT'
11301 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11302       double precision div77_81/0.974996043d0/,
11303      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11304
11305 C the vector between center of side_chain and peptide group
11306        double precision pep_side(3),long,side_calf(3),
11307      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11308      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11309 C the line belowe needs to be changed for FGPROC>1
11310       do i=1,nres-1
11311       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11312       ishield_list(i)=0
11313 Cif there two consequtive dummy atoms there is no peptide group between them
11314 C the line below has to be changed for FGPROC>1
11315       VolumeTotal=0.0
11316       do k=1,nres
11317        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11318        dist_pep_side=0.0
11319        dist_side_calf=0.0
11320        do j=1,3
11321 C first lets set vector conecting the ithe side-chain with kth side-chain
11322       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11323 C      pep_side(j)=2.0d0
11324 C and vector conecting the side-chain with its proper calfa
11325       side_calf(j)=c(j,k+nres)-c(j,k)
11326 C      side_calf(j)=2.0d0
11327       pept_group(j)=c(j,i)-c(j,i+1)
11328 C lets have their lenght
11329       dist_pep_side=pep_side(j)**2+dist_pep_side
11330       dist_side_calf=dist_side_calf+side_calf(j)**2
11331       dist_pept_group=dist_pept_group+pept_group(j)**2
11332       enddo
11333        dist_pep_side=dsqrt(dist_pep_side)
11334        dist_pept_group=dsqrt(dist_pept_group)
11335        dist_side_calf=dsqrt(dist_side_calf)
11336       do j=1,3
11337         pep_side_norm(j)=pep_side(j)/dist_pep_side
11338         side_calf_norm(j)=dist_side_calf
11339       enddo
11340 C now sscale fraction
11341        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11342 C       print *,buff_shield,"buff"
11343 C now sscale
11344         if (sh_frac_dist.le.0.0) cycle
11345 C If we reach here it means that this side chain reaches the shielding sphere
11346 C Lets add him to the list for gradient
11347         ishield_list(i)=ishield_list(i)+1
11348 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11349 C this list is essential otherwise problem would be O3
11350         shield_list(ishield_list(i),i)=k
11351 C Lets have the sscale value
11352         if (sh_frac_dist.gt.1.0) then
11353          scale_fac_dist=1.0d0
11354          do j=1,3
11355          sh_frac_dist_grad(j)=0.0d0
11356          enddo
11357         else
11358          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11359      &                   *(2.0*sh_frac_dist-3.0d0)
11360          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11361      &                  /dist_pep_side/buff_shield*0.5
11362 C remember for the final gradient multiply sh_frac_dist_grad(j)
11363 C for side_chain by factor -2 !
11364          do j=1,3
11365          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11366 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11367 C     &                    sh_frac_dist_grad(j)
11368          enddo
11369         endif
11370 C        if ((i.eq.3).and.(k.eq.2)) then
11371 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11372 C     & ,"TU"
11373 C        endif
11374
11375 C this is what is now we have the distance scaling now volume...
11376       short=short_r_sidechain(itype(k))
11377       long=long_r_sidechain(itype(k))
11378       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11379 C now costhet_grad
11380 C       costhet=0.0d0
11381        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11382 C       costhet_fac=0.0d0
11383        do j=1,3
11384          costhet_grad(j)=costhet_fac*pep_side(j)
11385        enddo
11386 C remember for the final gradient multiply costhet_grad(j)
11387 C for side_chain by factor -2 !
11388 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11389 C pep_side0pept_group is vector multiplication
11390       pep_side0pept_group=0.0
11391       do j=1,3
11392       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11393       enddo
11394       cosalfa=(pep_side0pept_group/
11395      & (dist_pep_side*dist_side_calf))
11396       fac_alfa_sin=1.0-cosalfa**2
11397       fac_alfa_sin=dsqrt(fac_alfa_sin)
11398       rkprim=fac_alfa_sin*(long-short)+short
11399 C now costhet_grad
11400        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11401        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11402
11403        do j=1,3
11404          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11405      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11406      &*(long-short)/fac_alfa_sin*cosalfa/
11407      &((dist_pep_side*dist_side_calf))*
11408      &((side_calf(j))-cosalfa*
11409      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11410
11411         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11412      &*(long-short)/fac_alfa_sin*cosalfa
11413      &/((dist_pep_side*dist_side_calf))*
11414      &(pep_side(j)-
11415      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11416        enddo
11417
11418       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11419      &                    /VSolvSphere_div
11420      &                    *wshield
11421 C now the gradient...
11422 C grad_shield is gradient of Calfa for peptide groups
11423 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11424 C     &               costhet,cosphi
11425 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11426 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11427       do j=1,3
11428       grad_shield(j,i)=grad_shield(j,i)
11429 C gradient po skalowaniu
11430      &                +(sh_frac_dist_grad(j)
11431 C  gradient po costhet
11432      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11433      &-scale_fac_dist*(cosphi_grad_long(j))
11434      &/(1.0-cosphi) )*div77_81
11435      &*VofOverlap
11436 C grad_shield_side is Cbeta sidechain gradient
11437       grad_shield_side(j,ishield_list(i),i)=
11438      &        (sh_frac_dist_grad(j)*-2.0d0
11439      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11440      &       +scale_fac_dist*(cosphi_grad_long(j))
11441      &        *2.0d0/(1.0-cosphi))
11442      &        *div77_81*VofOverlap
11443
11444        grad_shield_loc(j,ishield_list(i),i)=
11445      &   scale_fac_dist*cosphi_grad_loc(j)
11446      &        *2.0d0/(1.0-cosphi)
11447      &        *div77_81*VofOverlap
11448       enddo
11449       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11450       enddo
11451       fac_shield(i)=VolumeTotal*div77_81+div4_81
11452 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11453       enddo
11454       return
11455       end
11456 C--------------------------------------------------------------------------
11457       double precision function tschebyshev(m,n,x,y)
11458       implicit none
11459       include "DIMENSIONS"
11460       integer i,m,n
11461       double precision x(n),y,yy(0:maxvar),aux
11462 c Tschebyshev polynomial. Note that the first term is omitted
11463 c m=0: the constant term is included
11464 c m=1: the constant term is not included
11465       yy(0)=1.0d0
11466       yy(1)=y
11467       do i=2,n
11468         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11469       enddo
11470       aux=0.0d0
11471       do i=m,n
11472         aux=aux+x(i)*yy(i)
11473       enddo
11474       tschebyshev=aux
11475       return
11476       end
11477 C--------------------------------------------------------------------------
11478       double precision function gradtschebyshev(m,n,x,y)
11479       implicit none
11480       include "DIMENSIONS"
11481       integer i,m,n
11482       double precision x(n+1),y,yy(0:maxvar),aux
11483 c Tschebyshev polynomial. Note that the first term is omitted
11484 c m=0: the constant term is included
11485 c m=1: the constant term is not included
11486       yy(0)=1.0d0
11487       yy(1)=2.0d0*y
11488       do i=2,n
11489         yy(i)=2*y*yy(i-1)-yy(i-2)
11490       enddo
11491       aux=0.0d0
11492       do i=m,n
11493         aux=aux+x(i+1)*yy(i)*(i+1)
11494 C        print *, x(i+1),yy(i),i
11495       enddo
11496       gradtschebyshev=aux
11497       return
11498       end
11499 C------------------------------------------------------------------------
11500 C first for shielding is setting of function of side-chains
11501        subroutine set_shield_fac2
11502       implicit real*8 (a-h,o-z)
11503       include 'DIMENSIONS'
11504       include 'COMMON.CHAIN'
11505       include 'COMMON.DERIV'
11506       include 'COMMON.IOUNITS'
11507       include 'COMMON.SHIELD'
11508       include 'COMMON.INTERACT'
11509 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11510       double precision div77_81/0.974996043d0/,
11511      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11512
11513 C the vector between center of side_chain and peptide group
11514        double precision pep_side(3),long,side_calf(3),
11515      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11516      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11517 C the line belowe needs to be changed for FGPROC>1
11518       do i=1,nres-1
11519       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11520       ishield_list(i)=0
11521 Cif there two consequtive dummy atoms there is no peptide group between them
11522 C the line below has to be changed for FGPROC>1
11523       VolumeTotal=0.0
11524       do k=1,nres
11525        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11526        dist_pep_side=0.0
11527        dist_side_calf=0.0
11528        do j=1,3
11529 C first lets set vector conecting the ithe side-chain with kth side-chain
11530       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11531 C      pep_side(j)=2.0d0
11532 C and vector conecting the side-chain with its proper calfa
11533       side_calf(j)=c(j,k+nres)-c(j,k)
11534 C      side_calf(j)=2.0d0
11535       pept_group(j)=c(j,i)-c(j,i+1)
11536 C lets have their lenght
11537       dist_pep_side=pep_side(j)**2+dist_pep_side
11538       dist_side_calf=dist_side_calf+side_calf(j)**2
11539       dist_pept_group=dist_pept_group+pept_group(j)**2
11540       enddo
11541        dist_pep_side=dsqrt(dist_pep_side)
11542        dist_pept_group=dsqrt(dist_pept_group)
11543        dist_side_calf=dsqrt(dist_side_calf)
11544       do j=1,3
11545         pep_side_norm(j)=pep_side(j)/dist_pep_side
11546         side_calf_norm(j)=dist_side_calf
11547       enddo
11548 C now sscale fraction
11549        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11550 C       print *,buff_shield,"buff"
11551 C now sscale
11552         if (sh_frac_dist.le.0.0) cycle
11553 C If we reach here it means that this side chain reaches the shielding sphere
11554 C Lets add him to the list for gradient
11555         ishield_list(i)=ishield_list(i)+1
11556 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11557 C this list is essential otherwise problem would be O3
11558         shield_list(ishield_list(i),i)=k
11559 C Lets have the sscale value
11560         if (sh_frac_dist.gt.1.0) then
11561          scale_fac_dist=1.0d0
11562          do j=1,3
11563          sh_frac_dist_grad(j)=0.0d0
11564          enddo
11565         else
11566          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11567      &                   *(2.0d0*sh_frac_dist-3.0d0)
11568          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11569      &                  /dist_pep_side/buff_shield*0.5d0
11570 C remember for the final gradient multiply sh_frac_dist_grad(j)
11571 C for side_chain by factor -2 !
11572          do j=1,3
11573          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11574 C         sh_frac_dist_grad(j)=0.0d0
11575 C         scale_fac_dist=1.0d0
11576 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11577 C     &                    sh_frac_dist_grad(j)
11578          enddo
11579         endif
11580 C this is what is now we have the distance scaling now volume...
11581       short=short_r_sidechain(itype(k))
11582       long=long_r_sidechain(itype(k))
11583       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11584       sinthet=short/dist_pep_side*costhet
11585 C now costhet_grad
11586 C       costhet=0.6d0
11587 C       sinthet=0.8
11588        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11589 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11590 C     &             -short/dist_pep_side**2/costhet)
11591 C       costhet_fac=0.0d0
11592        do j=1,3
11593          costhet_grad(j)=costhet_fac*pep_side(j)
11594        enddo
11595 C remember for the final gradient multiply costhet_grad(j)
11596 C for side_chain by factor -2 !
11597 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11598 C pep_side0pept_group is vector multiplication
11599       pep_side0pept_group=0.0d0
11600       do j=1,3
11601       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11602       enddo
11603       cosalfa=(pep_side0pept_group/
11604      & (dist_pep_side*dist_side_calf))
11605       fac_alfa_sin=1.0d0-cosalfa**2
11606       fac_alfa_sin=dsqrt(fac_alfa_sin)
11607       rkprim=fac_alfa_sin*(long-short)+short
11608 C      rkprim=short
11609
11610 C now costhet_grad
11611        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11612 C       cosphi=0.6
11613        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11614        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11615      &      dist_pep_side**2)
11616 C       sinphi=0.8
11617        do j=1,3
11618          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11619      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11620      &*(long-short)/fac_alfa_sin*cosalfa/
11621      &((dist_pep_side*dist_side_calf))*
11622      &((side_calf(j))-cosalfa*
11623      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11624 C       cosphi_grad_long(j)=0.0d0
11625         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11626      &*(long-short)/fac_alfa_sin*cosalfa
11627      &/((dist_pep_side*dist_side_calf))*
11628      &(pep_side(j)-
11629      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11630 C       cosphi_grad_loc(j)=0.0d0
11631        enddo
11632 C      print *,sinphi,sinthet
11633       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11634      &                    /VSolvSphere_div
11635 C     &                    *wshield
11636 C now the gradient...
11637       do j=1,3
11638       grad_shield(j,i)=grad_shield(j,i)
11639 C gradient po skalowaniu
11640      &                +(sh_frac_dist_grad(j)*VofOverlap
11641 C  gradient po costhet
11642      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11643      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11644      &       sinphi/sinthet*costhet*costhet_grad(j)
11645      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11646      & )*wshield
11647 C grad_shield_side is Cbeta sidechain gradient
11648       grad_shield_side(j,ishield_list(i),i)=
11649      &        (sh_frac_dist_grad(j)*-2.0d0
11650      &        *VofOverlap
11651      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11652      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11653      &       sinphi/sinthet*costhet*costhet_grad(j)
11654      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11655      &       )*wshield
11656
11657        grad_shield_loc(j,ishield_list(i),i)=
11658      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11659      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11660      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11661      &        ))
11662      &        *wshield
11663       enddo
11664       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11665       enddo
11666       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11667 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11668       enddo
11669       return
11670       end
11671