source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.eq.1) then
 146        call set_shield_fac
 147       else if  (shield_mode.eq.2) then
 148        call set_shield_fac2
 149       endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172         write (iout,*) "Soft-spheer ELEC potential"
 173 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174 c     &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 207         call ebend(ebe,ethetacnstr)
 208         endif
 209 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 210 C energy function
 211        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 212          call ebend_kcc(ebe,ethetacnstr)
 213         endif
 214       else
 215         ebe=0
 216         ethetacnstr=0
 217       endif
 218 c      print *,"Processor",myrank," computed UB"
 219 C
 220 C Calculate the SC local energy.
 221 C
 222 C      print *,"TU DOCHODZE?"
 223       call esc(escloc)
 224 c      print *,"Processor",myrank," computed USC"
 225 C
 226 C Calculate the virtual-bond torsional energy.
 227 C
 228 cd    print *,'nterm=',nterm
 229 C      print *,"tor",tor_mode
 230       if (wtor.gt.0) then
 231        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 232        call etor(etors,edihcnstr)
 233        endif
 234 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 235 C energy function
 236        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 237        call etor_kcc(etors,edihcnstr)
 238        endif
 239       else
 240        etors=0
 241        edihcnstr=0
 242       endif
 243 c      print *,"Processor",myrank," computed Utor"
 244 C
 245 C 6/23/01 Calculate double-torsional energy
 246 C
 247       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 248        call etor_d(etors_d)
 249       else
 250        etors_d=0
 251       endif
 252 c      print *,"Processor",myrank," computed Utord"
 253 C
 254 C 21/5/07 Calculate local sicdechain correlation energy
 255 C
 256       if (wsccor.gt.0.0d0) then
 257         call eback_sc_corr(esccor)
 258       else
 259         esccor=0.0d0
 260       endif
 261 C      print *,"PRZED MULIt"
 262 c      print *,"Processor",myrank," computed Usccorr"
 263 C
 264 C 12/1/95 Multi-body terms
 265 C
 266       n_corr=0
 267       n_corr1=0
 268       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 269      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 270          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 271 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 272 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 273       else
 274          ecorr=0.0d0
 275          ecorr5=0.0d0
 276          ecorr6=0.0d0
 277          eturn6=0.0d0
 278       endif
 279       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 280          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 281 cd         write (iout,*) "multibody_hb ecorr",ecorr
 282       endif
 283 c      print *,"Processor",myrank," computed Ucorr"
 284 C
 285 C If performing constraint dynamics, call the constraint energy
 286 C  after the equilibration time
 287       if(usampl.and.totT.gt.eq_time) then
 288          call EconstrQ
 289          call Econstr_back
 290       else
 291          Uconst=0.0d0
 292          Uconst_back=0.0d0
 293       endif
 294 C 01/27/2015 added by adasko
 295 C the energy component below is energy transfer into lipid environment
 296 C based on partition function
 297 C      print *,"przed lipidami"
 298       if (wliptran.gt.0) then
 299         call Eliptransfer(eliptran)
 300       endif
 301 C      print *,"za lipidami"
 302       if (AFMlog.gt.0) then
 303         call AFMforce(Eafmforce)
 304       else if (selfguide.gt.0) then
 305         call AFMvel(Eafmforce)
 306       endif
 307 #ifdef TIMING
 308       time_enecalc=time_enecalc+MPI_Wtime()-time00
 309 #endif
 310 c      print *,"Processor",myrank," computed Uconstr"
 311 #ifdef TIMING
 312       time00=MPI_Wtime()
 313 #endif
 314 c
 315 C Sum the energies
 316 C
 317       energia(1)=evdw
 318 #ifdef SCP14
 319       energia(2)=evdw2-evdw2_14
 320       energia(18)=evdw2_14
 321 #else
 322       energia(2)=evdw2
 323       energia(18)=0.0d0
 324 #endif
 325 #ifdef SPLITELE
 326       energia(3)=ees
 327       energia(16)=evdw1
 328 #else
 329       energia(3)=ees+evdw1
 330       energia(16)=0.0d0
 331 #endif
 332       energia(4)=ecorr
 333       energia(5)=ecorr5
 334       energia(6)=ecorr6
 335       energia(7)=eel_loc
 336       energia(8)=eello_turn3
 337       energia(9)=eello_turn4
 338       energia(10)=eturn6
 339       energia(11)=ebe
 340       energia(12)=escloc
 341       energia(13)=etors
 342       energia(14)=etors_d
 343       energia(15)=ehpb
 344       energia(19)=edihcnstr
 345       energia(17)=estr
 346       energia(20)=Uconst+Uconst_back
 347       energia(21)=esccor
 348       energia(22)=eliptran
 349       energia(23)=Eafmforce
 350       energia(24)=ethetacnstr
 351 c    Here are the energies showed per procesor if the are more processors
 352 c    per molecule then we sum it up in sum_energy subroutine
 353 c      print *," Processor",myrank," calls SUM_ENERGY"
 354       call sum_energy(energia,.true.)
 355       if (dyn_ss) call dyn_set_nss
 356 c      print *," Processor",myrank," left SUM_ENERGY"
 357 #ifdef TIMING
 358       time_sumene=time_sumene+MPI_Wtime()-time00
 359 #endif
 360       return
 361       end
 362 c-------------------------------------------------------------------------------
 363       subroutine sum_energy(energia,reduce)
 364       implicit real*8 (a-h,o-z)
 365       include 'DIMENSIONS'
 366 #ifndef ISNAN
 367       external proc_proc
 368 #ifdef WINPGI
 369 cMS$ATTRIBUTES C ::  proc_proc
 370 #endif
 371 #endif
 372 #ifdef MPI
 373       include "mpif.h"
 374 #endif
 375       include 'COMMON.SETUP'
 376       include 'COMMON.IOUNITS'
 377       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 378       include 'COMMON.FFIELD'
 379       include 'COMMON.DERIV'
 380       include 'COMMON.INTERACT'
 381       include 'COMMON.SBRIDGE'
 382       include 'COMMON.CHAIN'
 383       include 'COMMON.VAR'
 384       include 'COMMON.CONTROL'
 385       include 'COMMON.TIME1'
 386       logical reduce
 387 #ifdef MPI
 388       if (nfgtasks.gt.1 .and. reduce) then
 389 #ifdef DEBUG
 390         write (iout,*) "energies before REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         do i=0,n_ene
 395           enebuff(i)=energia(i)
 396         enddo
 397         time00=MPI_Wtime()
 398         call MPI_Barrier(FG_COMM,IERR)
 399         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 400         time00=MPI_Wtime()
 401         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 402      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 403 #ifdef DEBUG
 404         write (iout,*) "energies after REDUCE"
 405         call enerprint(energia)
 406         call flush(iout)
 407 #endif
 408         time_Reduce=time_Reduce+MPI_Wtime()-time00
 409       endif
 410       if (fg_rank.eq.0) then
 411 #endif
 412       evdw=energia(1)
 413 #ifdef SCP14
 414       evdw2=energia(2)+energia(18)
 415       evdw2_14=energia(18)
 416 #else
 417       evdw2=energia(2)
 418 #endif
 419 #ifdef SPLITELE
 420       ees=energia(3)
 421       evdw1=energia(16)
 422 #else
 423       ees=energia(3)
 424       evdw1=0.0d0
 425 #endif
 426       ecorr=energia(4)
 427       ecorr5=energia(5)
 428       ecorr6=energia(6)
 429       eel_loc=energia(7)
 430       eello_turn3=energia(8)
 431       eello_turn4=energia(9)
 432       eturn6=energia(10)
 433       ebe=energia(11)
 434       escloc=energia(12)
 435       etors=energia(13)
 436       etors_d=energia(14)
 437       ehpb=energia(15)
 438       edihcnstr=energia(19)
 439       estr=energia(17)
 440       Uconst=energia(20)
 441       esccor=energia(21)
 442       eliptran=energia(22)
 443       Eafmforce=energia(23)
 444       ethetacnstr=energia(24)
 445 #ifdef SPLITELE
 446       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 447      & +wang*ebe+wtor*etors+wscloc*escloc
 448      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 449      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 450      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 451      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 452      & +ethetacnstr
 453 #else
 454       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 455      & +wang*ebe+wtor*etors+wscloc*escloc
 456      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 457      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 458      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 459      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 460      & +Eafmforce
 461      & +ethetacnstr
 462 #endif
 463       energia(0)=etot
 464 c detecting NaNQ
 465 #ifdef ISNAN
 466 #ifdef AIX
 467       if (isnan(etot).ne.0) energia(0)=1.0d+99
 468 #else
 469       if (isnan(etot)) energia(0)=1.0d+99
 470 #endif
 471 #else
 472       i=0
 473 #ifdef WINPGI
 474       idumm=proc_proc(etot,i)
 475 #else
 476       call proc_proc(etot,i)
 477 #endif
 478       if(i.eq.1)energia(0)=1.0d+99
 479 #endif
 480 #ifdef MPI
 481       endif
 482 #endif
 483       return
 484       end
 485 c-------------------------------------------------------------------------------
 486       subroutine sum_gradient
 487       implicit real*8 (a-h,o-z)
 488       include 'DIMENSIONS'
 489 #ifndef ISNAN
 490       external proc_proc
 491 #ifdef WINPGI
 492 cMS$ATTRIBUTES C ::  proc_proc
 493 #endif
 494 #endif
 495 #ifdef MPI
 496       include 'mpif.h'
 497 #endif
 498       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 499      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 500      & ,gloc_scbuf(3,-1:maxres)
 501       include 'COMMON.SETUP'
 502       include 'COMMON.IOUNITS'
 503       include 'COMMON.FFIELD'
 504       include 'COMMON.DERIV'
 505       include 'COMMON.INTERACT'
 506       include 'COMMON.SBRIDGE'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.VAR'
 509       include 'COMMON.CONTROL'
 510       include 'COMMON.TIME1'
 511       include 'COMMON.MAXGRAD'
 512       include 'COMMON.SCCOR'
 513 #ifdef TIMING
 514       time01=MPI_Wtime()
 515 #endif
 516 #ifdef DEBUG
 517       write (iout,*) "sum_gradient gvdwc, gvdwx"
 518       do i=1,nres
 519         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 520      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 521       enddo
 522       call flush(iout)
 523 #endif
 524 #ifdef MPI
 525 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 526         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 527      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 528 #endif
 529 C
 530 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 531 C            in virtual-bond-vector coordinates
 532 C
 533 #ifdef DEBUG
 534 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 535 c      do i=1,nres-1
 536 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 537 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 538 c      enddo
 539 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 540 c      do i=1,nres-1
 541 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 542 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 543 c      enddo
 544       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 545       do i=1,nres
 546         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 547      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 548      &   g_corr5_loc(i)
 549       enddo
 550       call flush(iout)
 551 #endif
 552 #ifdef SPLITELE
 553       do i=0,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564      &                +wliptran*gliptranc(j,i)
 565      &                +gradafm(j,i)
 566      &                 +welec*gshieldc(j,i)
 567      &                 +wcorr*gshieldc_ec(j,i)
 568      &                 +wturn3*gshieldc_t3(j,i)
 569      &                 +wturn4*gshieldc_t4(j,i)
 570      &                 +wel_loc*gshieldc_ll(j,i)
 571
 572
 573         enddo
 574       enddo
 575 #else
 576       do i=0,nct
 577         do j=1,3
 578           gradbufc(j,i)=wsc*gvdwc(j,i)+
 579      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 580      &                welec*gelc_long(j,i)+
 581      &                wbond*gradb(j,i)+
 582      &                wel_loc*gel_loc_long(j,i)+
 583      &                wcorr*gradcorr_long(j,i)+
 584      &                wcorr5*gradcorr5_long(j,i)+
 585      &                wcorr6*gradcorr6_long(j,i)+
 586      &                wturn6*gcorr6_turn_long(j,i)+
 587      &                wstrain*ghpbc(j,i)
 588      &                +wliptran*gliptranc(j,i)
 589      &                +gradafm(j,i)
 590      &                 +welec*gshieldc(j,i)
 591      &                 +wcorr*gshieldc_ec(j,i)
 592      &                 +wturn4*gshieldc_t4(j,i)
 593      &                 +wel_loc*gshieldc_ll(j,i)
 594
 595
 596         enddo
 597       enddo
 598 #endif
 599 #ifdef MPI
 600       if (nfgtasks.gt.1) then
 601       time00=MPI_Wtime()
 602 #ifdef DEBUG
 603       write (iout,*) "gradbufc before allreduce"
 604       do i=1,nres
 605         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 606       enddo
 607       call flush(iout)
 608 #endif
 609       do i=0,nres
 610         do j=1,3
 611           gradbufc_sum(j,i)=gradbufc(j,i)
 612         enddo
 613       enddo
 614 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 615 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 616 c      time_reduce=time_reduce+MPI_Wtime()-time00
 617 #ifdef DEBUG
 618 c      write (iout,*) "gradbufc_sum after allreduce"
 619 c      do i=1,nres
 620 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 621 c      enddo
 622 c      call flush(iout)
 623 #endif
 624 #ifdef TIMING
 625 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 626 #endif
 627       do i=nnt,nres
 628         do k=1,3
 629           gradbufc(k,i)=0.0d0
 630         enddo
 631       enddo
 632 #ifdef DEBUG
 633       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 634       write (iout,*) (i," jgrad_start",jgrad_start(i),
 635      &                  " jgrad_end  ",jgrad_end(i),
 636      &                  i=igrad_start,igrad_end)
 637 #endif
 638 c
 639 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 640 c do not parallelize this part.
 641 c
 642 c      do i=igrad_start,igrad_end
 643 c        do j=jgrad_start(i),jgrad_end(i)
 644 c          do k=1,3
 645 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 646 c          enddo
 647 c        enddo
 648 c      enddo
 649       do j=1,3
 650         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 651       enddo
 652       do i=nres-2,-1,-1
 653         do j=1,3
 654           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 655         enddo
 656       enddo
 657 #ifdef DEBUG
 658       write (iout,*) "gradbufc after summing"
 659       do i=1,nres
 660         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 661       enddo
 662       call flush(iout)
 663 #endif
 664       else
 665 #endif
 666 #ifdef DEBUG
 667       write (iout,*) "gradbufc"
 668       do i=1,nres
 669         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 670       enddo
 671       call flush(iout)
 672 #endif
 673       do i=-1,nres
 674         do j=1,3
 675           gradbufc_sum(j,i)=gradbufc(j,i)
 676           gradbufc(j,i)=0.0d0
 677         enddo
 678       enddo
 679       do j=1,3
 680         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 681       enddo
 682       do i=nres-2,-1,-1
 683         do j=1,3
 684           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 685         enddo
 686       enddo
 687 c      do i=nnt,nres-1
 688 c        do k=1,3
 689 c          gradbufc(k,i)=0.0d0
 690 c        enddo
 691 c        do j=i+1,nres
 692 c          do k=1,3
 693 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 694 c          enddo
 695 c        enddo
 696 c      enddo
 697 #ifdef DEBUG
 698       write (iout,*) "gradbufc after summing"
 699       do i=1,nres
 700         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 701       enddo
 702       call flush(iout)
 703 #endif
 704 #ifdef MPI
 705       endif
 706 #endif
 707       do k=1,3
 708         gradbufc(k,nres)=0.0d0
 709       enddo
 710       do i=-1,nct
 711         do j=1,3
 712 #ifdef SPLITELE
 713 C          print *,gradbufc(1,13)
 714 C          print *,welec*gelc(1,13)
 715 C          print *,wel_loc*gel_loc(1,13)
 716 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 717 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 718 C          print *,wel_loc*gel_loc_long(1,13)
 719 C          print *,gradafm(1,13),"AFM"
 720           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 721      &                wel_loc*gel_loc(j,i)+
 722      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 723      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 724      &                wel_loc*gel_loc_long(j,i)+
 725      &                wcorr*gradcorr_long(j,i)+
 726      &                wcorr5*gradcorr5_long(j,i)+
 727      &                wcorr6*gradcorr6_long(j,i)+
 728      &                wturn6*gcorr6_turn_long(j,i))+
 729      &                wbond*gradb(j,i)+
 730      &                wcorr*gradcorr(j,i)+
 731      &                wturn3*gcorr3_turn(j,i)+
 732      &                wturn4*gcorr4_turn(j,i)+
 733      &                wcorr5*gradcorr5(j,i)+
 734      &                wcorr6*gradcorr6(j,i)+
 735      &                wturn6*gcorr6_turn(j,i)+
 736      &                wsccor*gsccorc(j,i)
 737      &               +wscloc*gscloc(j,i)
 738      &               +wliptran*gliptranc(j,i)
 739      &                +gradafm(j,i)
 740      &                 +welec*gshieldc(j,i)
 741      &                 +welec*gshieldc_loc(j,i)
 742      &                 +wcorr*gshieldc_ec(j,i)
 743      &                 +wcorr*gshieldc_loc_ec(j,i)
 744      &                 +wturn3*gshieldc_t3(j,i)
 745      &                 +wturn3*gshieldc_loc_t3(j,i)
 746      &                 +wturn4*gshieldc_t4(j,i)
 747      &                 +wturn4*gshieldc_loc_t4(j,i)
 748      &                 +wel_loc*gshieldc_ll(j,i)
 749      &                 +wel_loc*gshieldc_loc_ll(j,i)
 750
 751
 752
 753
 754
 755
 756 #else
 757           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 758      &                wel_loc*gel_loc(j,i)+
 759      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 760      &                welec*gelc_long(j,i)+
 761      &                wel_loc*gel_loc_long(j,i)+
 762      &                wcorr*gcorr_long(j,i)+
 763      &                wcorr5*gradcorr5_long(j,i)+
 764      &                wcorr6*gradcorr6_long(j,i)+
 765      &                wturn6*gcorr6_turn_long(j,i))+
 766      &                wbond*gradb(j,i)+
 767      &                wcorr*gradcorr(j,i)+
 768      &                wturn3*gcorr3_turn(j,i)+
 769      &                wturn4*gcorr4_turn(j,i)+
 770      &                wcorr5*gradcorr5(j,i)+
 771      &                wcorr6*gradcorr6(j,i)+
 772      &                wturn6*gcorr6_turn(j,i)+
 773      &                wsccor*gsccorc(j,i)
 774      &               +wscloc*gscloc(j,i)
 775      &               +wliptran*gliptranc(j,i)
 776      &                +gradafm(j,i)
 777      &                 +welec*gshieldc(j,i)
 778      &                 +welec*gshieldc_loc(j,i)
 779      &                 +wcorr*gshieldc_ec(j,i)
 780      &                 +wcorr*gshieldc_loc_ec(j,i)
 781      &                 +wturn3*gshieldc_t3(j,i)
 782      &                 +wturn3*gshieldc_loc_t3(j,i)
 783      &                 +wturn4*gshieldc_t4(j,i)
 784      &                 +wturn4*gshieldc_loc_t4(j,i)
 785      &                 +wel_loc*gshieldc_ll(j,i)
 786      &                 +wel_loc*gshieldc_loc_ll(j,i)
 787
 788
 789
 790
 791
 792 #endif
 793           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 794      &                  wbond*gradbx(j,i)+
 795      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 796      &                  wsccor*gsccorx(j,i)
 797      &                 +wscloc*gsclocx(j,i)
 798      &                 +wliptran*gliptranx(j,i)
 799      &                 +welec*gshieldx(j,i)
 800      &                 +wcorr*gshieldx_ec(j,i)
 801      &                 +wturn3*gshieldx_t3(j,i)
 802      &                 +wturn4*gshieldx_t4(j,i)
 803      &                 +wel_loc*gshieldx_ll(j,i)
 804
 805
 806
 807         enddo
 808       enddo
 809 #ifdef DEBUG
 810       write (iout,*) "gloc before adding corr"
 811       do i=1,4*nres
 812         write (iout,*) i,gloc(i,icg)
 813       enddo
 814 #endif
 815       do i=1,nres-3
 816         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 817      &   +wcorr5*g_corr5_loc(i)
 818      &   +wcorr6*g_corr6_loc(i)
 819      &   +wturn4*gel_loc_turn4(i)
 820      &   +wturn3*gel_loc_turn3(i)
 821      &   +wturn6*gel_loc_turn6(i)
 822      &   +wel_loc*gel_loc_loc(i)
 823       enddo
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after adding corr"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830 #ifdef MPI
 831       if (nfgtasks.gt.1) then
 832         do j=1,3
 833           do i=1,nres
 834             gradbufc(j,i)=gradc(j,i,icg)
 835             gradbufx(j,i)=gradx(j,i,icg)
 836           enddo
 837         enddo
 838         do i=1,4*nres
 839           glocbuf(i)=gloc(i,icg)
 840         enddo
 841 c#define DEBUG
 842 #ifdef DEBUG
 843       write (iout,*) "gloc_sc before reduce"
 844       do i=1,nres
 845        do j=1,1
 846         write (iout,*) i,j,gloc_sc(j,i,icg)
 847        enddo
 848       enddo
 849 #endif
 850 c#undef DEBUG
 851         do i=1,nres
 852          do j=1,3
 853           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 854          enddo
 855         enddo
 856         time00=MPI_Wtime()
 857         call MPI_Barrier(FG_COMM,IERR)
 858         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 859         time00=MPI_Wtime()
 860         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 861      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 862         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 863      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 864         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         time_reduce=time_reduce+MPI_Wtime()-time00
 867         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 868      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 869         time_reduce=time_reduce+MPI_Wtime()-time00
 870 c#define DEBUG
 871 #ifdef DEBUG
 872       write (iout,*) "gloc_sc after reduce"
 873       do i=1,nres
 874        do j=1,1
 875         write (iout,*) i,j,gloc_sc(j,i,icg)
 876        enddo
 877       enddo
 878 #endif
 879 c#undef DEBUG
 880 #ifdef DEBUG
 881       write (iout,*) "gloc after reduce"
 882       do i=1,4*nres
 883         write (iout,*) i,gloc(i,icg)
 884       enddo
 885 #endif
 886       endif
 887 #endif
 888       if (gnorm_check) then
 889 c
 890 c Compute the maximum elements of the gradient
 891 c
 892       gvdwc_max=0.0d0
 893       gvdwc_scp_max=0.0d0
 894       gelc_max=0.0d0
 895       gvdwpp_max=0.0d0
 896       gradb_max=0.0d0
 897       ghpbc_max=0.0d0
 898       gradcorr_max=0.0d0
 899       gel_loc_max=0.0d0
 900       gcorr3_turn_max=0.0d0
 901       gcorr4_turn_max=0.0d0
 902       gradcorr5_max=0.0d0
 903       gradcorr6_max=0.0d0
 904       gcorr6_turn_max=0.0d0
 905       gsccorc_max=0.0d0
 906       gscloc_max=0.0d0
 907       gvdwx_max=0.0d0
 908       gradx_scp_max=0.0d0
 909       ghpbx_max=0.0d0
 910       gradxorr_max=0.0d0
 911       gsccorx_max=0.0d0
 912       gsclocx_max=0.0d0
 913       do i=1,nct
 914         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 915         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 916         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 917         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 918      &   gvdwc_scp_max=gvdwc_scp_norm
 919         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 920         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 921         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 922         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 923         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 924         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 925         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 926         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 927         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 928         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 929         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 930         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 931         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 932      &    gcorr3_turn(1,i)))
 933         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 934      &    gcorr3_turn_max=gcorr3_turn_norm
 935         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 936      &    gcorr4_turn(1,i)))
 937         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 938      &    gcorr4_turn_max=gcorr4_turn_norm
 939         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 940         if (gradcorr5_norm.gt.gradcorr5_max)
 941      &    gradcorr5_max=gradcorr5_norm
 942         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 943         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 944         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 945      &    gcorr6_turn(1,i)))
 946         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 947      &    gcorr6_turn_max=gcorr6_turn_norm
 948         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 949         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 950         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 951         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 952         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 953         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 954         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 955         if (gradx_scp_norm.gt.gradx_scp_max)
 956      &    gradx_scp_max=gradx_scp_norm
 957         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 958         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 959         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 960         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 961         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 962         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 963         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 964         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 965       enddo
 966       if (gradout) then
 967 #ifdef AIX
 968         open(istat,file=statname,position="append")
 969 #else
 970         open(istat,file=statname,access="append")
 971 #endif
 972         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 973      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 974      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 975      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 976      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 977      &     gsccorx_max,gsclocx_max
 978         close(istat)
 979         if (gvdwc_max.gt.1.0d4) then
 980           write (iout,*) "gvdwc gvdwx gradb gradbx"
 981           do i=nnt,nct
 982             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 983      &        gradb(j,i),gradbx(j,i),j=1,3)
 984           enddo
 985           call pdbout(0.0d0,'cipiszcze',iout)
 986           call flush(iout)
 987         endif
 988       endif
 989       endif
 990 #ifdef DEBUG
 991       write (iout,*) "gradc gradx gloc"
 992       do i=1,nres
 993         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 994      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 995       enddo
 996 #endif
 997 #ifdef TIMING
 998       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 999 #endif
1000       return
1001       end
1002 c-------------------------------------------------------------------------------
1003       subroutine rescale_weights(t_bath)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.CONTROL'
1010       double precision kfac /2.4d0/
1011       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1012 c      facT=temp0/t_bath
1013 c      facT=2*temp0/(t_bath+temp0)
1014       if (rescale_mode.eq.0) then
1015         facT=1.0d0
1016         facT2=1.0d0
1017         facT3=1.0d0
1018         facT4=1.0d0
1019         facT5=1.0d0
1020       else if (rescale_mode.eq.1) then
1021         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1022         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1023         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1024         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1025         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1026       else if (rescale_mode.eq.2) then
1027         x=t_bath/temp0
1028         x2=x*x
1029         x3=x2*x
1030         x4=x3*x
1031         x5=x4*x
1032         facT=licznik/dlog(dexp(x)+dexp(-x))
1033         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1034         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1035         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1036         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1037       else
1038         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1039         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1040 #ifdef MPI
1041        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1042 #endif
1043        stop 555
1044       endif
1045       if (shield_mode.gt.0) then
1046        wscp=weights(2)*fact
1047        wsc=weights(1)*fact
1048        wvdwpp=weights(16)*fact
1049       endif
1050       welec=weights(3)*fact
1051       wcorr=weights(4)*fact3
1052       wcorr5=weights(5)*fact4
1053       wcorr6=weights(6)*fact5
1054       wel_loc=weights(7)*fact2
1055       wturn3=weights(8)*fact2
1056       wturn4=weights(9)*fact3
1057       wturn6=weights(10)*fact5
1058       wtor=weights(13)*fact
1059       wtor_d=weights(14)*fact2
1060       wsccor=weights(21)*fact
1061
1062       return
1063       end
1064 C------------------------------------------------------------------------
1065       subroutine enerprint(energia)
1066       implicit real*8 (a-h,o-z)
1067       include 'DIMENSIONS'
1068       include 'COMMON.IOUNITS'
1069       include 'COMMON.FFIELD'
1070       include 'COMMON.SBRIDGE'
1071       include 'COMMON.MD'
1072       double precision energia(0:n_ene)
1073       etot=energia(0)
1074       evdw=energia(1)
1075       evdw2=energia(2)
1076 #ifdef SCP14
1077       evdw2=energia(2)+energia(18)
1078 #else
1079       evdw2=energia(2)
1080 #endif
1081       ees=energia(3)
1082 #ifdef SPLITELE
1083       evdw1=energia(16)
1084 #endif
1085       ecorr=energia(4)
1086       ecorr5=energia(5)
1087       ecorr6=energia(6)
1088       eel_loc=energia(7)
1089       eello_turn3=energia(8)
1090       eello_turn4=energia(9)
1091       eello_turn6=energia(10)
1092       ebe=energia(11)
1093       escloc=energia(12)
1094       etors=energia(13)
1095       etors_d=energia(14)
1096       ehpb=energia(15)
1097       edihcnstr=energia(19)
1098       estr=energia(17)
1099       Uconst=energia(20)
1100       esccor=energia(21)
1101       eliptran=energia(22)
1102       Eafmforce=energia(23)
1103       ethetacnstr=energia(24)
1104 #ifdef SPLITELE
1105       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1106      &  estr,wbond,ebe,wang,
1107      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1108      &  ecorr,wcorr,
1109      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1110      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1111      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1112      &  etot
1113    10 format (/'Virtual-chain energies:'//
1114      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1115      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1116      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1117      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1118      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1119      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1120      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1121      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1122      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1123      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1124      & ' (SS bridges & dist. cnstr.)'/
1125      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1126      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1127      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1128      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1129      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1130      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1131      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1132      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1133      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1134      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1135      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1136      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1137      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1138      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1139      & 'ETOT=  ',1pE16.6,' (total)')
1140
1141 #else
1142       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1143      &  estr,wbond,ebe,wang,
1144      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1145      &  ecorr,wcorr,
1146      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1147      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1148      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1149      &  etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1154      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1155      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1156      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1157      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1158      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1159      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1160      & ' (SS bridges & dist. cnstr.)'/
1161      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1162      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1163      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1164      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1165      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1166      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1167      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1168      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1169      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1170      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1171      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1172      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1173      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1174      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1175      & 'ETOT=  ',1pE16.6,' (total)')
1176 #endif
1177       return
1178       end
1179 C-----------------------------------------------------------------------
1180       subroutine elj(evdw)
1181 C
1182 C This subroutine calculates the interaction energy of nonbonded side chains
1183 C assuming the LJ potential of interaction.
1184 C
1185       implicit real*8 (a-h,o-z)
1186       include 'DIMENSIONS'
1187       parameter (accur=1.0d-10)
1188       include 'COMMON.GEO'
1189       include 'COMMON.VAR'
1190       include 'COMMON.LOCAL'
1191       include 'COMMON.CHAIN'
1192       include 'COMMON.DERIV'
1193       include 'COMMON.INTERACT'
1194       include 'COMMON.TORSION'
1195       include 'COMMON.SBRIDGE'
1196       include 'COMMON.NAMES'
1197       include 'COMMON.IOUNITS'
1198       include 'COMMON.CONTACTS'
1199       dimension gg(3)
1200 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1201       evdw=0.0D0
1202       do i=iatsc_s,iatsc_e
1203         itypi=iabs(itype(i))
1204         if (itypi.eq.ntyp1) cycle
1205         itypi1=iabs(itype(i+1))
1206         xi=c(1,nres+i)
1207         yi=c(2,nres+i)
1208         zi=c(3,nres+i)
1209 C Change 12/1/95
1210         num_conti=0
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1216 cd   &                  'iend=',iend(i,iint)
1217           do j=istart(i,iint),iend(i,iint)
1218             itypj=iabs(itype(j))
1219             if (itypj.eq.ntyp1) cycle
1220             xj=c(1,nres+j)-xi
1221             yj=c(2,nres+j)-yi
1222             zj=c(3,nres+j)-zi
1223 C Change 12/1/95 to calculate four-body interactions
1224             rij=xj*xj+yj*yj+zj*zj
1225             rrij=1.0D0/rij
1226 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1227             eps0ij=eps(itypi,itypj)
1228             fac=rrij**expon2
1229 C have you changed here?
1230             e1=fac*fac*aa
1231             e2=fac*bb
1232             evdwij=e1+e2
1233 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1234 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1235 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1236 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1237 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1238 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1239             evdw=evdw+evdwij
1240 C
1241 C Calculate the components of the gradient in DC and X
1242 C
1243             fac=-rrij*(e1+evdwij)
1244             gg(1)=xj*fac
1245             gg(2)=yj*fac
1246             gg(3)=zj*fac
1247             do k=1,3
1248               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1249               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1250               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1251               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1252             enddo
1253 cgrad            do k=i,j-1
1254 cgrad              do l=1,3
1255 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1256 cgrad              enddo
1257 cgrad            enddo
1258 C
1259 C 12/1/95, revised on 5/20/97
1260 C
1261 C Calculate the contact function. The ith column of the array JCONT will
1262 C contain the numbers of atoms that make contacts with the atom I (of numbers
1263 C greater than I). The arrays FACONT and GACONT will contain the values of
1264 C the contact function and its derivative.
1265 C
1266 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1267 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1268 C Uncomment next line, if the correlation interactions are contact function only
1269             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1270               rij=dsqrt(rij)
1271               sigij=sigma(itypi,itypj)
1272               r0ij=rs0(itypi,itypj)
1273 C
1274 C Check whether the SC's are not too far to make a contact.
1275 C
1276               rcut=1.5d0*r0ij
1277               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1278 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1279 C
1280               if (fcont.gt.0.0D0) then
1281 C If the SC-SC distance if close to sigma, apply spline.
1282 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1283 cAdam &             fcont1,fprimcont1)
1284 cAdam           fcont1=1.0d0-fcont1
1285 cAdam           if (fcont1.gt.0.0d0) then
1286 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1287 cAdam             fcont=fcont*fcont1
1288 cAdam           endif
1289 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1290 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1291 cga             do k=1,3
1292 cga               gg(k)=gg(k)*eps0ij
1293 cga             enddo
1294 cga             eps0ij=-evdwij*eps0ij
1295 C Uncomment for AL's type of SC correlation interactions.
1296 cadam           eps0ij=-evdwij
1297                 num_conti=num_conti+1
1298                 jcont(num_conti,i)=j
1299                 facont(num_conti,i)=fcont*eps0ij
1300                 fprimcont=eps0ij*fprimcont/rij
1301                 fcont=expon*fcont
1302 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1303 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1304 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1305 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1306                 gacont(1,num_conti,i)=-fprimcont*xj
1307                 gacont(2,num_conti,i)=-fprimcont*yj
1308                 gacont(3,num_conti,i)=-fprimcont*zj
1309 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1310 cd              write (iout,'(2i3,3f10.5)')
1311 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1312               endif
1313             endif
1314           enddo      ! j
1315         enddo        ! iint
1316 C Change 12/1/95
1317         num_cont(i)=num_conti
1318       enddo          ! i
1319       do i=1,nct
1320         do j=1,3
1321           gvdwc(j,i)=expon*gvdwc(j,i)
1322           gvdwx(j,i)=expon*gvdwx(j,i)
1323         enddo
1324       enddo
1325 C******************************************************************************
1326 C
1327 C                              N O T E !!!
1328 C
1329 C To save time, the factor of EXPON has been extracted from ALL components
1330 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1331 C use!
1332 C
1333 C******************************************************************************
1334       return
1335       end
1336 C-----------------------------------------------------------------------------
1337       subroutine eljk(evdw)
1338 C
1339 C This subroutine calculates the interaction energy of nonbonded side chains
1340 C assuming the LJK potential of interaction.
1341 C
1342       implicit real*8 (a-h,o-z)
1343       include 'DIMENSIONS'
1344       include 'COMMON.GEO'
1345       include 'COMMON.VAR'
1346       include 'COMMON.LOCAL'
1347       include 'COMMON.CHAIN'
1348       include 'COMMON.DERIV'
1349       include 'COMMON.INTERACT'
1350       include 'COMMON.IOUNITS'
1351       include 'COMMON.NAMES'
1352       dimension gg(3)
1353       logical scheck
1354 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1355       evdw=0.0D0
1356       do i=iatsc_s,iatsc_e
1357         itypi=iabs(itype(i))
1358         if (itypi.eq.ntyp1) cycle
1359         itypi1=iabs(itype(i+1))
1360         xi=c(1,nres+i)
1361         yi=c(2,nres+i)
1362         zi=c(3,nres+i)
1363 C
1364 C Calculate SC interaction energy.
1365 C
1366         do iint=1,nint_gr(i)
1367           do j=istart(i,iint),iend(i,iint)
1368             itypj=iabs(itype(j))
1369             if (itypj.eq.ntyp1) cycle
1370             xj=c(1,nres+j)-xi
1371             yj=c(2,nres+j)-yi
1372             zj=c(3,nres+j)-zi
1373             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1374             fac_augm=rrij**expon
1375             e_augm=augm(itypi,itypj)*fac_augm
1376             r_inv_ij=dsqrt(rrij)
1377             rij=1.0D0/r_inv_ij
1378             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1379             fac=r_shift_inv**expon
1380 C have you changed here?
1381             e1=fac*fac*aa
1382             e2=fac*bb
1383             evdwij=e_augm+e1+e2
1384 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1385 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1386 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1387 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1388 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1389 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1390 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1391             evdw=evdw+evdwij
1392 C
1393 C Calculate the components of the gradient in DC and X
1394 C
1395             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1396             gg(1)=xj*fac
1397             gg(2)=yj*fac
1398             gg(3)=zj*fac
1399             do k=1,3
1400               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1401               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1402               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1403               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1404             enddo
1405 cgrad            do k=i,j-1
1406 cgrad              do l=1,3
1407 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1408 cgrad              enddo
1409 cgrad            enddo
1410           enddo      ! j
1411         enddo        ! iint
1412       enddo          ! i
1413       do i=1,nct
1414         do j=1,3
1415           gvdwc(j,i)=expon*gvdwc(j,i)
1416           gvdwx(j,i)=expon*gvdwx(j,i)
1417         enddo
1418       enddo
1419       return
1420       end
1421 C-----------------------------------------------------------------------------
1422       subroutine ebp(evdw)
1423 C
1424 C This subroutine calculates the interaction energy of nonbonded side chains
1425 C assuming the Berne-Pechukas potential of interaction.
1426 C
1427       implicit real*8 (a-h,o-z)
1428       include 'DIMENSIONS'
1429       include 'COMMON.GEO'
1430       include 'COMMON.VAR'
1431       include 'COMMON.LOCAL'
1432       include 'COMMON.CHAIN'
1433       include 'COMMON.DERIV'
1434       include 'COMMON.NAMES'
1435       include 'COMMON.INTERACT'
1436       include 'COMMON.IOUNITS'
1437       include 'COMMON.CALC'
1438       common /srutu/ icall
1439 c     double precision rrsave(maxdim)
1440       logical lprn
1441       evdw=0.0D0
1442 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1443       evdw=0.0D0
1444 c     if (icall.eq.0) then
1445 c       lprn=.true.
1446 c     else
1447         lprn=.false.
1448 c     endif
1449       ind=0
1450       do i=iatsc_s,iatsc_e
1451         itypi=iabs(itype(i))
1452         if (itypi.eq.ntyp1) cycle
1453         itypi1=iabs(itype(i+1))
1454         xi=c(1,nres+i)
1455         yi=c(2,nres+i)
1456         zi=c(3,nres+i)
1457         dxi=dc_norm(1,nres+i)
1458         dyi=dc_norm(2,nres+i)
1459         dzi=dc_norm(3,nres+i)
1460 c        dsci_inv=dsc_inv(itypi)
1461         dsci_inv=vbld_inv(i+nres)
1462 C
1463 C Calculate SC interaction energy.
1464 C
1465         do iint=1,nint_gr(i)
1466           do j=istart(i,iint),iend(i,iint)
1467             ind=ind+1
1468             itypj=iabs(itype(j))
1469             if (itypj.eq.ntyp1) cycle
1470 c            dscj_inv=dsc_inv(itypj)
1471             dscj_inv=vbld_inv(j+nres)
1472             chi1=chi(itypi,itypj)
1473             chi2=chi(itypj,itypi)
1474             chi12=chi1*chi2
1475             chip1=chip(itypi)
1476             chip2=chip(itypj)
1477             chip12=chip1*chip2
1478             alf1=alp(itypi)
1479             alf2=alp(itypj)
1480             alf12=0.5D0*(alf1+alf2)
1481 C For diagnostics only!!!
1482 c           chi1=0.0D0
1483 c           chi2=0.0D0
1484 c           chi12=0.0D0
1485 c           chip1=0.0D0
1486 c           chip2=0.0D0
1487 c           chip12=0.0D0
1488 c           alf1=0.0D0
1489 c           alf2=0.0D0
1490 c           alf12=0.0D0
1491             xj=c(1,nres+j)-xi
1492             yj=c(2,nres+j)-yi
1493             zj=c(3,nres+j)-zi
1494             dxj=dc_norm(1,nres+j)
1495             dyj=dc_norm(2,nres+j)
1496             dzj=dc_norm(3,nres+j)
1497             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1498 cd          if (icall.eq.0) then
1499 cd            rrsave(ind)=rrij
1500 cd          else
1501 cd            rrij=rrsave(ind)
1502 cd          endif
1503             rij=dsqrt(rrij)
1504 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1505             call sc_angular
1506 C Calculate whole angle-dependent part of epsilon and contributions
1507 C to its derivatives
1508 C have you changed here?
1509             fac=(rrij*sigsq)**expon2
1510             e1=fac*fac*aa
1511             e2=fac*bb
1512             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1513             eps2der=evdwij*eps3rt
1514             eps3der=evdwij*eps2rt
1515             evdwij=evdwij*eps2rt*eps3rt
1516             evdw=evdw+evdwij
1517             if (lprn) then
1518             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1519             epsi=bb**2/aa
1520 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1521 cd     &        restyp(itypi),i,restyp(itypj),j,
1522 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1523 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1524 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1525 cd     &        evdwij
1526             endif
1527 C Calculate gradient components.
1528             e1=e1*eps1*eps2rt**2*eps3rt**2
1529             fac=-expon*(e1+evdwij)
1530             sigder=fac/sigsq
1531             fac=rrij*fac
1532 C Calculate radial part of the gradient
1533             gg(1)=xj*fac
1534             gg(2)=yj*fac
1535             gg(3)=zj*fac
1536 C Calculate the angular part of the gradient and sum add the contributions
1537 C to the appropriate components of the Cartesian gradient.
1538             call sc_grad
1539           enddo      ! j
1540         enddo        ! iint
1541       enddo          ! i
1542 c     stop
1543       return
1544       end
1545 C-----------------------------------------------------------------------------
1546       subroutine egb(evdw)
1547 C
1548 C This subroutine calculates the interaction energy of nonbonded side chains
1549 C assuming the Gay-Berne potential of interaction.
1550 C
1551       implicit real*8 (a-h,o-z)
1552       include 'DIMENSIONS'
1553       include 'COMMON.GEO'
1554       include 'COMMON.VAR'
1555       include 'COMMON.LOCAL'
1556       include 'COMMON.CHAIN'
1557       include 'COMMON.DERIV'
1558       include 'COMMON.NAMES'
1559       include 'COMMON.INTERACT'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.CALC'
1562       include 'COMMON.CONTROL'
1563       include 'COMMON.SPLITELE'
1564       include 'COMMON.SBRIDGE'
1565       logical lprn
1566       integer xshift,yshift,zshift
1567
1568       evdw=0.0D0
1569 ccccc      energy_dec=.false.
1570 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1571       evdw=0.0D0
1572       lprn=.false.
1573 c     if (icall.eq.0) lprn=.false.
1574       ind=0
1575 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1576 C we have the original box)
1577 C      do xshift=-1,1
1578 C      do yshift=-1,1
1579 C      do zshift=-1,1
1580       do i=iatsc_s,iatsc_e
1581         itypi=iabs(itype(i))
1582         if (itypi.eq.ntyp1) cycle
1583         itypi1=iabs(itype(i+1))
1584         xi=c(1,nres+i)
1585         yi=c(2,nres+i)
1586         zi=c(3,nres+i)
1587 C Return atom into box, boxxsize is size of box in x dimension
1588 c  134   continue
1589 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1590 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1591 C Condition for being inside the proper box
1592 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1593 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1594 c        go to 134
1595 c        endif
1596 c  135   continue
1597 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1598 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1599 C Condition for being inside the proper box
1600 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1601 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1602 c        go to 135
1603 c        endif
1604 c  136   continue
1605 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1606 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1607 C Condition for being inside the proper box
1608 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1609 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1610 c        go to 136
1611 c        endif
1612           xi=mod(xi,boxxsize)
1613           if (xi.lt.0) xi=xi+boxxsize
1614           yi=mod(yi,boxysize)
1615           if (yi.lt.0) yi=yi+boxysize
1616           zi=mod(zi,boxzsize)
1617           if (zi.lt.0) zi=zi+boxzsize
1618 C define scaling factor for lipids
1619
1620 C        if (positi.le.0) positi=positi+boxzsize
1621 C        print *,i
1622 C first for peptide groups
1623 c for each residue check if it is in lipid or lipid water border area
1624        if ((zi.gt.bordlipbot)
1625      &.and.(zi.lt.bordliptop)) then
1626 C the energy transfer exist
1627         if (zi.lt.buflipbot) then
1628 C what fraction I am in
1629          fracinbuf=1.0d0-
1630      &        ((zi-bordlipbot)/lipbufthick)
1631 C lipbufthick is thickenes of lipid buffore
1632          sslipi=sscalelip(fracinbuf)
1633          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1634         elseif (zi.gt.bufliptop) then
1635          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1636          sslipi=sscalelip(fracinbuf)
1637          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1638         else
1639          sslipi=1.0d0
1640          ssgradlipi=0.0
1641         endif
1642        else
1643          sslipi=0.0d0
1644          ssgradlipi=0.0
1645        endif
1646
1647 C          xi=xi+xshift*boxxsize
1648 C          yi=yi+yshift*boxysize
1649 C          zi=zi+zshift*boxzsize
1650
1651         dxi=dc_norm(1,nres+i)
1652         dyi=dc_norm(2,nres+i)
1653         dzi=dc_norm(3,nres+i)
1654 c        dsci_inv=dsc_inv(itypi)
1655         dsci_inv=vbld_inv(i+nres)
1656 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1657 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1658 C
1659 C Calculate SC interaction energy.
1660 C
1661         do iint=1,nint_gr(i)
1662           do j=istart(i,iint),iend(i,iint)
1663             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1664
1665 c              write(iout,*) "PRZED ZWYKLE", evdwij
1666               call dyn_ssbond_ene(i,j,evdwij)
1667 c              write(iout,*) "PO ZWYKLE", evdwij
1668
1669               evdw=evdw+evdwij
1670               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1671      &                        'evdw',i,j,evdwij,' ss'
1672 C triple bond artifac removal
1673              do k=j+1,iend(i,iint)
1674 C search over all next residues
1675               if (dyn_ss_mask(k)) then
1676 C check if they are cysteins
1677 C              write(iout,*) 'k=',k
1678
1679 c              write(iout,*) "PRZED TRI", evdwij
1680                evdwij_przed_tri=evdwij
1681               call triple_ssbond_ene(i,j,k,evdwij)
1682 c               if(evdwij_przed_tri.ne.evdwij) then
1683 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1684 c               endif
1685
1686 c              write(iout,*) "PO TRI", evdwij
1687 C call the energy function that removes the artifical triple disulfide
1688 C bond the soubroutine is located in ssMD.F
1689               evdw=evdw+evdwij
1690               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1691      &                        'evdw',i,j,evdwij,'tss'
1692               endif!dyn_ss_mask(k)
1693              enddo! k
1694             ELSE
1695             ind=ind+1
1696             itypj=iabs(itype(j))
1697             if (itypj.eq.ntyp1) cycle
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1701 c     &       1.0d0/vbld(j+nres)
1702 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1703             sig0ij=sigma(itypi,itypj)
1704             chi1=chi(itypi,itypj)
1705             chi2=chi(itypj,itypi)
1706             chi12=chi1*chi2
1707             chip1=chip(itypi)
1708             chip2=chip(itypj)
1709             chip12=chip1*chip2
1710             alf1=alp(itypi)
1711             alf2=alp(itypj)
1712             alf12=0.5D0*(alf1+alf2)
1713 C For diagnostics only!!!
1714 c           chi1=0.0D0
1715 c           chi2=0.0D0
1716 c           chi12=0.0D0
1717 c           chip1=0.0D0
1718 c           chip2=0.0D0
1719 c           chip12=0.0D0
1720 c           alf1=0.0D0
1721 c           alf2=0.0D0
1722 c           alf12=0.0D0
1723             xj=c(1,nres+j)
1724             yj=c(2,nres+j)
1725             zj=c(3,nres+j)
1726 C Return atom J into box the original box
1727 c  137   continue
1728 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1729 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1730 C Condition for being inside the proper box
1731 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1732 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1733 c        go to 137
1734 c        endif
1735 c  138   continue
1736 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1737 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1738 C Condition for being inside the proper box
1739 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1740 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1741 c        go to 138
1742 c        endif
1743 c  139   continue
1744 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1745 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1746 C Condition for being inside the proper box
1747 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1748 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1749 c        go to 139
1750 c        endif
1751           xj=mod(xj,boxxsize)
1752           if (xj.lt.0) xj=xj+boxxsize
1753           yj=mod(yj,boxysize)
1754           if (yj.lt.0) yj=yj+boxysize
1755           zj=mod(zj,boxzsize)
1756           if (zj.lt.0) zj=zj+boxzsize
1757        if ((zj.gt.bordlipbot)
1758      &.and.(zj.lt.bordliptop)) then
1759 C the energy transfer exist
1760         if (zj.lt.buflipbot) then
1761 C what fraction I am in
1762          fracinbuf=1.0d0-
1763      &        ((zj-bordlipbot)/lipbufthick)
1764 C lipbufthick is thickenes of lipid buffore
1765          sslipj=sscalelip(fracinbuf)
1766          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1767         elseif (zj.gt.bufliptop) then
1768          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1769          sslipj=sscalelip(fracinbuf)
1770          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1771         else
1772          sslipj=1.0d0
1773          ssgradlipj=0.0
1774         endif
1775        else
1776          sslipj=0.0d0
1777          ssgradlipj=0.0
1778        endif
1779       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1780      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1781       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1782      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1783 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1784 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1785 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1786 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1787 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1788       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1789       xj_safe=xj
1790       yj_safe=yj
1791       zj_safe=zj
1792       subchap=0
1793       do xshift=-1,1
1794       do yshift=-1,1
1795       do zshift=-1,1
1796           xj=xj_safe+xshift*boxxsize
1797           yj=yj_safe+yshift*boxysize
1798           zj=zj_safe+zshift*boxzsize
1799           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1800           if(dist_temp.lt.dist_init) then
1801             dist_init=dist_temp
1802             xj_temp=xj
1803             yj_temp=yj
1804             zj_temp=zj
1805             subchap=1
1806           endif
1807        enddo
1808        enddo
1809        enddo
1810        if (subchap.eq.1) then
1811           xj=xj_temp-xi
1812           yj=yj_temp-yi
1813           zj=zj_temp-zi
1814        else
1815           xj=xj_safe-xi
1816           yj=yj_safe-yi
1817           zj=zj_safe-zi
1818        endif
1819             dxj=dc_norm(1,nres+j)
1820             dyj=dc_norm(2,nres+j)
1821             dzj=dc_norm(3,nres+j)
1822 C            xj=xj-xi
1823 C            yj=yj-yi
1824 C            zj=zj-zi
1825 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1826 c            write (iout,*) "j",j," dc_norm",
1827 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1828             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1829             rij=dsqrt(rrij)
1830             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1831             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1832
1833 c            write (iout,'(a7,4f8.3)')
1834 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1835             if (sss.gt.0.0d0) then
1836 C Calculate angle-dependent terms of energy and contributions to their
1837 C derivatives.
1838             call sc_angular
1839             sigsq=1.0D0/sigsq
1840             sig=sig0ij*dsqrt(sigsq)
1841             rij_shift=1.0D0/rij-sig+sig0ij
1842 c for diagnostics; uncomment
1843 c            rij_shift=1.2*sig0ij
1844 C I hate to put IF's in the loops, but here don't have another choice!!!!
1845             if (rij_shift.le.0.0D0) then
1846               evdw=1.0D20
1847 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1848 cd     &        restyp(itypi),i,restyp(itypj),j,
1849 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1850               return
1851             endif
1852             sigder=-sig*sigsq
1853 c---------------------------------------------------------------
1854             rij_shift=1.0D0/rij_shift
1855             fac=rij_shift**expon
1856 C here to start with
1857 C            if (c(i,3).gt.
1858             faclip=fac
1859             e1=fac*fac*aa
1860             e2=fac*bb
1861             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1862             eps2der=evdwij*eps3rt
1863             eps3der=evdwij*eps2rt
1864 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1865 C     &((sslipi+sslipj)/2.0d0+
1866 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1867 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1868 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1869             evdwij=evdwij*eps2rt*eps3rt
1870             evdw=evdw+evdwij*sss
1871             if (lprn) then
1872             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1873             epsi=bb**2/aa
1874             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1875      &        restyp(itypi),i,restyp(itypj),j,
1876      &        epsi,sigm,chi1,chi2,chip1,chip2,
1877      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1878      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1879      &        evdwij
1880             endif
1881
1882             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1883      &                        'evdw',i,j,evdwij
1884
1885 C Calculate gradient components.
1886             e1=e1*eps1*eps2rt**2*eps3rt**2
1887             fac=-expon*(e1+evdwij)*rij_shift
1888             sigder=fac*sigder
1889             fac=rij*fac
1890 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1891 c     &      evdwij,fac,sigma(itypi,itypj),expon
1892             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1893 c            fac=0.0d0
1894 C Calculate the radial part of the gradient
1895             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1896      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1897      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1898      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1899             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1900             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1901 C            gg_lipi(3)=0.0d0
1902 C            gg_lipj(3)=0.0d0
1903             gg(1)=xj*fac
1904             gg(2)=yj*fac
1905             gg(3)=zj*fac
1906 C Calculate angular part of the gradient.
1907             call sc_grad
1908             endif
1909             ENDIF    ! dyn_ss
1910           enddo      ! j
1911         enddo        ! iint
1912       enddo          ! i
1913 C      enddo          ! zshift
1914 C      enddo          ! yshift
1915 C      enddo          ! xshift
1916 c      write (iout,*) "Number of loop steps in EGB:",ind
1917 cccc      energy_dec=.false.
1918       return
1919       end
1920 C-----------------------------------------------------------------------------
1921       subroutine egbv(evdw)
1922 C
1923 C This subroutine calculates the interaction energy of nonbonded side chains
1924 C assuming the Gay-Berne-Vorobjev potential of interaction.
1925 C
1926       implicit real*8 (a-h,o-z)
1927       include 'DIMENSIONS'
1928       include 'COMMON.GEO'
1929       include 'COMMON.VAR'
1930       include 'COMMON.LOCAL'
1931       include 'COMMON.CHAIN'
1932       include 'COMMON.DERIV'
1933       include 'COMMON.NAMES'
1934       include 'COMMON.INTERACT'
1935       include 'COMMON.IOUNITS'
1936       include 'COMMON.CALC'
1937       common /srutu/ icall
1938       logical lprn
1939       evdw=0.0D0
1940 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1941       evdw=0.0D0
1942       lprn=.false.
1943 c     if (icall.eq.0) lprn=.true.
1944       ind=0
1945       do i=iatsc_s,iatsc_e
1946         itypi=iabs(itype(i))
1947         if (itypi.eq.ntyp1) cycle
1948         itypi1=iabs(itype(i+1))
1949         xi=c(1,nres+i)
1950         yi=c(2,nres+i)
1951         zi=c(3,nres+i)
1952           xi=mod(xi,boxxsize)
1953           if (xi.lt.0) xi=xi+boxxsize
1954           yi=mod(yi,boxysize)
1955           if (yi.lt.0) yi=yi+boxysize
1956           zi=mod(zi,boxzsize)
1957           if (zi.lt.0) zi=zi+boxzsize
1958 C define scaling factor for lipids
1959
1960 C        if (positi.le.0) positi=positi+boxzsize
1961 C        print *,i
1962 C first for peptide groups
1963 c for each residue check if it is in lipid or lipid water border area
1964        if ((zi.gt.bordlipbot)
1965      &.and.(zi.lt.bordliptop)) then
1966 C the energy transfer exist
1967         if (zi.lt.buflipbot) then
1968 C what fraction I am in
1969          fracinbuf=1.0d0-
1970      &        ((zi-bordlipbot)/lipbufthick)
1971 C lipbufthick is thickenes of lipid buffore
1972          sslipi=sscalelip(fracinbuf)
1973          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1974         elseif (zi.gt.bufliptop) then
1975          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1976          sslipi=sscalelip(fracinbuf)
1977          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1978         else
1979          sslipi=1.0d0
1980          ssgradlipi=0.0
1981         endif
1982        else
1983          sslipi=0.0d0
1984          ssgradlipi=0.0
1985        endif
1986
1987         dxi=dc_norm(1,nres+i)
1988         dyi=dc_norm(2,nres+i)
1989         dzi=dc_norm(3,nres+i)
1990 c        dsci_inv=dsc_inv(itypi)
1991         dsci_inv=vbld_inv(i+nres)
1992 C
1993 C Calculate SC interaction energy.
1994 C
1995         do iint=1,nint_gr(i)
1996           do j=istart(i,iint),iend(i,iint)
1997             ind=ind+1
1998             itypj=iabs(itype(j))
1999             if (itypj.eq.ntyp1) cycle
2000 c            dscj_inv=dsc_inv(itypj)
2001             dscj_inv=vbld_inv(j+nres)
2002             sig0ij=sigma(itypi,itypj)
2003             r0ij=r0(itypi,itypj)
2004             chi1=chi(itypi,itypj)
2005             chi2=chi(itypj,itypi)
2006             chi12=chi1*chi2
2007             chip1=chip(itypi)
2008             chip2=chip(itypj)
2009             chip12=chip1*chip2
2010             alf1=alp(itypi)
2011             alf2=alp(itypj)
2012             alf12=0.5D0*(alf1+alf2)
2013 C For diagnostics only!!!
2014 c           chi1=0.0D0
2015 c           chi2=0.0D0
2016 c           chi12=0.0D0
2017 c           chip1=0.0D0
2018 c           chip2=0.0D0
2019 c           chip12=0.0D0
2020 c           alf1=0.0D0
2021 c           alf2=0.0D0
2022 c           alf12=0.0D0
2023 C            xj=c(1,nres+j)-xi
2024 C            yj=c(2,nres+j)-yi
2025 C            zj=c(3,nres+j)-zi
2026           xj=mod(xj,boxxsize)
2027           if (xj.lt.0) xj=xj+boxxsize
2028           yj=mod(yj,boxysize)
2029           if (yj.lt.0) yj=yj+boxysize
2030           zj=mod(zj,boxzsize)
2031           if (zj.lt.0) zj=zj+boxzsize
2032        if ((zj.gt.bordlipbot)
2033      &.and.(zj.lt.bordliptop)) then
2034 C the energy transfer exist
2035         if (zj.lt.buflipbot) then
2036 C what fraction I am in
2037          fracinbuf=1.0d0-
2038      &        ((zj-bordlipbot)/lipbufthick)
2039 C lipbufthick is thickenes of lipid buffore
2040          sslipj=sscalelip(fracinbuf)
2041          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2042         elseif (zj.gt.bufliptop) then
2043          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2044          sslipj=sscalelip(fracinbuf)
2045          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2046         else
2047          sslipj=1.0d0
2048          ssgradlipj=0.0
2049         endif
2050        else
2051          sslipj=0.0d0
2052          ssgradlipj=0.0
2053        endif
2054       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2055      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2056       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2057      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2058 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2059 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2060 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2061       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2062       xj_safe=xj
2063       yj_safe=yj
2064       zj_safe=zj
2065       subchap=0
2066       do xshift=-1,1
2067       do yshift=-1,1
2068       do zshift=-1,1
2069           xj=xj_safe+xshift*boxxsize
2070           yj=yj_safe+yshift*boxysize
2071           zj=zj_safe+zshift*boxzsize
2072           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2073           if(dist_temp.lt.dist_init) then
2074             dist_init=dist_temp
2075             xj_temp=xj
2076             yj_temp=yj
2077             zj_temp=zj
2078             subchap=1
2079           endif
2080        enddo
2081        enddo
2082        enddo
2083        if (subchap.eq.1) then
2084           xj=xj_temp-xi
2085           yj=yj_temp-yi
2086           zj=zj_temp-zi
2087        else
2088           xj=xj_safe-xi
2089           yj=yj_safe-yi
2090           zj=zj_safe-zi
2091        endif
2092             dxj=dc_norm(1,nres+j)
2093             dyj=dc_norm(2,nres+j)
2094             dzj=dc_norm(3,nres+j)
2095             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2096             rij=dsqrt(rrij)
2097 C Calculate angle-dependent terms of energy and contributions to their
2098 C derivatives.
2099             call sc_angular
2100             sigsq=1.0D0/sigsq
2101             sig=sig0ij*dsqrt(sigsq)
2102             rij_shift=1.0D0/rij-sig+r0ij
2103 C I hate to put IF's in the loops, but here don't have another choice!!!!
2104             if (rij_shift.le.0.0D0) then
2105               evdw=1.0D20
2106               return
2107             endif
2108             sigder=-sig*sigsq
2109 c---------------------------------------------------------------
2110             rij_shift=1.0D0/rij_shift
2111             fac=rij_shift**expon
2112             e1=fac*fac*aa
2113             e2=fac*bb
2114             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2115             eps2der=evdwij*eps3rt
2116             eps3der=evdwij*eps2rt
2117             fac_augm=rrij**expon
2118             e_augm=augm(itypi,itypj)*fac_augm
2119             evdwij=evdwij*eps2rt*eps3rt
2120             evdw=evdw+evdwij+e_augm
2121             if (lprn) then
2122             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2123             epsi=bb**2/aa
2124             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2125      &        restyp(itypi),i,restyp(itypj),j,
2126      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2127      &        chi1,chi2,chip1,chip2,
2128      &        eps1,eps2rt**2,eps3rt**2,
2129      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2130      &        evdwij+e_augm
2131             endif
2132 C Calculate gradient components.
2133             e1=e1*eps1*eps2rt**2*eps3rt**2
2134             fac=-expon*(e1+evdwij)*rij_shift
2135             sigder=fac*sigder
2136             fac=rij*fac-2*expon*rrij*e_augm
2137             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2138 C Calculate the radial part of the gradient
2139             gg(1)=xj*fac
2140             gg(2)=yj*fac
2141             gg(3)=zj*fac
2142 C Calculate angular part of the gradient.
2143             call sc_grad
2144           enddo      ! j
2145         enddo        ! iint
2146       enddo          ! i
2147       end
2148 C-----------------------------------------------------------------------------
2149       subroutine sc_angular
2150 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2151 C om12. Called by ebp, egb, and egbv.
2152       implicit none
2153       include 'COMMON.CALC'
2154       include 'COMMON.IOUNITS'
2155       erij(1)=xj*rij
2156       erij(2)=yj*rij
2157       erij(3)=zj*rij
2158       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2159       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2160       om12=dxi*dxj+dyi*dyj+dzi*dzj
2161       chiom12=chi12*om12
2162 C Calculate eps1(om12) and its derivative in om12
2163       faceps1=1.0D0-om12*chiom12
2164       faceps1_inv=1.0D0/faceps1
2165       eps1=dsqrt(faceps1_inv)
2166 C Following variable is eps1*deps1/dom12
2167       eps1_om12=faceps1_inv*chiom12
2168 c diagnostics only
2169 c      faceps1_inv=om12
2170 c      eps1=om12
2171 c      eps1_om12=1.0d0
2172 c      write (iout,*) "om12",om12," eps1",eps1
2173 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2174 C and om12.
2175       om1om2=om1*om2
2176       chiom1=chi1*om1
2177       chiom2=chi2*om2
2178       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2179       sigsq=1.0D0-facsig*faceps1_inv
2180       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2181       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2182       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2183 c diagnostics only
2184 c      sigsq=1.0d0
2185 c      sigsq_om1=0.0d0
2186 c      sigsq_om2=0.0d0
2187 c      sigsq_om12=0.0d0
2188 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2189 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2190 c     &    " eps1",eps1
2191 C Calculate eps2 and its derivatives in om1, om2, and om12.
2192       chipom1=chip1*om1
2193       chipom2=chip2*om2
2194       chipom12=chip12*om12
2195       facp=1.0D0-om12*chipom12
2196       facp_inv=1.0D0/facp
2197       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2198 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2199 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2200 C Following variable is the square root of eps2
2201       eps2rt=1.0D0-facp1*facp_inv
2202 C Following three variables are the derivatives of the square root of eps
2203 C in om1, om2, and om12.
2204       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2205       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2206       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2207 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2208       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2209 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2210 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2211 c     &  " eps2rt_om12",eps2rt_om12
2212 C Calculate whole angle-dependent part of epsilon and contributions
2213 C to its derivatives
2214       return
2215       end
2216 C----------------------------------------------------------------------------
2217       subroutine sc_grad
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220       include 'COMMON.CHAIN'
2221       include 'COMMON.DERIV'
2222       include 'COMMON.CALC'
2223       include 'COMMON.IOUNITS'
2224       double precision dcosom1(3),dcosom2(3)
2225 cc      print *,'sss=',sss
2226       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2227       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2228       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2229      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2230 c diagnostics only
2231 c      eom1=0.0d0
2232 c      eom2=0.0d0
2233 c      eom12=evdwij*eps1_om12
2234 c end diagnostics
2235 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2236 c     &  " sigder",sigder
2237 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2238 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2239       do k=1,3
2240         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2241         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2242       enddo
2243       do k=1,3
2244         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2245       enddo
2246 c      write (iout,*) "gg",(gg(k),k=1,3)
2247       do k=1,3
2248         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2249      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2250      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2251         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2252      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2253      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2254 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2255 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2256 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2257 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2258       enddo
2259 C
2260 C Calculate the components of the gradient in DC and X
2261 C
2262 cgrad      do k=i,j-1
2263 cgrad        do l=1,3
2264 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2265 cgrad        enddo
2266 cgrad      enddo
2267       do l=1,3
2268         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2269         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2270       enddo
2271       return
2272       end
2273 C-----------------------------------------------------------------------
2274       subroutine e_softsphere(evdw)
2275 C
2276 C This subroutine calculates the interaction energy of nonbonded side chains
2277 C assuming the LJ potential of interaction.
2278 C
2279       implicit real*8 (a-h,o-z)
2280       include 'DIMENSIONS'
2281       parameter (accur=1.0d-10)
2282       include 'COMMON.GEO'
2283       include 'COMMON.VAR'
2284       include 'COMMON.LOCAL'
2285       include 'COMMON.CHAIN'
2286       include 'COMMON.DERIV'
2287       include 'COMMON.INTERACT'
2288       include 'COMMON.TORSION'
2289       include 'COMMON.SBRIDGE'
2290       include 'COMMON.NAMES'
2291       include 'COMMON.IOUNITS'
2292       include 'COMMON.CONTACTS'
2293       dimension gg(3)
2294 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2295       evdw=0.0D0
2296       do i=iatsc_s,iatsc_e
2297         itypi=iabs(itype(i))
2298         if (itypi.eq.ntyp1) cycle
2299         itypi1=iabs(itype(i+1))
2300         xi=c(1,nres+i)
2301         yi=c(2,nres+i)
2302         zi=c(3,nres+i)
2303 C
2304 C Calculate SC interaction energy.
2305 C
2306         do iint=1,nint_gr(i)
2307 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2308 cd   &                  'iend=',iend(i,iint)
2309           do j=istart(i,iint),iend(i,iint)
2310             itypj=iabs(itype(j))
2311             if (itypj.eq.ntyp1) cycle
2312             xj=c(1,nres+j)-xi
2313             yj=c(2,nres+j)-yi
2314             zj=c(3,nres+j)-zi
2315             rij=xj*xj+yj*yj+zj*zj
2316 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2317             r0ij=r0(itypi,itypj)
2318             r0ijsq=r0ij*r0ij
2319 c            print *,i,j,r0ij,dsqrt(rij)
2320             if (rij.lt.r0ijsq) then
2321               evdwij=0.25d0*(rij-r0ijsq)**2
2322               fac=rij-r0ijsq
2323             else
2324               evdwij=0.0d0
2325               fac=0.0d0
2326             endif
2327             evdw=evdw+evdwij
2328 C
2329 C Calculate the components of the gradient in DC and X
2330 C
2331             gg(1)=xj*fac
2332             gg(2)=yj*fac
2333             gg(3)=zj*fac
2334             do k=1,3
2335               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2336               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2337               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2338               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2339             enddo
2340 cgrad            do k=i,j-1
2341 cgrad              do l=1,3
2342 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2343 cgrad              enddo
2344 cgrad            enddo
2345           enddo ! j
2346         enddo ! iint
2347       enddo ! i
2348       return
2349       end
2350 C--------------------------------------------------------------------------
2351       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2352      &              eello_turn4)
2353 C
2354 C Soft-sphere potential of p-p interaction
2355 C
2356       implicit real*8 (a-h,o-z)
2357       include 'DIMENSIONS'
2358       include 'COMMON.CONTROL'
2359       include 'COMMON.IOUNITS'
2360       include 'COMMON.GEO'
2361       include 'COMMON.VAR'
2362       include 'COMMON.LOCAL'
2363       include 'COMMON.CHAIN'
2364       include 'COMMON.DERIV'
2365       include 'COMMON.INTERACT'
2366       include 'COMMON.CONTACTS'
2367       include 'COMMON.TORSION'
2368       include 'COMMON.VECTORS'
2369       include 'COMMON.FFIELD'
2370       dimension ggg(3)
2371 C      write(iout,*) 'In EELEC_soft_sphere'
2372       ees=0.0D0
2373       evdw1=0.0D0
2374       eel_loc=0.0d0
2375       eello_turn3=0.0d0
2376       eello_turn4=0.0d0
2377       ind=0
2378       do i=iatel_s,iatel_e
2379         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2380         dxi=dc(1,i)
2381         dyi=dc(2,i)
2382         dzi=dc(3,i)
2383         xmedi=c(1,i)+0.5d0*dxi
2384         ymedi=c(2,i)+0.5d0*dyi
2385         zmedi=c(3,i)+0.5d0*dzi
2386           xmedi=mod(xmedi,boxxsize)
2387           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2388           ymedi=mod(ymedi,boxysize)
2389           if (ymedi.lt.0) ymedi=ymedi+boxysize
2390           zmedi=mod(zmedi,boxzsize)
2391           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2392         num_conti=0
2393 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2394         do j=ielstart(i),ielend(i)
2395           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2396           ind=ind+1
2397           iteli=itel(i)
2398           itelj=itel(j)
2399           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2400           r0ij=rpp(iteli,itelj)
2401           r0ijsq=r0ij*r0ij
2402           dxj=dc(1,j)
2403           dyj=dc(2,j)
2404           dzj=dc(3,j)
2405           xj=c(1,j)+0.5D0*dxj
2406           yj=c(2,j)+0.5D0*dyj
2407           zj=c(3,j)+0.5D0*dzj
2408           xj=mod(xj,boxxsize)
2409           if (xj.lt.0) xj=xj+boxxsize
2410           yj=mod(yj,boxysize)
2411           if (yj.lt.0) yj=yj+boxysize
2412           zj=mod(zj,boxzsize)
2413           if (zj.lt.0) zj=zj+boxzsize
2414       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2415       xj_safe=xj
2416       yj_safe=yj
2417       zj_safe=zj
2418       isubchap=0
2419       do xshift=-1,1
2420       do yshift=-1,1
2421       do zshift=-1,1
2422           xj=xj_safe+xshift*boxxsize
2423           yj=yj_safe+yshift*boxysize
2424           zj=zj_safe+zshift*boxzsize
2425           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2426           if(dist_temp.lt.dist_init) then
2427             dist_init=dist_temp
2428             xj_temp=xj
2429             yj_temp=yj
2430             zj_temp=zj
2431             isubchap=1
2432           endif
2433        enddo
2434        enddo
2435        enddo
2436        if (isubchap.eq.1) then
2437           xj=xj_temp-xmedi
2438           yj=yj_temp-ymedi
2439           zj=zj_temp-zmedi
2440        else
2441           xj=xj_safe-xmedi
2442           yj=yj_safe-ymedi
2443           zj=zj_safe-zmedi
2444        endif
2445           rij=xj*xj+yj*yj+zj*zj
2446             sss=sscale(sqrt(rij))
2447             sssgrad=sscagrad(sqrt(rij))
2448           if (rij.lt.r0ijsq) then
2449             evdw1ij=0.25d0*(rij-r0ijsq)**2
2450             fac=rij-r0ijsq
2451           else
2452             evdw1ij=0.0d0
2453             fac=0.0d0
2454           endif
2455           evdw1=evdw1+evdw1ij*sss
2456 C
2457 C Calculate contributions to the Cartesian gradient.
2458 C
2459           ggg(1)=fac*xj*sssgrad
2460           ggg(2)=fac*yj*sssgrad
2461           ggg(3)=fac*zj*sssgrad
2462           do k=1,3
2463             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2464             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2465           enddo
2466 *
2467 * Loop over residues i+1 thru j-1.
2468 *
2469 cgrad          do k=i+1,j-1
2470 cgrad            do l=1,3
2471 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2472 cgrad            enddo
2473 cgrad          enddo
2474         enddo ! j
2475       enddo   ! i
2476 cgrad      do i=nnt,nct-1
2477 cgrad        do k=1,3
2478 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2479 cgrad        enddo
2480 cgrad        do j=i+1,nct-1
2481 cgrad          do k=1,3
2482 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2483 cgrad          enddo
2484 cgrad        enddo
2485 cgrad      enddo
2486       return
2487       end
2488 c------------------------------------------------------------------------------
2489       subroutine vec_and_deriv
2490       implicit real*8 (a-h,o-z)
2491       include 'DIMENSIONS'
2492 #ifdef MPI
2493       include 'mpif.h'
2494 #endif
2495       include 'COMMON.IOUNITS'
2496       include 'COMMON.GEO'
2497       include 'COMMON.VAR'
2498       include 'COMMON.LOCAL'
2499       include 'COMMON.CHAIN'
2500       include 'COMMON.VECTORS'
2501       include 'COMMON.SETUP'
2502       include 'COMMON.TIME1'
2503       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2504 C Compute the local reference systems. For reference system (i), the
2505 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2506 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2507 #ifdef PARVEC
2508       do i=ivec_start,ivec_end
2509 #else
2510       do i=1,nres-1
2511 #endif
2512           if (i.eq.nres-1) then
2513 C Case of the last full residue
2514 C Compute the Z-axis
2515             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2516             costh=dcos(pi-theta(nres))
2517             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2518             do k=1,3
2519               uz(k,i)=fac*uz(k,i)
2520             enddo
2521 C Compute the derivatives of uz
2522             uzder(1,1,1)= 0.0d0
2523             uzder(2,1,1)=-dc_norm(3,i-1)
2524             uzder(3,1,1)= dc_norm(2,i-1)
2525             uzder(1,2,1)= dc_norm(3,i-1)
2526             uzder(2,2,1)= 0.0d0
2527             uzder(3,2,1)=-dc_norm(1,i-1)
2528             uzder(1,3,1)=-dc_norm(2,i-1)
2529             uzder(2,3,1)= dc_norm(1,i-1)
2530             uzder(3,3,1)= 0.0d0
2531             uzder(1,1,2)= 0.0d0
2532             uzder(2,1,2)= dc_norm(3,i)
2533             uzder(3,1,2)=-dc_norm(2,i)
2534             uzder(1,2,2)=-dc_norm(3,i)
2535             uzder(2,2,2)= 0.0d0
2536             uzder(3,2,2)= dc_norm(1,i)
2537             uzder(1,3,2)= dc_norm(2,i)
2538             uzder(2,3,2)=-dc_norm(1,i)
2539             uzder(3,3,2)= 0.0d0
2540 C Compute the Y-axis
2541             facy=fac
2542             do k=1,3
2543               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2544             enddo
2545 C Compute the derivatives of uy
2546             do j=1,3
2547               do k=1,3
2548                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2549      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2550                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2551               enddo
2552               uyder(j,j,1)=uyder(j,j,1)-costh
2553               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2554             enddo
2555             do j=1,2
2556               do k=1,3
2557                 do l=1,3
2558                   uygrad(l,k,j,i)=uyder(l,k,j)
2559                   uzgrad(l,k,j,i)=uzder(l,k,j)
2560                 enddo
2561               enddo
2562             enddo
2563             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2564             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2565             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2566             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2567           else
2568 C Other residues
2569 C Compute the Z-axis
2570             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2571             costh=dcos(pi-theta(i+2))
2572             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2573             do k=1,3
2574               uz(k,i)=fac*uz(k,i)
2575             enddo
2576 C Compute the derivatives of uz
2577             uzder(1,1,1)= 0.0d0
2578             uzder(2,1,1)=-dc_norm(3,i+1)
2579             uzder(3,1,1)= dc_norm(2,i+1)
2580             uzder(1,2,1)= dc_norm(3,i+1)
2581             uzder(2,2,1)= 0.0d0
2582             uzder(3,2,1)=-dc_norm(1,i+1)
2583             uzder(1,3,1)=-dc_norm(2,i+1)
2584             uzder(2,3,1)= dc_norm(1,i+1)
2585             uzder(3,3,1)= 0.0d0
2586             uzder(1,1,2)= 0.0d0
2587             uzder(2,1,2)= dc_norm(3,i)
2588             uzder(3,1,2)=-dc_norm(2,i)
2589             uzder(1,2,2)=-dc_norm(3,i)
2590             uzder(2,2,2)= 0.0d0
2591             uzder(3,2,2)= dc_norm(1,i)
2592             uzder(1,3,2)= dc_norm(2,i)
2593             uzder(2,3,2)=-dc_norm(1,i)
2594             uzder(3,3,2)= 0.0d0
2595 C Compute the Y-axis
2596             facy=fac
2597             do k=1,3
2598               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2599             enddo
2600 C Compute the derivatives of uy
2601             do j=1,3
2602               do k=1,3
2603                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2604      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2605                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2606               enddo
2607               uyder(j,j,1)=uyder(j,j,1)-costh
2608               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2609             enddo
2610             do j=1,2
2611               do k=1,3
2612                 do l=1,3
2613                   uygrad(l,k,j,i)=uyder(l,k,j)
2614                   uzgrad(l,k,j,i)=uzder(l,k,j)
2615                 enddo
2616               enddo
2617             enddo
2618             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2619             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2620             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2621             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2622           endif
2623       enddo
2624       do i=1,nres-1
2625         vbld_inv_temp(1)=vbld_inv(i+1)
2626         if (i.lt.nres-1) then
2627           vbld_inv_temp(2)=vbld_inv(i+2)
2628           else
2629           vbld_inv_temp(2)=vbld_inv(i)
2630           endif
2631         do j=1,2
2632           do k=1,3
2633             do l=1,3
2634               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2635               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2636             enddo
2637           enddo
2638         enddo
2639       enddo
2640 #if defined(PARVEC) && defined(MPI)
2641       if (nfgtasks1.gt.1) then
2642         time00=MPI_Wtime()
2643 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2644 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2645 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2646         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2654      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2655         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2656      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2657      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2658         time_gather=time_gather+MPI_Wtime()-time00
2659       endif
2660 c      if (fg_rank.eq.0) then
2661 c        write (iout,*) "Arrays UY and UZ"
2662 c        do i=1,nres-1
2663 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2664 c     &     (uz(k,i),k=1,3)
2665 c        enddo
2666 c      endif
2667 #endif
2668       return
2669       end
2670 C-----------------------------------------------------------------------------
2671       subroutine check_vecgrad
2672       implicit real*8 (a-h,o-z)
2673       include 'DIMENSIONS'
2674       include 'COMMON.IOUNITS'
2675       include 'COMMON.GEO'
2676       include 'COMMON.VAR'
2677       include 'COMMON.LOCAL'
2678       include 'COMMON.CHAIN'
2679       include 'COMMON.VECTORS'
2680       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2681       dimension uyt(3,maxres),uzt(3,maxres)
2682       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2683       double precision delta /1.0d-7/
2684       call vec_and_deriv
2685 cd      do i=1,nres
2686 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2687 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2688 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2689 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2690 cd     &     (dc_norm(if90,i),if90=1,3)
2691 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2692 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2693 cd          write(iout,'(a)')
2694 cd      enddo
2695       do i=1,nres
2696         do j=1,2
2697           do k=1,3
2698             do l=1,3
2699               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2700               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2701             enddo
2702           enddo
2703         enddo
2704       enddo
2705       call vec_and_deriv
2706       do i=1,nres
2707         do j=1,3
2708           uyt(j,i)=uy(j,i)
2709           uzt(j,i)=uz(j,i)
2710         enddo
2711       enddo
2712       do i=1,nres
2713 cd        write (iout,*) 'i=',i
2714         do k=1,3
2715           erij(k)=dc_norm(k,i)
2716         enddo
2717         do j=1,3
2718           do k=1,3
2719             dc_norm(k,i)=erij(k)
2720           enddo
2721           dc_norm(j,i)=dc_norm(j,i)+delta
2722 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2723 c          do k=1,3
2724 c            dc_norm(k,i)=dc_norm(k,i)/fac
2725 c          enddo
2726 c          write (iout,*) (dc_norm(k,i),k=1,3)
2727 c          write (iout,*) (erij(k),k=1,3)
2728           call vec_and_deriv
2729           do k=1,3
2730             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2731             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2732             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2733             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2734           enddo
2735 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2736 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2737 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2738         enddo
2739         do k=1,3
2740           dc_norm(k,i)=erij(k)
2741         enddo
2742 cd        do k=1,3
2743 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2744 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2745 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2746 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2747 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2748 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2749 cd          write (iout,'(a)')
2750 cd        enddo
2751       enddo
2752       return
2753       end
2754 C--------------------------------------------------------------------------
2755       subroutine set_matrices
2756       implicit real*8 (a-h,o-z)
2757       include 'DIMENSIONS'
2758 #ifdef MPI
2759       include "mpif.h"
2760       include "COMMON.SETUP"
2761       integer IERR
2762       integer status(MPI_STATUS_SIZE)
2763 #endif
2764       include 'COMMON.IOUNITS'
2765       include 'COMMON.GEO'
2766       include 'COMMON.VAR'
2767       include 'COMMON.LOCAL'
2768       include 'COMMON.CHAIN'
2769       include 'COMMON.DERIV'
2770       include 'COMMON.INTERACT'
2771       include 'COMMON.CONTACTS'
2772       include 'COMMON.TORSION'
2773       include 'COMMON.VECTORS'
2774       include 'COMMON.FFIELD'
2775       double precision auxvec(2),auxmat(2,2)
2776 C
2777 C Compute the virtual-bond-torsional-angle dependent quantities needed
2778 C to calculate the el-loc multibody terms of various order.
2779 C
2780 c      write(iout,*) 'nphi=',nphi,nres
2781 #ifdef PARMAT
2782       do i=ivec_start+2,ivec_end+2
2783 #else
2784       do i=3,nres+1
2785 #endif
2786 #ifdef NEWCORR
2787         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2788           iti = itype2loc(itype(i-2))
2789         else
2790           iti=nloctyp
2791         endif
2792 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2793         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2794           iti1 = itype2loc(itype(i-1))
2795         else
2796           iti1=nloctyp
2797         endif
2798 c        write(iout,*),i
2799         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2800      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2801      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2802         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2803      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2804      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2805 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2806 c     &*(cos(theta(i)/2.0)
2807         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2808      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2809      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2810 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2811 c     &*(cos(theta(i)/2.0)
2812         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2813      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2814      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2815 c        if (ggb1(1,i).eq.0.0d0) then
2816 c        write(iout,*) 'i=',i,ggb1(1,i),
2817 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2818 c     &bnew1(2,1,iti)*cos(theta(i)),
2819 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2820 c        endif
2821         b1(2,i-2)=bnew1(1,2,iti)
2822         gtb1(2,i-2)=0.0
2823         b2(2,i-2)=bnew2(1,2,iti)
2824         gtb2(2,i-2)=0.0
2825         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2826         EE(1,2,i-2)=eeold(1,2,iti)
2827         EE(2,1,i-2)=eeold(2,1,iti)
2828         EE(2,2,i-2)=eeold(2,2,iti)
2829         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2830         gtEE(1,2,i-2)=0.0d0
2831         gtEE(2,2,i-2)=0.0d0
2832         gtEE(2,1,i-2)=0.0d0
2833 c        EE(2,2,iti)=0.0d0
2834 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2835 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2836 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2837 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2838        b1tilde(1,i-2)=b1(1,i-2)
2839        b1tilde(2,i-2)=-b1(2,i-2)
2840        b2tilde(1,i-2)=b2(1,i-2)
2841        b2tilde(2,i-2)=-b2(2,i-2)
2842 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2843 c       write(iout,*)  'b1=',b1(1,i-2)
2844 c       write (iout,*) 'theta=', theta(i-1)
2845        enddo
2846 #else
2847         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2848           iti = itype2loc(itype(i-2))
2849         else
2850           iti=nloctyp
2851         endif
2852 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2853         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2854           iti1 = itype2loc(itype(i-1))
2855         else
2856           iti1=nloctyp
2857         endif
2858         b1(1,i-2)=b(3,iti)
2859         b1(2,i-2)=b(5,iti)
2860         b2(1,i-2)=b(2,iti)
2861         b2(2,i-2)=b(4,iti)
2862        b1tilde(1,i-2)=b1(1,i-2)
2863        b1tilde(2,i-2)=-b1(2,i-2)
2864        b2tilde(1,i-2)=b2(1,i-2)
2865        b2tilde(2,i-2)=-b2(2,i-2)
2866         EE(1,2,i-2)=eeold(1,2,iti)
2867         EE(2,1,i-2)=eeold(2,1,iti)
2868         EE(2,2,i-2)=eeold(2,2,iti)
2869         EE(1,1,i-2)=eeold(1,1,iti)
2870       enddo
2871 #endif
2872 #ifdef PARMAT
2873       do i=ivec_start+2,ivec_end+2
2874 #else
2875       do i=3,nres+1
2876 #endif
2877         if (i .lt. nres+1) then
2878           sin1=dsin(phi(i))
2879           cos1=dcos(phi(i))
2880           sintab(i-2)=sin1
2881           costab(i-2)=cos1
2882           obrot(1,i-2)=cos1
2883           obrot(2,i-2)=sin1
2884           sin2=dsin(2*phi(i))
2885           cos2=dcos(2*phi(i))
2886           sintab2(i-2)=sin2
2887           costab2(i-2)=cos2
2888           obrot2(1,i-2)=cos2
2889           obrot2(2,i-2)=sin2
2890           Ug(1,1,i-2)=-cos1
2891           Ug(1,2,i-2)=-sin1
2892           Ug(2,1,i-2)=-sin1
2893           Ug(2,2,i-2)= cos1
2894           Ug2(1,1,i-2)=-cos2
2895           Ug2(1,2,i-2)=-sin2
2896           Ug2(2,1,i-2)=-sin2
2897           Ug2(2,2,i-2)= cos2
2898         else
2899           costab(i-2)=1.0d0
2900           sintab(i-2)=0.0d0
2901           obrot(1,i-2)=1.0d0
2902           obrot(2,i-2)=0.0d0
2903           obrot2(1,i-2)=0.0d0
2904           obrot2(2,i-2)=0.0d0
2905           Ug(1,1,i-2)=1.0d0
2906           Ug(1,2,i-2)=0.0d0
2907           Ug(2,1,i-2)=0.0d0
2908           Ug(2,2,i-2)=1.0d0
2909           Ug2(1,1,i-2)=0.0d0
2910           Ug2(1,2,i-2)=0.0d0
2911           Ug2(2,1,i-2)=0.0d0
2912           Ug2(2,2,i-2)=0.0d0
2913         endif
2914         if (i .gt. 3 .and. i .lt. nres+1) then
2915           obrot_der(1,i-2)=-sin1
2916           obrot_der(2,i-2)= cos1
2917           Ugder(1,1,i-2)= sin1
2918           Ugder(1,2,i-2)=-cos1
2919           Ugder(2,1,i-2)=-cos1
2920           Ugder(2,2,i-2)=-sin1
2921           dwacos2=cos2+cos2
2922           dwasin2=sin2+sin2
2923           obrot2_der(1,i-2)=-dwasin2
2924           obrot2_der(2,i-2)= dwacos2
2925           Ug2der(1,1,i-2)= dwasin2
2926           Ug2der(1,2,i-2)=-dwacos2
2927           Ug2der(2,1,i-2)=-dwacos2
2928           Ug2der(2,2,i-2)=-dwasin2
2929         else
2930           obrot_der(1,i-2)=0.0d0
2931           obrot_der(2,i-2)=0.0d0
2932           Ugder(1,1,i-2)=0.0d0
2933           Ugder(1,2,i-2)=0.0d0
2934           Ugder(2,1,i-2)=0.0d0
2935           Ugder(2,2,i-2)=0.0d0
2936           obrot2_der(1,i-2)=0.0d0
2937           obrot2_der(2,i-2)=0.0d0
2938           Ug2der(1,1,i-2)=0.0d0
2939           Ug2der(1,2,i-2)=0.0d0
2940           Ug2der(2,1,i-2)=0.0d0
2941           Ug2der(2,2,i-2)=0.0d0
2942         endif
2943 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2944         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2945           iti = itype2loc(itype(i-2))
2946         else
2947           iti=nloctyp
2948         endif
2949 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2950         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2951           iti1 = itype2loc(itype(i-1))
2952         else
2953           iti1=nloctyp
2954         endif
2955 cd        write (iout,*) '*******i',i,' iti1',iti
2956 cd        write (iout,*) 'b1',b1(:,iti)
2957 cd        write (iout,*) 'b2',b2(:,iti)
2958 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2959 c        if (i .gt. iatel_s+2) then
2960         if (i .gt. nnt+2) then
2961           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2962 #ifdef NEWCORR
2963           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2964 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2965 #endif
2966 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2967 c     &    EE(1,2,iti),EE(2,2,i)
2968           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2969           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2970 c          write(iout,*) "Macierz EUG",
2971 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2972 c     &    eug(2,2,i-2)
2973           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2974      &    then
2975           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2976           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2977           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2978           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2979           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2980           endif
2981         else
2982           do k=1,2
2983             Ub2(k,i-2)=0.0d0
2984             Ctobr(k,i-2)=0.0d0
2985             Dtobr2(k,i-2)=0.0d0
2986             do l=1,2
2987               EUg(l,k,i-2)=0.0d0
2988               CUg(l,k,i-2)=0.0d0
2989               DUg(l,k,i-2)=0.0d0
2990               DtUg2(l,k,i-2)=0.0d0
2991             enddo
2992           enddo
2993         endif
2994         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2995         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2996         do k=1,2
2997           muder(k,i-2)=Ub2der(k,i-2)
2998         enddo
2999 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3000         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3001           if (itype(i-1).le.ntyp) then
3002             iti1 = itype2loc(itype(i-1))
3003           else
3004             iti1=nloctyp
3005           endif
3006         else
3007           iti1=nloctyp
3008         endif
3009         do k=1,2
3010           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3011         enddo
3012 #ifdef MUOUT
3013         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3014      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3015      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3016      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3017      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3018      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3019 #endif
3020 cd        write (iout,*) 'mu1',mu1(:,i-2)
3021 cd        write (iout,*) 'mu2',mu2(:,i-2)
3022         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3023      &  then
3024         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3025         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3026         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3027         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3028         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3029 C Vectors and matrices dependent on a single virtual-bond dihedral.
3030         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3031         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3032         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3033         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3034         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3035         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3036         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3037         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3038         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3039         endif
3040       enddo
3041 C Matrices dependent on two consecutive virtual-bond dihedrals.
3042 C The order of matrices is from left to right.
3043       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3044      &then
3045 c      do i=max0(ivec_start,2),ivec_end
3046       do i=2,nres-1
3047         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3048         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3049         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3050         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3051         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3052         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3053         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3054         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3055       enddo
3056       endif
3057 #if defined(MPI) && defined(PARMAT)
3058 #ifdef DEBUG
3059 c      if (fg_rank.eq.0) then
3060         write (iout,*) "Arrays UG and UGDER before GATHER"
3061         do i=1,nres-1
3062           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3063      &     ((ug(l,k,i),l=1,2),k=1,2),
3064      &     ((ugder(l,k,i),l=1,2),k=1,2)
3065         enddo
3066         write (iout,*) "Arrays UG2 and UG2DER"
3067         do i=1,nres-1
3068           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3069      &     ((ug2(l,k,i),l=1,2),k=1,2),
3070      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3071         enddo
3072         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3073         do i=1,nres-1
3074           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3075      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3076      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3077         enddo
3078         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3079         do i=1,nres-1
3080           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3081      &     costab(i),sintab(i),costab2(i),sintab2(i)
3082         enddo
3083         write (iout,*) "Array MUDER"
3084         do i=1,nres-1
3085           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3086         enddo
3087 c      endif
3088 #endif
3089       if (nfgtasks.gt.1) then
3090         time00=MPI_Wtime()
3091 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3092 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3093 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3094 #ifdef MATGATHER
3095         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3096      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3097      &   FG_COMM1,IERR)
3098         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3099      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3102      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3103      &   FG_COMM1,IERR)
3104         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3105      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3114      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3115      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3116         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3117      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3118      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3119         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3120      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3121      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3122         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3123      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3124      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3125         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3126      &  then
3127         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3128      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3129      &   FG_COMM1,IERR)
3130         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3131      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3132      &   FG_COMM1,IERR)
3133         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3134      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3135      &   FG_COMM1,IERR)
3136        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3137      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3138      &   FG_COMM1,IERR)
3139         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3140      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3141      &   FG_COMM1,IERR)
3142         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3143      &   ivec_count(fg_rank1),
3144      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3145      &   FG_COMM1,IERR)
3146         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3147      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3148      &   FG_COMM1,IERR)
3149         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3150      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3151      &   FG_COMM1,IERR)
3152         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3153      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3154      &   FG_COMM1,IERR)
3155         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3156      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3157      &   FG_COMM1,IERR)
3158         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3159      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3160      &   FG_COMM1,IERR)
3161         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3162      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3163      &   FG_COMM1,IERR)
3164         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3165      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3166      &   FG_COMM1,IERR)
3167         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3168      &   ivec_count(fg_rank1),
3169      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3170      &   FG_COMM1,IERR)
3171         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3172      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3173      &   FG_COMM1,IERR)
3174        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3175      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3176      &   FG_COMM1,IERR)
3177         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3178      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3179      &   FG_COMM1,IERR)
3180        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3181      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3182      &   FG_COMM1,IERR)
3183         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3184      &   ivec_count(fg_rank1),
3185      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3186      &   FG_COMM1,IERR)
3187         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3188      &   ivec_count(fg_rank1),
3189      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3190      &   FG_COMM1,IERR)
3191         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3192      &   ivec_count(fg_rank1),
3193      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3194      &   MPI_MAT2,FG_COMM1,IERR)
3195         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3196      &   ivec_count(fg_rank1),
3197      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3198      &   MPI_MAT2,FG_COMM1,IERR)
3199         endif
3200 #else
3201 c Passes matrix info through the ring
3202       isend=fg_rank1
3203       irecv=fg_rank1-1
3204       if (irecv.lt.0) irecv=nfgtasks1-1
3205       iprev=irecv
3206       inext=fg_rank1+1
3207       if (inext.ge.nfgtasks1) inext=0
3208       do i=1,nfgtasks1-1
3209 c        write (iout,*) "isend",isend," irecv",irecv
3210 c        call flush(iout)
3211         lensend=lentyp(isend)
3212         lenrecv=lentyp(irecv)
3213 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3214 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3215 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3216 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3217 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3218 c        write (iout,*) "Gather ROTAT1"
3219 c        call flush(iout)
3220 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3221 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3222 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3223 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3224 c        write (iout,*) "Gather ROTAT2"
3225 c        call flush(iout)
3226         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3227      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3228      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3229      &   iprev,4400+irecv,FG_COMM,status,IERR)
3230 c        write (iout,*) "Gather ROTAT_OLD"
3231 c        call flush(iout)
3232         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3233      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3234      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3235      &   iprev,5500+irecv,FG_COMM,status,IERR)
3236 c        write (iout,*) "Gather PRECOMP11"
3237 c        call flush(iout)
3238         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3239      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3240      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3241      &   iprev,6600+irecv,FG_COMM,status,IERR)
3242 c        write (iout,*) "Gather PRECOMP12"
3243 c        call flush(iout)
3244         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3245      &  then
3246         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3247      &   MPI_ROTAT2(lensend),inext,7700+isend,
3248      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3249      &   iprev,7700+irecv,FG_COMM,status,IERR)
3250 c        write (iout,*) "Gather PRECOMP21"
3251 c        call flush(iout)
3252         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3253      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3254      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3255      &   iprev,8800+irecv,FG_COMM,status,IERR)
3256 c        write (iout,*) "Gather PRECOMP22"
3257 c        call flush(iout)
3258         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3259      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3260      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3261      &   MPI_PRECOMP23(lenrecv),
3262      &   iprev,9900+irecv,FG_COMM,status,IERR)
3263 c        write (iout,*) "Gather PRECOMP23"
3264 c        call flush(iout)
3265         endif
3266         isend=irecv
3267         irecv=irecv-1
3268         if (irecv.lt.0) irecv=nfgtasks1-1
3269       enddo
3270 #endif
3271         time_gather=time_gather+MPI_Wtime()-time00
3272       endif
3273 #ifdef DEBUG
3274 c      if (fg_rank.eq.0) then
3275         write (iout,*) "Arrays UG and UGDER"
3276         do i=1,nres-1
3277           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3278      &     ((ug(l,k,i),l=1,2),k=1,2),
3279      &     ((ugder(l,k,i),l=1,2),k=1,2)
3280         enddo
3281         write (iout,*) "Arrays UG2 and UG2DER"
3282         do i=1,nres-1
3283           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3284      &     ((ug2(l,k,i),l=1,2),k=1,2),
3285      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3286         enddo
3287         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3288         do i=1,nres-1
3289           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3290      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3291      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3292         enddo
3293         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3294         do i=1,nres-1
3295           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3296      &     costab(i),sintab(i),costab2(i),sintab2(i)
3297         enddo
3298         write (iout,*) "Array MUDER"
3299         do i=1,nres-1
3300           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3301         enddo
3302 c      endif
3303 #endif
3304 #endif
3305 cd      do i=1,nres
3306 cd        iti = itype2loc(itype(i))
3307 cd        write (iout,*) i
3308 cd        do j=1,2
3309 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3310 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3311 cd        enddo
3312 cd      enddo
3313       return
3314       end
3315 C--------------------------------------------------------------------------
3316       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3317 C
3318 C This subroutine calculates the average interaction energy and its gradient
3319 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3320 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3321 C The potential depends both on the distance of peptide-group centers and on
3322 C the orientation of the CA-CA virtual bonds.
3323 C
3324       implicit real*8 (a-h,o-z)
3325 #ifdef MPI
3326       include 'mpif.h'
3327 #endif
3328       include 'DIMENSIONS'
3329       include 'COMMON.CONTROL'
3330       include 'COMMON.SETUP'
3331       include 'COMMON.IOUNITS'
3332       include 'COMMON.GEO'
3333       include 'COMMON.VAR'
3334       include 'COMMON.LOCAL'
3335       include 'COMMON.CHAIN'
3336       include 'COMMON.DERIV'
3337       include 'COMMON.INTERACT'
3338       include 'COMMON.CONTACTS'
3339       include 'COMMON.TORSION'
3340       include 'COMMON.VECTORS'
3341       include 'COMMON.FFIELD'
3342       include 'COMMON.TIME1'
3343       include 'COMMON.SPLITELE'
3344       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3345      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3346       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3347      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3348       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3349      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3350      &    num_conti,j1,j2
3351 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3352 #ifdef MOMENT
3353       double precision scal_el /1.0d0/
3354 #else
3355       double precision scal_el /0.5d0/
3356 #endif
3357 C 12/13/98
3358 C 13-go grudnia roku pamietnego...
3359       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3360      &                   0.0d0,1.0d0,0.0d0,
3361      &                   0.0d0,0.0d0,1.0d0/
3362 cd      write(iout,*) 'In EELEC'
3363 cd      do i=1,nloctyp
3364 cd        write(iout,*) 'Type',i
3365 cd        write(iout,*) 'B1',B1(:,i)
3366 cd        write(iout,*) 'B2',B2(:,i)
3367 cd        write(iout,*) 'CC',CC(:,:,i)
3368 cd        write(iout,*) 'DD',DD(:,:,i)
3369 cd        write(iout,*) 'EE',EE(:,:,i)
3370 cd      enddo
3371 cd      call check_vecgrad
3372 cd      stop
3373       if (icheckgrad.eq.1) then
3374         do i=1,nres-1
3375           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3376           do k=1,3
3377             dc_norm(k,i)=dc(k,i)*fac
3378           enddo
3379 c          write (iout,*) 'i',i,' fac',fac
3380         enddo
3381       endif
3382       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3383      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3384      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3385 c        call vec_and_deriv
3386 #ifdef TIMING
3387         time01=MPI_Wtime()
3388 #endif
3389         call set_matrices
3390 #ifdef TIMING
3391         time_mat=time_mat+MPI_Wtime()-time01
3392 #endif
3393       endif
3394 cd      do i=1,nres-1
3395 cd        write (iout,*) 'i=',i
3396 cd        do k=1,3
3397 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3398 cd        enddo
3399 cd        do k=1,3
3400 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3401 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3402 cd        enddo
3403 cd      enddo
3404       t_eelecij=0.0d0
3405       ees=0.0D0
3406       evdw1=0.0D0
3407       eel_loc=0.0d0
3408       eello_turn3=0.0d0
3409       eello_turn4=0.0d0
3410       ind=0
3411       do i=1,nres
3412         num_cont_hb(i)=0
3413       enddo
3414 cd      print '(a)','Enter EELEC'
3415 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3416       do i=1,nres
3417         gel_loc_loc(i)=0.0d0
3418         gcorr_loc(i)=0.0d0
3419       enddo
3420 c
3421 c
3422 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3423 C
3424 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3425 C
3426 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3427       do i=iturn3_start,iturn3_end
3428 c        if (i.le.1) cycle
3429 C        write(iout,*) "tu jest i",i
3430         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3431 C changes suggested by Ana to avoid out of bounds
3432 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3433 c     & .or.((i+4).gt.nres)
3434 c     & .or.((i-1).le.0)
3435 C end of changes by Ana
3436      &  .or. itype(i+2).eq.ntyp1
3437      &  .or. itype(i+3).eq.ntyp1) cycle
3438 C Adam: Instructions below will switch off existing interactions
3439 c        if(i.gt.1)then
3440 c          if(itype(i-1).eq.ntyp1)cycle
3441 c        end if
3442 c        if(i.LT.nres-3)then
3443 c          if (itype(i+4).eq.ntyp1) cycle
3444 c        end if
3445         dxi=dc(1,i)
3446         dyi=dc(2,i)
3447         dzi=dc(3,i)
3448         dx_normi=dc_norm(1,i)
3449         dy_normi=dc_norm(2,i)
3450         dz_normi=dc_norm(3,i)
3451         xmedi=c(1,i)+0.5d0*dxi
3452         ymedi=c(2,i)+0.5d0*dyi
3453         zmedi=c(3,i)+0.5d0*dzi
3454           xmedi=mod(xmedi,boxxsize)
3455           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3456           ymedi=mod(ymedi,boxysize)
3457           if (ymedi.lt.0) ymedi=ymedi+boxysize
3458           zmedi=mod(zmedi,boxzsize)
3459           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3460         num_conti=0
3461         call eelecij(i,i+2,ees,evdw1,eel_loc)
3462         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3463         num_cont_hb(i)=num_conti
3464       enddo
3465       do i=iturn4_start,iturn4_end
3466         if (i.lt.1) cycle
3467         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3468 C changes suggested by Ana to avoid out of bounds
3469 c     & .or.((i+5).gt.nres)
3470 c     & .or.((i-1).le.0)
3471 C end of changes suggested by Ana
3472      &    .or. itype(i+3).eq.ntyp1
3473      &    .or. itype(i+4).eq.ntyp1
3474 c     &    .or. itype(i+5).eq.ntyp1
3475 c     &    .or. itype(i).eq.ntyp1
3476 c     &    .or. itype(i-1).eq.ntyp1
3477      &                             ) cycle
3478         dxi=dc(1,i)
3479         dyi=dc(2,i)
3480         dzi=dc(3,i)
3481         dx_normi=dc_norm(1,i)
3482         dy_normi=dc_norm(2,i)
3483         dz_normi=dc_norm(3,i)
3484         xmedi=c(1,i)+0.5d0*dxi
3485         ymedi=c(2,i)+0.5d0*dyi
3486         zmedi=c(3,i)+0.5d0*dzi
3487 C Return atom into box, boxxsize is size of box in x dimension
3488 c  194   continue
3489 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3490 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3491 C Condition for being inside the proper box
3492 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3493 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3494 c        go to 194
3495 c        endif
3496 c  195   continue
3497 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3498 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3499 C Condition for being inside the proper box
3500 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3501 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3502 c        go to 195
3503 c        endif
3504 c  196   continue
3505 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3506 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3507 C Condition for being inside the proper box
3508 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3509 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3510 c        go to 196
3511 c        endif
3512           xmedi=mod(xmedi,boxxsize)
3513           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3514           ymedi=mod(ymedi,boxysize)
3515           if (ymedi.lt.0) ymedi=ymedi+boxysize
3516           zmedi=mod(zmedi,boxzsize)
3517           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3518
3519         num_conti=num_cont_hb(i)
3520 c        write(iout,*) "JESTEM W PETLI"
3521         call eelecij(i,i+3,ees,evdw1,eel_loc)
3522         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3523      &   call eturn4(i,eello_turn4)
3524         num_cont_hb(i)=num_conti
3525       enddo   ! i
3526 C Loop over all neighbouring boxes
3527 C      do xshift=-1,1
3528 C      do yshift=-1,1
3529 C      do zshift=-1,1
3530 c
3531 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3532 c
3533 CTU KURWA
3534       do i=iatel_s,iatel_e
3535 C        do i=75,75
3536 c        if (i.le.1) cycle
3537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3538 C changes suggested by Ana to avoid out of bounds
3539 c     & .or.((i+2).gt.nres)
3540 c     & .or.((i-1).le.0)
3541 C end of changes by Ana
3542 c     &  .or. itype(i+2).eq.ntyp1
3543 c     &  .or. itype(i-1).eq.ntyp1
3544      &                ) cycle
3545         dxi=dc(1,i)
3546         dyi=dc(2,i)
3547         dzi=dc(3,i)
3548         dx_normi=dc_norm(1,i)
3549         dy_normi=dc_norm(2,i)
3550         dz_normi=dc_norm(3,i)
3551         xmedi=c(1,i)+0.5d0*dxi
3552         ymedi=c(2,i)+0.5d0*dyi
3553         zmedi=c(3,i)+0.5d0*dzi
3554           xmedi=mod(xmedi,boxxsize)
3555           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3556           ymedi=mod(ymedi,boxysize)
3557           if (ymedi.lt.0) ymedi=ymedi+boxysize
3558           zmedi=mod(zmedi,boxzsize)
3559           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3560 C          xmedi=xmedi+xshift*boxxsize
3561 C          ymedi=ymedi+yshift*boxysize
3562 C          zmedi=zmedi+zshift*boxzsize
3563
3564 C Return tom into box, boxxsize is size of box in x dimension
3565 c  164   continue
3566 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3567 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3568 C Condition for being inside the proper box
3569 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3570 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3571 c        go to 164
3572 c        endif
3573 c  165   continue
3574 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3575 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3576 C Condition for being inside the proper box
3577 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3578 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3579 c        go to 165
3580 c        endif
3581 c  166   continue
3582 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3583 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3584 cC Condition for being inside the proper box
3585 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3586 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3587 c        go to 166
3588 c        endif
3589
3590 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3591         num_conti=num_cont_hb(i)
3592 C I TU KURWA
3593         do j=ielstart(i),ielend(i)
3594 C          do j=16,17
3595 C          write (iout,*) i,j
3596 C         if (j.le.1) cycle
3597           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3598 C changes suggested by Ana to avoid out of bounds
3599 c     & .or.((j+2).gt.nres)
3600 c     & .or.((j-1).le.0)
3601 C end of changes by Ana
3602 c     & .or.itype(j+2).eq.ntyp1
3603 c     & .or.itype(j-1).eq.ntyp1
3604      &) cycle
3605           call eelecij(i,j,ees,evdw1,eel_loc)
3606         enddo ! j
3607         num_cont_hb(i)=num_conti
3608       enddo   ! i
3609 C     enddo   ! zshift
3610 C      enddo   ! yshift
3611 C      enddo   ! xshift
3612
3613 c      write (iout,*) "Number of loop steps in EELEC:",ind
3614 cd      do i=1,nres
3615 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3616 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3617 cd      enddo
3618 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3619 ccc      eel_loc=eel_loc+eello_turn3
3620 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3621       return
3622       end
3623 C-------------------------------------------------------------------------------
3624       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3625       implicit real*8 (a-h,o-z)
3626       include 'DIMENSIONS'
3627 #ifdef MPI
3628       include "mpif.h"
3629 #endif
3630       include 'COMMON.CONTROL'
3631       include 'COMMON.IOUNITS'
3632       include 'COMMON.GEO'
3633       include 'COMMON.VAR'
3634       include 'COMMON.LOCAL'
3635       include 'COMMON.CHAIN'
3636       include 'COMMON.DERIV'
3637       include 'COMMON.INTERACT'
3638       include 'COMMON.CONTACTS'
3639       include 'COMMON.TORSION'
3640       include 'COMMON.VECTORS'
3641       include 'COMMON.FFIELD'
3642       include 'COMMON.TIME1'
3643       include 'COMMON.SPLITELE'
3644       include 'COMMON.SHIELD'
3645       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3646      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3647       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3648      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3649      &    gmuij2(4),gmuji2(4)
3650       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3651      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3652      &    num_conti,j1,j2
3653 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3654 #ifdef MOMENT
3655       double precision scal_el /1.0d0/
3656 #else
3657       double precision scal_el /0.5d0/
3658 #endif
3659 C 12/13/98
3660 C 13-go grudnia roku pamietnego...
3661       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3662      &                   0.0d0,1.0d0,0.0d0,
3663      &                   0.0d0,0.0d0,1.0d0/
3664        integer xshift,yshift,zshift
3665 c          time00=MPI_Wtime()
3666 cd      write (iout,*) "eelecij",i,j
3667 c          ind=ind+1
3668           iteli=itel(i)
3669           itelj=itel(j)
3670           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3671           aaa=app(iteli,itelj)
3672           bbb=bpp(iteli,itelj)
3673           ael6i=ael6(iteli,itelj)
3674           ael3i=ael3(iteli,itelj)
3675           dxj=dc(1,j)
3676           dyj=dc(2,j)
3677           dzj=dc(3,j)
3678           dx_normj=dc_norm(1,j)
3679           dy_normj=dc_norm(2,j)
3680           dz_normj=dc_norm(3,j)
3681 C          xj=c(1,j)+0.5D0*dxj-xmedi
3682 C          yj=c(2,j)+0.5D0*dyj-ymedi
3683 C          zj=c(3,j)+0.5D0*dzj-zmedi
3684           xj=c(1,j)+0.5D0*dxj
3685           yj=c(2,j)+0.5D0*dyj
3686           zj=c(3,j)+0.5D0*dzj
3687           xj=mod(xj,boxxsize)
3688           if (xj.lt.0) xj=xj+boxxsize
3689           yj=mod(yj,boxysize)
3690           if (yj.lt.0) yj=yj+boxysize
3691           zj=mod(zj,boxzsize)
3692           if (zj.lt.0) zj=zj+boxzsize
3693           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3694       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3695       xj_safe=xj
3696       yj_safe=yj
3697       zj_safe=zj
3698       isubchap=0
3699       do xshift=-1,1
3700       do yshift=-1,1
3701       do zshift=-1,1
3702           xj=xj_safe+xshift*boxxsize
3703           yj=yj_safe+yshift*boxysize
3704           zj=zj_safe+zshift*boxzsize
3705           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3706           if(dist_temp.lt.dist_init) then
3707             dist_init=dist_temp
3708             xj_temp=xj
3709             yj_temp=yj
3710             zj_temp=zj
3711             isubchap=1
3712           endif
3713        enddo
3714        enddo
3715        enddo
3716        if (isubchap.eq.1) then
3717           xj=xj_temp-xmedi
3718           yj=yj_temp-ymedi
3719           zj=zj_temp-zmedi
3720        else
3721           xj=xj_safe-xmedi
3722           yj=yj_safe-ymedi
3723           zj=zj_safe-zmedi
3724        endif
3725 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3726 c  174   continue
3727 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3728 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3729 C Condition for being inside the proper box
3730 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3731 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3732 c        go to 174
3733 c        endif
3734 c  175   continue
3735 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3736 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3737 C Condition for being inside the proper box
3738 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3739 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3740 c        go to 175
3741 c        endif
3742 c  176   continue
3743 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3744 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3745 C Condition for being inside the proper box
3746 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3747 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3748 c        go to 176
3749 c        endif
3750 C        endif !endPBC condintion
3751 C        xj=xj-xmedi
3752 C        yj=yj-ymedi
3753 C        zj=zj-zmedi
3754           rij=xj*xj+yj*yj+zj*zj
3755
3756             sss=sscale(sqrt(rij))
3757             sssgrad=sscagrad(sqrt(rij))
3758 c            if (sss.gt.0.0d0) then
3759           rrmij=1.0D0/rij
3760           rij=dsqrt(rij)
3761           rmij=1.0D0/rij
3762           r3ij=rrmij*rmij
3763           r6ij=r3ij*r3ij
3764           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3765           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3766           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3767           fac=cosa-3.0D0*cosb*cosg
3768           ev1=aaa*r6ij*r6ij
3769 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3770           if (j.eq.i+2) ev1=scal_el*ev1
3771           ev2=bbb*r6ij
3772           fac3=ael6i*r6ij
3773           fac4=ael3i*r3ij
3774           evdwij=(ev1+ev2)
3775           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3776           el2=fac4*fac
3777 C MARYSIA
3778 C          eesij=(el1+el2)
3779 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3780           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3781           if (shield_mode.gt.0) then
3782 C          fac_shield(i)=0.4
3783 C          fac_shield(j)=0.6
3784           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3785           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3786           eesij=(el1+el2)
3787           ees=ees+eesij
3788           else
3789           fac_shield(i)=1.0
3790           fac_shield(j)=1.0
3791           eesij=(el1+el2)
3792           ees=ees+eesij
3793           endif
3794           evdw1=evdw1+evdwij*sss
3795 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3796 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3797 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3798 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3799
3800           if (energy_dec) then
3801               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3802      &'evdw1',i,j,evdwij
3803      &,iteli,itelj,aaa,evdw1
3804               write (iout,*) sss
3805               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3806      &fac_shield(i),fac_shield(j)
3807           endif
3808
3809 C
3810 C Calculate contributions to the Cartesian gradient.
3811 C
3812 #ifdef SPLITELE
3813           facvdw=-6*rrmij*(ev1+evdwij)*sss
3814           facel=-3*rrmij*(el1+eesij)
3815           fac1=fac
3816           erij(1)=xj*rmij
3817           erij(2)=yj*rmij
3818           erij(3)=zj*rmij
3819
3820 *
3821 * Radial derivatives. First process both termini of the fragment (i,j)
3822 *
3823           ggg(1)=facel*xj
3824           ggg(2)=facel*yj
3825           ggg(3)=facel*zj
3826           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3827      &  (shield_mode.gt.0)) then
3828 C          print *,i,j
3829           do ilist=1,ishield_list(i)
3830            iresshield=shield_list(ilist,i)
3831            do k=1,3
3832            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3833      &      *2.0
3834            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3835      &              rlocshield
3836      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3837             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3838 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3839 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3840 C             if (iresshield.gt.i) then
3841 C               do ishi=i+1,iresshield-1
3842 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3843 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3844 C
3845 C              enddo
3846 C             else
3847 C               do ishi=iresshield,i
3848 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3849 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3850 C
3851 C               enddo
3852 C              endif
3853            enddo
3854           enddo
3855           do ilist=1,ishield_list(j)
3856            iresshield=shield_list(ilist,j)
3857            do k=1,3
3858            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3859      &     *2.0
3860            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3861      &              rlocshield
3862      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3863            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3864
3865 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3866 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3867 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3868 C             if (iresshield.gt.j) then
3869 C               do ishi=j+1,iresshield-1
3870 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3871 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3872 C
3873 C               enddo
3874 C            else
3875 C               do ishi=iresshield,j
3876 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3877 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3878 C               enddo
3879 C              endif
3880            enddo
3881           enddo
3882
3883           do k=1,3
3884             gshieldc(k,i)=gshieldc(k,i)+
3885      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3886             gshieldc(k,j)=gshieldc(k,j)+
3887      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3888             gshieldc(k,i-1)=gshieldc(k,i-1)+
3889      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3890             gshieldc(k,j-1)=gshieldc(k,j-1)+
3891      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3892
3893            enddo
3894            endif
3895 c          do k=1,3
3896 c            ghalf=0.5D0*ggg(k)
3897 c            gelc(k,i)=gelc(k,i)+ghalf
3898 c            gelc(k,j)=gelc(k,j)+ghalf
3899 c          enddo
3900 c 9/28/08 AL Gradient compotents will be summed only at the end
3901 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3902           do k=1,3
3903             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3904 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3905             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3906 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3907 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3908 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3909 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3910 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3911           enddo
3912 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3913
3914 *
3915 * Loop over residues i+1 thru j-1.
3916 *
3917 cgrad          do k=i+1,j-1
3918 cgrad            do l=1,3
3919 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3920 cgrad            enddo
3921 cgrad          enddo
3922           if (sss.gt.0.0) then
3923           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3924           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3925           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3926           else
3927           ggg(1)=0.0
3928           ggg(2)=0.0
3929           ggg(3)=0.0
3930           endif
3931 c          do k=1,3
3932 c            ghalf=0.5D0*ggg(k)
3933 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3934 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3935 c          enddo
3936 c 9/28/08 AL Gradient compotents will be summed only at the end
3937           do k=1,3
3938             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3939             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3940           enddo
3941 *
3942 * Loop over residues i+1 thru j-1.
3943 *
3944 cgrad          do k=i+1,j-1
3945 cgrad            do l=1,3
3946 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3947 cgrad            enddo
3948 cgrad          enddo
3949 #else
3950 C MARYSIA
3951           facvdw=(ev1+evdwij)*sss
3952           facel=(el1+eesij)
3953           fac1=fac
3954           fac=-3*rrmij*(facvdw+facvdw+facel)
3955           erij(1)=xj*rmij
3956           erij(2)=yj*rmij
3957           erij(3)=zj*rmij
3958 *
3959 * Radial derivatives. First process both termini of the fragment (i,j)
3960 *
3961           ggg(1)=fac*xj
3962 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3963           ggg(2)=fac*yj
3964 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3965           ggg(3)=fac*zj
3966 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3967 c          do k=1,3
3968 c            ghalf=0.5D0*ggg(k)
3969 c            gelc(k,i)=gelc(k,i)+ghalf
3970 c            gelc(k,j)=gelc(k,j)+ghalf
3971 c          enddo
3972 c 9/28/08 AL Gradient compotents will be summed only at the end
3973           do k=1,3
3974             gelc_long(k,j)=gelc(k,j)+ggg(k)
3975             gelc_long(k,i)=gelc(k,i)-ggg(k)
3976           enddo
3977 *
3978 * Loop over residues i+1 thru j-1.
3979 *
3980 cgrad          do k=i+1,j-1
3981 cgrad            do l=1,3
3982 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3983 cgrad            enddo
3984 cgrad          enddo
3985 c 9/28/08 AL Gradient compotents will be summed only at the end
3986           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3987           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3988           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3989           do k=1,3
3990             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3991             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3992           enddo
3993 #endif
3994 *
3995 * Angular part
3996 *
3997           ecosa=2.0D0*fac3*fac1+fac4
3998           fac4=-3.0D0*fac4
3999           fac3=-6.0D0*fac3
4000           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4001           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4002           do k=1,3
4003             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4004             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4005           enddo
4006 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4007 cd   &          (dcosg(k),k=1,3)
4008           do k=1,3
4009             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4010      &      fac_shield(i)**2*fac_shield(j)**2
4011           enddo
4012 c          do k=1,3
4013 c            ghalf=0.5D0*ggg(k)
4014 c            gelc(k,i)=gelc(k,i)+ghalf
4015 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4016 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4017 c            gelc(k,j)=gelc(k,j)+ghalf
4018 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4019 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4020 c          enddo
4021 cgrad          do k=i+1,j-1
4022 cgrad            do l=1,3
4023 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4024 cgrad            enddo
4025 cgrad          enddo
4026 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4027           do k=1,3
4028             gelc(k,i)=gelc(k,i)
4029      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4030      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4031      &           *fac_shield(i)**2*fac_shield(j)**2
4032             gelc(k,j)=gelc(k,j)
4033      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4034      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4035      &           *fac_shield(i)**2*fac_shield(j)**2
4036             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4037             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4038           enddo
4039 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4040
4041 C MARYSIA
4042 c          endif !sscale
4043           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4044      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4045      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4046 C
4047 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4048 C   energy of a peptide unit is assumed in the form of a second-order
4049 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4050 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4051 C   are computed for EVERY pair of non-contiguous peptide groups.
4052 C
4053
4054           if (j.lt.nres-1) then
4055             j1=j+1
4056             j2=j-1
4057           else
4058             j1=j-1
4059             j2=j-2
4060           endif
4061           kkk=0
4062           lll=0
4063           do k=1,2
4064             do l=1,2
4065               kkk=kkk+1
4066               muij(kkk)=mu(k,i)*mu(l,j)
4067 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4068 #ifdef NEWCORR
4069              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4070 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4071              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4072              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4073 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4074              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4075 #endif
4076             enddo
4077           enddo
4078 cd         write (iout,*) 'EELEC: i',i,' j',j
4079 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4080 cd          write(iout,*) 'muij',muij
4081           ury=scalar(uy(1,i),erij)
4082           urz=scalar(uz(1,i),erij)
4083           vry=scalar(uy(1,j),erij)
4084           vrz=scalar(uz(1,j),erij)
4085           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4086           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4087           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4088           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4089           fac=dsqrt(-ael6i)*r3ij
4090           a22=a22*fac
4091           a23=a23*fac
4092           a32=a32*fac
4093           a33=a33*fac
4094 cd          write (iout,'(4i5,4f10.5)')
4095 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4096 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4097 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4098 cd     &      uy(:,j),uz(:,j)
4099 cd          write (iout,'(4f10.5)')
4100 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4101 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4102 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4103 cd           write (iout,'(9f10.5/)')
4104 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4105 C Derivatives of the elements of A in virtual-bond vectors
4106           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4107           do k=1,3
4108             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4109             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4110             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4111             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4112             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4113             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4114             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4115             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4116             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4117             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4118             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4119             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4120           enddo
4121 C Compute radial contributions to the gradient
4122           facr=-3.0d0*rrmij
4123           a22der=a22*facr
4124           a23der=a23*facr
4125           a32der=a32*facr
4126           a33der=a33*facr
4127           agg(1,1)=a22der*xj
4128           agg(2,1)=a22der*yj
4129           agg(3,1)=a22der*zj
4130           agg(1,2)=a23der*xj
4131           agg(2,2)=a23der*yj
4132           agg(3,2)=a23der*zj
4133           agg(1,3)=a32der*xj
4134           agg(2,3)=a32der*yj
4135           agg(3,3)=a32der*zj
4136           agg(1,4)=a33der*xj
4137           agg(2,4)=a33der*yj
4138           agg(3,4)=a33der*zj
4139 C Add the contributions coming from er
4140           fac3=-3.0d0*fac
4141           do k=1,3
4142             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4143             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4144             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4145             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4146           enddo
4147           do k=1,3
4148 C Derivatives in DC(i)
4149 cgrad            ghalf1=0.5d0*agg(k,1)
4150 cgrad            ghalf2=0.5d0*agg(k,2)
4151 cgrad            ghalf3=0.5d0*agg(k,3)
4152 cgrad            ghalf4=0.5d0*agg(k,4)
4153             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4154      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4155             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4156      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4157             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4158      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4159             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4160      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4161 C Derivatives in DC(i+1)
4162             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4163      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4164             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4165      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4166             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4167      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4168             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4169      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4170 C Derivatives in DC(j)
4171             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4172      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4173             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4174      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4175             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4176      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4177             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4178      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4179 C Derivatives in DC(j+1) or DC(nres-1)
4180             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4181      &      -3.0d0*vryg(k,3)*ury)
4182             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4183      &      -3.0d0*vrzg(k,3)*ury)
4184             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4185      &      -3.0d0*vryg(k,3)*urz)
4186             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4187      &      -3.0d0*vrzg(k,3)*urz)
4188 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4189 cgrad              do l=1,4
4190 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4191 cgrad              enddo
4192 cgrad            endif
4193           enddo
4194           acipa(1,1)=a22
4195           acipa(1,2)=a23
4196           acipa(2,1)=a32
4197           acipa(2,2)=a33
4198           a22=-a22
4199           a23=-a23
4200           do l=1,2
4201             do k=1,3
4202               agg(k,l)=-agg(k,l)
4203               aggi(k,l)=-aggi(k,l)
4204               aggi1(k,l)=-aggi1(k,l)
4205               aggj(k,l)=-aggj(k,l)
4206               aggj1(k,l)=-aggj1(k,l)
4207             enddo
4208           enddo
4209           if (j.lt.nres-1) then
4210             a22=-a22
4211             a32=-a32
4212             do l=1,3,2
4213               do k=1,3
4214                 agg(k,l)=-agg(k,l)
4215                 aggi(k,l)=-aggi(k,l)
4216                 aggi1(k,l)=-aggi1(k,l)
4217                 aggj(k,l)=-aggj(k,l)
4218                 aggj1(k,l)=-aggj1(k,l)
4219               enddo
4220             enddo
4221           else
4222             a22=-a22
4223             a23=-a23
4224             a32=-a32
4225             a33=-a33
4226             do l=1,4
4227               do k=1,3
4228                 agg(k,l)=-agg(k,l)
4229                 aggi(k,l)=-aggi(k,l)
4230                 aggi1(k,l)=-aggi1(k,l)
4231                 aggj(k,l)=-aggj(k,l)
4232                 aggj1(k,l)=-aggj1(k,l)
4233               enddo
4234             enddo
4235           endif
4236           ENDIF ! WCORR
4237           IF (wel_loc.gt.0.0d0) THEN
4238 C Contribution to the local-electrostatic energy coming from the i-j pair
4239           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4240      &     +a33*muij(4)
4241           if (shield_mode.eq.0) then
4242            fac_shield(i)=1.0
4243            fac_shield(j)=1.0
4244 C          else
4245 C           fac_shield(i)=0.4
4246 C           fac_shield(j)=0.6
4247           endif
4248           eel_loc_ij=eel_loc_ij
4249      &    *fac_shield(i)*fac_shield(j)
4250 C Now derivative over eel_loc
4251           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4252      &  (shield_mode.gt.0)) then
4253 C          print *,i,j
4254
4255           do ilist=1,ishield_list(i)
4256            iresshield=shield_list(ilist,i)
4257            do k=1,3
4258            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4259      &                                          /fac_shield(i)
4260 C     &      *2.0
4261            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4262      &              rlocshield
4263      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4264             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4265      &      +rlocshield
4266            enddo
4267           enddo
4268           do ilist=1,ishield_list(j)
4269            iresshield=shield_list(ilist,j)
4270            do k=1,3
4271            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4272      &                                       /fac_shield(j)
4273 C     &     *2.0
4274            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4275      &              rlocshield
4276      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4277            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4278      &             +rlocshield
4279
4280            enddo
4281           enddo
4282
4283           do k=1,3
4284             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4285      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4286             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4287      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4288             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4289      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4290             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4291      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4292            enddo
4293            endif
4294
4295
4296 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4297 c     &                     ' eel_loc_ij',eel_loc_ij
4298 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4299 C Calculate patrial derivative for theta angle
4300 #ifdef NEWCORR
4301          geel_loc_ij=(a22*gmuij1(1)
4302      &     +a23*gmuij1(2)
4303      &     +a32*gmuij1(3)
4304      &     +a33*gmuij1(4))
4305      &    *fac_shield(i)*fac_shield(j)
4306 c         write(iout,*) "derivative over thatai"
4307 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4308 c     &   a33*gmuij1(4)
4309          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4310      &      geel_loc_ij*wel_loc
4311 c         write(iout,*) "derivative over thatai-1"
4312 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4313 c     &   a33*gmuij2(4)
4314          geel_loc_ij=
4315      &     a22*gmuij2(1)
4316      &     +a23*gmuij2(2)
4317      &     +a32*gmuij2(3)
4318      &     +a33*gmuij2(4)
4319          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4320      &      geel_loc_ij*wel_loc
4321      &    *fac_shield(i)*fac_shield(j)
4322
4323 c  Derivative over j residue
4324          geel_loc_ji=a22*gmuji1(1)
4325      &     +a23*gmuji1(2)
4326      &     +a32*gmuji1(3)
4327      &     +a33*gmuji1(4)
4328 c         write(iout,*) "derivative over thataj"
4329 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4330 c     &   a33*gmuji1(4)
4331
4332         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4333      &      geel_loc_ji*wel_loc
4334      &    *fac_shield(i)*fac_shield(j)
4335
4336          geel_loc_ji=
4337      &     +a22*gmuji2(1)
4338      &     +a23*gmuji2(2)
4339      &     +a32*gmuji2(3)
4340      &     +a33*gmuji2(4)
4341 c         write(iout,*) "derivative over thataj-1"
4342 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4343 c     &   a33*gmuji2(4)
4344          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4345      &      geel_loc_ji*wel_loc
4346      &    *fac_shield(i)*fac_shield(j)
4347 #endif
4348 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4349
4350           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4351      &            'eelloc',i,j,eel_loc_ij
4352 c           if (eel_loc_ij.ne.0)
4353 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4354 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4355
4356           eel_loc=eel_loc+eel_loc_ij
4357 C Partial derivatives in virtual-bond dihedral angles gamma
4358           if (i.gt.1)
4359      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4360      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4361      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4362      &    *fac_shield(i)*fac_shield(j)
4363
4364           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4365      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4366      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4367      &    *fac_shield(i)*fac_shield(j)
4368 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4369           do l=1,3
4370             ggg(l)=(agg(l,1)*muij(1)+
4371      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4372      &    *fac_shield(i)*fac_shield(j)
4373             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4374             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4375 cgrad            ghalf=0.5d0*ggg(l)
4376 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4377 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4378           enddo
4379 cgrad          do k=i+1,j2
4380 cgrad            do l=1,3
4381 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4382 cgrad            enddo
4383 cgrad          enddo
4384 C Remaining derivatives of eello
4385           do l=1,3
4386             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4387      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4388      &    *fac_shield(i)*fac_shield(j)
4389
4390             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4391      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4392      &    *fac_shield(i)*fac_shield(j)
4393
4394             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4395      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4396      &    *fac_shield(i)*fac_shield(j)
4397
4398             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4399      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4400      &    *fac_shield(i)*fac_shield(j)
4401
4402           enddo
4403           ENDIF
4404 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4405 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4406           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4407      &       .and. num_conti.le.maxconts) then
4408 c            write (iout,*) i,j," entered corr"
4409 C
4410 C Calculate the contact function. The ith column of the array JCONT will
4411 C contain the numbers of atoms that make contacts with the atom I (of numbers
4412 C greater than I). The arrays FACONT and GACONT will contain the values of
4413 C the contact function and its derivative.
4414 c           r0ij=1.02D0*rpp(iteli,itelj)
4415 c           r0ij=1.11D0*rpp(iteli,itelj)
4416             r0ij=2.20D0*rpp(iteli,itelj)
4417 c           r0ij=1.55D0*rpp(iteli,itelj)
4418             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4419             if (fcont.gt.0.0D0) then
4420               num_conti=num_conti+1
4421               if (num_conti.gt.maxconts) then
4422                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4423      &                         ' will skip next contacts for this conf.'
4424               else
4425                 jcont_hb(num_conti,i)=j
4426 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4427 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4428                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4429      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4430 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4431 C  terms.
4432                 d_cont(num_conti,i)=rij
4433 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4434 C     --- Electrostatic-interaction matrix ---
4435                 a_chuj(1,1,num_conti,i)=a22
4436                 a_chuj(1,2,num_conti,i)=a23
4437                 a_chuj(2,1,num_conti,i)=a32
4438                 a_chuj(2,2,num_conti,i)=a33
4439 C     --- Gradient of rij
4440                 do kkk=1,3
4441                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4442                 enddo
4443                 kkll=0
4444                 do k=1,2
4445                   do l=1,2
4446                     kkll=kkll+1
4447                     do m=1,3
4448                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4449                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4450                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4451                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4452                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4453                     enddo
4454                   enddo
4455                 enddo
4456                 ENDIF
4457                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4458 C Calculate contact energies
4459                 cosa4=4.0D0*cosa
4460                 wij=cosa-3.0D0*cosb*cosg
4461                 cosbg1=cosb+cosg
4462                 cosbg2=cosb-cosg
4463 c               fac3=dsqrt(-ael6i)/r0ij**3
4464                 fac3=dsqrt(-ael6i)*r3ij
4465 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4466                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4467                 if (ees0tmp.gt.0) then
4468                   ees0pij=dsqrt(ees0tmp)
4469                 else
4470                   ees0pij=0
4471                 endif
4472 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4473                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4474                 if (ees0tmp.gt.0) then
4475                   ees0mij=dsqrt(ees0tmp)
4476                 else
4477                   ees0mij=0
4478                 endif
4479 c               ees0mij=0.0D0
4480                 if (shield_mode.eq.0) then
4481                 fac_shield(i)=1.0d0
4482                 fac_shield(j)=1.0d0
4483                 else
4484                 ees0plist(num_conti,i)=j
4485 C                fac_shield(i)=0.4d0
4486 C                fac_shield(j)=0.6d0
4487                 endif
4488                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4489      &          *fac_shield(i)*fac_shield(j)
4490                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4491      &          *fac_shield(i)*fac_shield(j)
4492 C Diagnostics. Comment out or remove after debugging!
4493 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4494 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4495 c               ees0m(num_conti,i)=0.0D0
4496 C End diagnostics.
4497 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4498 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4499 C Angular derivatives of the contact function
4500                 ees0pij1=fac3/ees0pij
4501                 ees0mij1=fac3/ees0mij
4502                 fac3p=-3.0D0*fac3*rrmij
4503                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4504                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4505 c               ees0mij1=0.0D0
4506                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4507                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4508                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4509                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4510                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4511                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4512                 ecosap=ecosa1+ecosa2
4513                 ecosbp=ecosb1+ecosb2
4514                 ecosgp=ecosg1+ecosg2
4515                 ecosam=ecosa1-ecosa2
4516                 ecosbm=ecosb1-ecosb2
4517                 ecosgm=ecosg1-ecosg2
4518 C Diagnostics
4519 c               ecosap=ecosa1
4520 c               ecosbp=ecosb1
4521 c               ecosgp=ecosg1
4522 c               ecosam=0.0D0
4523 c               ecosbm=0.0D0
4524 c               ecosgm=0.0D0
4525 C End diagnostics
4526                 facont_hb(num_conti,i)=fcont
4527                 fprimcont=fprimcont/rij
4528 cd              facont_hb(num_conti,i)=1.0D0
4529 C Following line is for diagnostics.
4530 cd              fprimcont=0.0D0
4531                 do k=1,3
4532                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4533                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4534                 enddo
4535                 do k=1,3
4536                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4537                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4538                 enddo
4539                 gggp(1)=gggp(1)+ees0pijp*xj
4540                 gggp(2)=gggp(2)+ees0pijp*yj
4541                 gggp(3)=gggp(3)+ees0pijp*zj
4542                 gggm(1)=gggm(1)+ees0mijp*xj
4543                 gggm(2)=gggm(2)+ees0mijp*yj
4544                 gggm(3)=gggm(3)+ees0mijp*zj
4545 C Derivatives due to the contact function
4546                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4547                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4548                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4549                 do k=1,3
4550 c
4551 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4552 c          following the change of gradient-summation algorithm.
4553 c
4554 cgrad                  ghalfp=0.5D0*gggp(k)
4555 cgrad                  ghalfm=0.5D0*gggm(k)
4556                   gacontp_hb1(k,num_conti,i)=!ghalfp
4557      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4558      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4559      &          *fac_shield(i)*fac_shield(j)
4560
4561                   gacontp_hb2(k,num_conti,i)=!ghalfp
4562      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4563      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4564      &          *fac_shield(i)*fac_shield(j)
4565
4566                   gacontp_hb3(k,num_conti,i)=gggp(k)
4567      &          *fac_shield(i)*fac_shield(j)
4568
4569                   gacontm_hb1(k,num_conti,i)=!ghalfm
4570      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4571      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4572      &          *fac_shield(i)*fac_shield(j)
4573
4574                   gacontm_hb2(k,num_conti,i)=!ghalfm
4575      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4576      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4577      &          *fac_shield(i)*fac_shield(j)
4578
4579                   gacontm_hb3(k,num_conti,i)=gggm(k)
4580      &          *fac_shield(i)*fac_shield(j)
4581
4582                 enddo
4583 C Diagnostics. Comment out or remove after debugging!
4584 cdiag           do k=1,3
4585 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4586 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4587 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4588 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4589 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4590 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4591 cdiag           enddo
4592               ENDIF ! wcorr
4593               endif  ! num_conti.le.maxconts
4594             endif  ! fcont.gt.0
4595           endif    ! j.gt.i+1
4596           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4597             do k=1,4
4598               do l=1,3
4599                 ghalf=0.5d0*agg(l,k)
4600                 aggi(l,k)=aggi(l,k)+ghalf
4601                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4602                 aggj(l,k)=aggj(l,k)+ghalf
4603               enddo
4604             enddo
4605             if (j.eq.nres-1 .and. i.lt.j-2) then
4606               do k=1,4
4607                 do l=1,3
4608                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4609                 enddo
4610               enddo
4611             endif
4612           endif
4613 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4614       return
4615       end
4616 C-----------------------------------------------------------------------------
4617       subroutine eturn3(i,eello_turn3)
4618 C Third- and fourth-order contributions from turns
4619       implicit real*8 (a-h,o-z)
4620       include 'DIMENSIONS'
4621       include 'COMMON.IOUNITS'
4622       include 'COMMON.GEO'
4623       include 'COMMON.VAR'
4624       include 'COMMON.LOCAL'
4625       include 'COMMON.CHAIN'
4626       include 'COMMON.DERIV'
4627       include 'COMMON.INTERACT'
4628       include 'COMMON.CONTACTS'
4629       include 'COMMON.TORSION'
4630       include 'COMMON.VECTORS'
4631       include 'COMMON.FFIELD'
4632       include 'COMMON.CONTROL'
4633       include 'COMMON.SHIELD'
4634       dimension ggg(3)
4635       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4636      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4637      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4638      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4639      &  auxgmat2(2,2),auxgmatt2(2,2)
4640       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4641      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4642       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4643      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4644      &    num_conti,j1,j2
4645       j=i+2
4646 c      write (iout,*) "eturn3",i,j,j1,j2
4647       a_temp(1,1)=a22
4648       a_temp(1,2)=a23
4649       a_temp(2,1)=a32
4650       a_temp(2,2)=a33
4651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4652 C
4653 C               Third-order contributions
4654 C
4655 C                 (i+2)o----(i+3)
4656 C                      | |
4657 C                      | |
4658 C                 (i+1)o----i
4659 C
4660 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4661 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4662         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4663 c auxalary matices for theta gradient
4664 c auxalary matrix for i+1 and constant i+2
4665         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4666 c auxalary matrix for i+2 and constant i+1
4667         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4668         call transpose2(auxmat(1,1),auxmat1(1,1))
4669         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4670         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4671         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4672         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4673         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4674         if (shield_mode.eq.0) then
4675         fac_shield(i)=1.0
4676         fac_shield(j)=1.0
4677 C        else
4678 C        fac_shield(i)=0.4
4679 C        fac_shield(j)=0.6
4680         endif
4681         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4682      &  *fac_shield(i)*fac_shield(j)
4683         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4684      &  *fac_shield(i)*fac_shield(j)
4685 C Derivatives in theta
4686         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4687      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4688      &   *fac_shield(i)*fac_shield(j)
4689         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4690      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4691      &   *fac_shield(i)*fac_shield(j)
4692
4693
4694 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4695 C Derivatives in shield mode
4696           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4697      &  (shield_mode.gt.0)) then
4698 C          print *,i,j
4699
4700           do ilist=1,ishield_list(i)
4701            iresshield=shield_list(ilist,i)
4702            do k=1,3
4703            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4704 C     &      *2.0
4705            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4706      &              rlocshield
4707      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4708             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4709      &      +rlocshield
4710            enddo
4711           enddo
4712           do ilist=1,ishield_list(j)
4713            iresshield=shield_list(ilist,j)
4714            do k=1,3
4715            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4716 C     &     *2.0
4717            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4718      &              rlocshield
4719      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4720            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4721      &             +rlocshield
4722
4723            enddo
4724           enddo
4725
4726           do k=1,3
4727             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4728      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4729             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4730      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4731             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4732      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4733             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4734      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4735            enddo
4736            endif
4737
4738 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4739 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4740 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4741 cd     &    ' eello_turn3_num',4*eello_turn3_num
4742 C Derivatives in gamma(i)
4743         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4744         call transpose2(auxmat2(1,1),auxmat3(1,1))
4745         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4746         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4747      &   *fac_shield(i)*fac_shield(j)
4748 C Derivatives in gamma(i+1)
4749         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4750         call transpose2(auxmat2(1,1),auxmat3(1,1))
4751         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4752         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4753      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4754      &   *fac_shield(i)*fac_shield(j)
4755 C Cartesian derivatives
4756         do l=1,3
4757 c            ghalf1=0.5d0*agg(l,1)
4758 c            ghalf2=0.5d0*agg(l,2)
4759 c            ghalf3=0.5d0*agg(l,3)
4760 c            ghalf4=0.5d0*agg(l,4)
4761           a_temp(1,1)=aggi(l,1)!+ghalf1
4762           a_temp(1,2)=aggi(l,2)!+ghalf2
4763           a_temp(2,1)=aggi(l,3)!+ghalf3
4764           a_temp(2,2)=aggi(l,4)!+ghalf4
4765           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4766           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4767      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4768      &   *fac_shield(i)*fac_shield(j)
4769
4770           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4771           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4772           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4773           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4774           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4775           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4776      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4777      &   *fac_shield(i)*fac_shield(j)
4778           a_temp(1,1)=aggj(l,1)!+ghalf1
4779           a_temp(1,2)=aggj(l,2)!+ghalf2
4780           a_temp(2,1)=aggj(l,3)!+ghalf3
4781           a_temp(2,2)=aggj(l,4)!+ghalf4
4782           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4783           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4784      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4785      &   *fac_shield(i)*fac_shield(j)
4786           a_temp(1,1)=aggj1(l,1)
4787           a_temp(1,2)=aggj1(l,2)
4788           a_temp(2,1)=aggj1(l,3)
4789           a_temp(2,2)=aggj1(l,4)
4790           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4791           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4792      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4793      &   *fac_shield(i)*fac_shield(j)
4794         enddo
4795       return
4796       end
4797 C-------------------------------------------------------------------------------
4798       subroutine eturn4(i,eello_turn4)
4799 C Third- and fourth-order contributions from turns
4800       implicit real*8 (a-h,o-z)
4801       include 'DIMENSIONS'
4802       include 'COMMON.IOUNITS'
4803       include 'COMMON.GEO'
4804       include 'COMMON.VAR'
4805       include 'COMMON.LOCAL'
4806       include 'COMMON.CHAIN'
4807       include 'COMMON.DERIV'
4808       include 'COMMON.INTERACT'
4809       include 'COMMON.CONTACTS'
4810       include 'COMMON.TORSION'
4811       include 'COMMON.VECTORS'
4812       include 'COMMON.FFIELD'
4813       include 'COMMON.CONTROL'
4814       include 'COMMON.SHIELD'
4815       dimension ggg(3)
4816       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4817      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4818      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4819      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4820      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4821      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4822      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4823       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4824      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4825       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4826      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4827      &    num_conti,j1,j2
4828       j=i+3
4829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4830 C
4831 C               Fourth-order contributions
4832 C
4833 C                 (i+3)o----(i+4)
4834 C                     /  |
4835 C               (i+2)o   |
4836 C                     \  |
4837 C                 (i+1)o----i
4838 C
4839 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4840 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4841 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4842 c        write(iout,*)"WCHODZE W PROGRAM"
4843         a_temp(1,1)=a22
4844         a_temp(1,2)=a23
4845         a_temp(2,1)=a32
4846         a_temp(2,2)=a33
4847         iti1=itype2loc(itype(i+1))
4848         iti2=itype2loc(itype(i+2))
4849         iti3=itype2loc(itype(i+3))
4850 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4851         call transpose2(EUg(1,1,i+1),e1t(1,1))
4852         call transpose2(Eug(1,1,i+2),e2t(1,1))
4853         call transpose2(Eug(1,1,i+3),e3t(1,1))
4854 C Ematrix derivative in theta
4855         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4856         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4857         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4858         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4859 c       eta1 in derivative theta
4860         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4861         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4862 c       auxgvec is derivative of Ub2 so i+3 theta
4863         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4864 c       auxalary matrix of E i+1
4865         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4866 c        s1=0.0
4867 c        gs1=0.0
4868         s1=scalar2(b1(1,i+2),auxvec(1))
4869 c derivative of theta i+2 with constant i+3
4870         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4871 c derivative of theta i+2 with constant i+2
4872         gs32=scalar2(b1(1,i+2),auxgvec(1))
4873 c derivative of E matix in theta of i+1
4874         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4875
4876         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4877 c       ea31 in derivative theta
4878         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4879         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4880 c auxilary matrix auxgvec of Ub2 with constant E matirx
4881         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4882 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4883         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4884
4885 c        s2=0.0
4886 c        gs2=0.0
4887         s2=scalar2(b1(1,i+1),auxvec(1))
4888 c derivative of theta i+1 with constant i+3
4889         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4890 c derivative of theta i+2 with constant i+1
4891         gs21=scalar2(b1(1,i+1),auxgvec(1))
4892 c derivative of theta i+3 with constant i+1
4893         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4894 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4895 c     &  gtb1(1,i+1)
4896         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4897 c two derivatives over diffetent matrices
4898 c gtae3e2 is derivative over i+3
4899         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4900 c ae3gte2 is derivative over i+2
4901         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4902         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4903 c three possible derivative over theta E matices
4904 c i+1
4905         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4906 c i+2
4907         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4908 c i+3
4909         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4911
4912         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4913         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4914         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4915         if (shield_mode.eq.0) then
4916         fac_shield(i)=1.0
4917         fac_shield(j)=1.0
4918 C        else
4919 C        fac_shield(i)=0.6
4920 C        fac_shield(j)=0.4
4921         endif
4922         eello_turn4=eello_turn4-(s1+s2+s3)
4923      &  *fac_shield(i)*fac_shield(j)
4924         eello_t4=-(s1+s2+s3)
4925      &  *fac_shield(i)*fac_shield(j)
4926 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4927         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4928      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4929 C Now derivative over shield:
4930           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4931      &  (shield_mode.gt.0)) then
4932 C          print *,i,j
4933
4934           do ilist=1,ishield_list(i)
4935            iresshield=shield_list(ilist,i)
4936            do k=1,3
4937            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4938 C     &      *2.0
4939            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4940      &              rlocshield
4941      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4942             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4943      &      +rlocshield
4944            enddo
4945           enddo
4946           do ilist=1,ishield_list(j)
4947            iresshield=shield_list(ilist,j)
4948            do k=1,3
4949            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4950 C     &     *2.0
4951            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4952      &              rlocshield
4953      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4954            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4955      &             +rlocshield
4956
4957            enddo
4958           enddo
4959
4960           do k=1,3
4961             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4962      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4963             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4964      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4965             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4966      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4967             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4968      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4969            enddo
4970            endif
4971
4972
4973
4974
4975
4976
4977 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4978 cd     &    ' eello_turn4_num',8*eello_turn4_num
4979 #ifdef NEWCORR
4980         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4981      &                  -(gs13+gsE13+gsEE1)*wturn4
4982      &  *fac_shield(i)*fac_shield(j)
4983         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4984      &                    -(gs23+gs21+gsEE2)*wturn4
4985      &  *fac_shield(i)*fac_shield(j)
4986
4987         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4988      &                    -(gs32+gsE31+gsEE3)*wturn4
4989      &  *fac_shield(i)*fac_shield(j)
4990
4991 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4992 c     &   gs2
4993 #endif
4994         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4995      &      'eturn4',i,j,-(s1+s2+s3)
4996 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4997 c     &    ' eello_turn4_num',8*eello_turn4_num
4998 C Derivatives in gamma(i)
4999         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5000         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5001         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5002         s1=scalar2(b1(1,i+2),auxvec(1))
5003         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5005         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5006      &  *fac_shield(i)*fac_shield(j)
5007 C Derivatives in gamma(i+1)
5008         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5009         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5010         s2=scalar2(b1(1,i+1),auxvec(1))
5011         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5012         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5013         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5014         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5015      &  *fac_shield(i)*fac_shield(j)
5016 C Derivatives in gamma(i+2)
5017         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5018         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5019         s1=scalar2(b1(1,i+2),auxvec(1))
5020         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5021         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5022         s2=scalar2(b1(1,i+1),auxvec(1))
5023         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5024         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5025         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5026         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5027      &  *fac_shield(i)*fac_shield(j)
5028 C Cartesian derivatives
5029 C Derivatives of this turn contributions in DC(i+2)
5030         if (j.lt.nres-1) then
5031           do l=1,3
5032             a_temp(1,1)=agg(l,1)
5033             a_temp(1,2)=agg(l,2)
5034             a_temp(2,1)=agg(l,3)
5035             a_temp(2,2)=agg(l,4)
5036             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5037             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5038             s1=scalar2(b1(1,i+2),auxvec(1))
5039             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5040             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5041             s2=scalar2(b1(1,i+1),auxvec(1))
5042             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5043             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5044             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5045             ggg(l)=-(s1+s2+s3)
5046             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5047      &  *fac_shield(i)*fac_shield(j)
5048           enddo
5049         endif
5050 C Remaining derivatives of this turn contribution
5051         do l=1,3
5052           a_temp(1,1)=aggi(l,1)
5053           a_temp(1,2)=aggi(l,2)
5054           a_temp(2,1)=aggi(l,3)
5055           a_temp(2,2)=aggi(l,4)
5056           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5057           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5058           s1=scalar2(b1(1,i+2),auxvec(1))
5059           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5060           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5061           s2=scalar2(b1(1,i+1),auxvec(1))
5062           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5063           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5064           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5065           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5066      &  *fac_shield(i)*fac_shield(j)
5067           a_temp(1,1)=aggi1(l,1)
5068           a_temp(1,2)=aggi1(l,2)
5069           a_temp(2,1)=aggi1(l,3)
5070           a_temp(2,2)=aggi1(l,4)
5071           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5072           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5073           s1=scalar2(b1(1,i+2),auxvec(1))
5074           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5075           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5076           s2=scalar2(b1(1,i+1),auxvec(1))
5077           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5078           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5079           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5080           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5081      &  *fac_shield(i)*fac_shield(j)
5082           a_temp(1,1)=aggj(l,1)
5083           a_temp(1,2)=aggj(l,2)
5084           a_temp(2,1)=aggj(l,3)
5085           a_temp(2,2)=aggj(l,4)
5086           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5087           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5088           s1=scalar2(b1(1,i+2),auxvec(1))
5089           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5090           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5091           s2=scalar2(b1(1,i+1),auxvec(1))
5092           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5093           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5094           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5095           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5096      &  *fac_shield(i)*fac_shield(j)
5097           a_temp(1,1)=aggj1(l,1)
5098           a_temp(1,2)=aggj1(l,2)
5099           a_temp(2,1)=aggj1(l,3)
5100           a_temp(2,2)=aggj1(l,4)
5101           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5102           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5103           s1=scalar2(b1(1,i+2),auxvec(1))
5104           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5105           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5106           s2=scalar2(b1(1,i+1),auxvec(1))
5107           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5108           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5109           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5110 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5111           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5112      &  *fac_shield(i)*fac_shield(j)
5113         enddo
5114       return
5115       end
5116 C-----------------------------------------------------------------------------
5117       subroutine vecpr(u,v,w)
5118       implicit real*8(a-h,o-z)
5119       dimension u(3),v(3),w(3)
5120       w(1)=u(2)*v(3)-u(3)*v(2)
5121       w(2)=-u(1)*v(3)+u(3)*v(1)
5122       w(3)=u(1)*v(2)-u(2)*v(1)
5123       return
5124       end
5125 C-----------------------------------------------------------------------------
5126       subroutine unormderiv(u,ugrad,unorm,ungrad)
5127 C This subroutine computes the derivatives of a normalized vector u, given
5128 C the derivatives computed without normalization conditions, ugrad. Returns
5129 C ungrad.
5130       implicit none
5131       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5132       double precision vec(3)
5133       double precision scalar
5134       integer i,j
5135 c      write (2,*) 'ugrad',ugrad
5136 c      write (2,*) 'u',u
5137       do i=1,3
5138         vec(i)=scalar(ugrad(1,i),u(1))
5139       enddo
5140 c      write (2,*) 'vec',vec
5141       do i=1,3
5142         do j=1,3
5143           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5144         enddo
5145       enddo
5146 c      write (2,*) 'ungrad',ungrad
5147       return
5148       end
5149 C-----------------------------------------------------------------------------
5150       subroutine escp_soft_sphere(evdw2,evdw2_14)
5151 C
5152 C This subroutine calculates the excluded-volume interaction energy between
5153 C peptide-group centers and side chains and its gradient in virtual-bond and
5154 C side-chain vectors.
5155 C
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'COMMON.GEO'
5159       include 'COMMON.VAR'
5160       include 'COMMON.LOCAL'
5161       include 'COMMON.CHAIN'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.INTERACT'
5164       include 'COMMON.FFIELD'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.CONTROL'
5167       dimension ggg(3)
5168       evdw2=0.0D0
5169       evdw2_14=0.0d0
5170       r0_scp=4.5d0
5171 cd    print '(a)','Enter ESCP'
5172 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5173 C      do xshift=-1,1
5174 C      do yshift=-1,1
5175 C      do zshift=-1,1
5176       do i=iatscp_s,iatscp_e
5177         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5178         iteli=itel(i)
5179         xi=0.5D0*(c(1,i)+c(1,i+1))
5180         yi=0.5D0*(c(2,i)+c(2,i+1))
5181         zi=0.5D0*(c(3,i)+c(3,i+1))
5182 C Return atom into box, boxxsize is size of box in x dimension
5183 c  134   continue
5184 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5185 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5186 C Condition for being inside the proper box
5187 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5188 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5189 c        go to 134
5190 c        endif
5191 c  135   continue
5192 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5193 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5194 C Condition for being inside the proper box
5195 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5196 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5197 c        go to 135
5198 c c       endif
5199 c  136   continue
5200 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5201 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5202 cC Condition for being inside the proper box
5203 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5204 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5205 c        go to 136
5206 c        endif
5207           xi=mod(xi,boxxsize)
5208           if (xi.lt.0) xi=xi+boxxsize
5209           yi=mod(yi,boxysize)
5210           if (yi.lt.0) yi=yi+boxysize
5211           zi=mod(zi,boxzsize)
5212           if (zi.lt.0) zi=zi+boxzsize
5213 C          xi=xi+xshift*boxxsize
5214 C          yi=yi+yshift*boxysize
5215 C          zi=zi+zshift*boxzsize
5216         do iint=1,nscp_gr(i)
5217
5218         do j=iscpstart(i,iint),iscpend(i,iint)
5219           if (itype(j).eq.ntyp1) cycle
5220           itypj=iabs(itype(j))
5221 C Uncomment following three lines for SC-p interactions
5222 c         xj=c(1,nres+j)-xi
5223 c         yj=c(2,nres+j)-yi
5224 c         zj=c(3,nres+j)-zi
5225 C Uncomment following three lines for Ca-p interactions
5226           xj=c(1,j)
5227           yj=c(2,j)
5228           zj=c(3,j)
5229 c  174   continue
5230 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5231 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5232 C Condition for being inside the proper box
5233 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5234 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5235 c        go to 174
5236 c        endif
5237 c  175   continue
5238 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5239 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5240 cC Condition for being inside the proper box
5241 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5242 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5243 c        go to 175
5244 c        endif
5245 c  176   continue
5246 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5247 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5248 C Condition for being inside the proper box
5249 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5250 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5251 c        go to 176
5252           xj=mod(xj,boxxsize)
5253           if (xj.lt.0) xj=xj+boxxsize
5254           yj=mod(yj,boxysize)
5255           if (yj.lt.0) yj=yj+boxysize
5256           zj=mod(zj,boxzsize)
5257           if (zj.lt.0) zj=zj+boxzsize
5258       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5259       xj_safe=xj
5260       yj_safe=yj
5261       zj_safe=zj
5262       subchap=0
5263       do xshift=-1,1
5264       do yshift=-1,1
5265       do zshift=-1,1
5266           xj=xj_safe+xshift*boxxsize
5267           yj=yj_safe+yshift*boxysize
5268           zj=zj_safe+zshift*boxzsize
5269           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5270           if(dist_temp.lt.dist_init) then
5271             dist_init=dist_temp
5272             xj_temp=xj
5273             yj_temp=yj
5274             zj_temp=zj
5275             subchap=1
5276           endif
5277        enddo
5278        enddo
5279        enddo
5280        if (subchap.eq.1) then
5281           xj=xj_temp-xi
5282           yj=yj_temp-yi
5283           zj=zj_temp-zi
5284        else
5285           xj=xj_safe-xi
5286           yj=yj_safe-yi
5287           zj=zj_safe-zi
5288        endif
5289 c c       endif
5290 C          xj=xj-xi
5291 C          yj=yj-yi
5292 C          zj=zj-zi
5293           rij=xj*xj+yj*yj+zj*zj
5294
5295           r0ij=r0_scp
5296           r0ijsq=r0ij*r0ij
5297           if (rij.lt.r0ijsq) then
5298             evdwij=0.25d0*(rij-r0ijsq)**2
5299             fac=rij-r0ijsq
5300           else
5301             evdwij=0.0d0
5302             fac=0.0d0
5303           endif
5304           evdw2=evdw2+evdwij
5305 C
5306 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5307 C
5308           ggg(1)=xj*fac
5309           ggg(2)=yj*fac
5310           ggg(3)=zj*fac
5311 cgrad          if (j.lt.i) then
5312 cd          write (iout,*) 'j<i'
5313 C Uncomment following three lines for SC-p interactions
5314 c           do k=1,3
5315 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5316 c           enddo
5317 cgrad          else
5318 cd          write (iout,*) 'j>i'
5319 cgrad            do k=1,3
5320 cgrad              ggg(k)=-ggg(k)
5321 C Uncomment following line for SC-p interactions
5322 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5323 cgrad            enddo
5324 cgrad          endif
5325 cgrad          do k=1,3
5326 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5327 cgrad          enddo
5328 cgrad          kstart=min0(i+1,j)
5329 cgrad          kend=max0(i-1,j-1)
5330 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5331 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5332 cgrad          do k=kstart,kend
5333 cgrad            do l=1,3
5334 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5335 cgrad            enddo
5336 cgrad          enddo
5337           do k=1,3
5338             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5339             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5340           enddo
5341         enddo
5342
5343         enddo ! iint
5344       enddo ! i
5345 C      enddo !zshift
5346 C      enddo !yshift
5347 C      enddo !xshift
5348       return
5349       end
5350 C-----------------------------------------------------------------------------
5351       subroutine escp(evdw2,evdw2_14)
5352 C
5353 C This subroutine calculates the excluded-volume interaction energy between
5354 C peptide-group centers and side chains and its gradient in virtual-bond and
5355 C side-chain vectors.
5356 C
5357       implicit real*8 (a-h,o-z)
5358       include 'DIMENSIONS'
5359       include 'COMMON.GEO'
5360       include 'COMMON.VAR'
5361       include 'COMMON.LOCAL'
5362       include 'COMMON.CHAIN'
5363       include 'COMMON.DERIV'
5364       include 'COMMON.INTERACT'
5365       include 'COMMON.FFIELD'
5366       include 'COMMON.IOUNITS'
5367       include 'COMMON.CONTROL'
5368       include 'COMMON.SPLITELE'
5369       dimension ggg(3)
5370       evdw2=0.0D0
5371       evdw2_14=0.0d0
5372 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5373 cd    print '(a)','Enter ESCP'
5374 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5375 C      do xshift=-1,1
5376 C      do yshift=-1,1
5377 C      do zshift=-1,1
5378       do i=iatscp_s,iatscp_e
5379         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5380         iteli=itel(i)
5381         xi=0.5D0*(c(1,i)+c(1,i+1))
5382         yi=0.5D0*(c(2,i)+c(2,i+1))
5383         zi=0.5D0*(c(3,i)+c(3,i+1))
5384           xi=mod(xi,boxxsize)
5385           if (xi.lt.0) xi=xi+boxxsize
5386           yi=mod(yi,boxysize)
5387           if (yi.lt.0) yi=yi+boxysize
5388           zi=mod(zi,boxzsize)
5389           if (zi.lt.0) zi=zi+boxzsize
5390 c          xi=xi+xshift*boxxsize
5391 c          yi=yi+yshift*boxysize
5392 c          zi=zi+zshift*boxzsize
5393 c        print *,xi,yi,zi,'polozenie i'
5394 C Return atom into box, boxxsize is size of box in x dimension
5395 c  134   continue
5396 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5397 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5398 C Condition for being inside the proper box
5399 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5400 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5401 c        go to 134
5402 c        endif
5403 c  135   continue
5404 c          print *,xi,boxxsize,"pierwszy"
5405
5406 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5407 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5408 C Condition for being inside the proper box
5409 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5410 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5411 c        go to 135
5412 c        endif
5413 c  136   continue
5414 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5415 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5416 C Condition for being inside the proper box
5417 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5418 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5419 c        go to 136
5420 c        endif
5421         do iint=1,nscp_gr(i)
5422
5423         do j=iscpstart(i,iint),iscpend(i,iint)
5424           itypj=iabs(itype(j))
5425           if (itypj.eq.ntyp1) cycle
5426 C Uncomment following three lines for SC-p interactions
5427 c         xj=c(1,nres+j)-xi
5428 c         yj=c(2,nres+j)-yi
5429 c         zj=c(3,nres+j)-zi
5430 C Uncomment following three lines for Ca-p interactions
5431           xj=c(1,j)
5432           yj=c(2,j)
5433           zj=c(3,j)
5434           xj=mod(xj,boxxsize)
5435           if (xj.lt.0) xj=xj+boxxsize
5436           yj=mod(yj,boxysize)
5437           if (yj.lt.0) yj=yj+boxysize
5438           zj=mod(zj,boxzsize)
5439           if (zj.lt.0) zj=zj+boxzsize
5440 c  174   continue
5441 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5442 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5443 C Condition for being inside the proper box
5444 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5445 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5446 c        go to 174
5447 c        endif
5448 c  175   continue
5449 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5450 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5451 cC Condition for being inside the proper box
5452 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5453 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5454 c        go to 175
5455 c        endif
5456 c  176   continue
5457 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5458 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5459 C Condition for being inside the proper box
5460 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5461 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5462 c        go to 176
5463 c        endif
5464 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5465       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5466       xj_safe=xj
5467       yj_safe=yj
5468       zj_safe=zj
5469       subchap=0
5470       do xshift=-1,1
5471       do yshift=-1,1
5472       do zshift=-1,1
5473           xj=xj_safe+xshift*boxxsize
5474           yj=yj_safe+yshift*boxysize
5475           zj=zj_safe+zshift*boxzsize
5476           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5477           if(dist_temp.lt.dist_init) then
5478             dist_init=dist_temp
5479             xj_temp=xj
5480             yj_temp=yj
5481             zj_temp=zj
5482             subchap=1
5483           endif
5484        enddo
5485        enddo
5486        enddo
5487        if (subchap.eq.1) then
5488           xj=xj_temp-xi
5489           yj=yj_temp-yi
5490           zj=zj_temp-zi
5491        else
5492           xj=xj_safe-xi
5493           yj=yj_safe-yi
5494           zj=zj_safe-zi
5495        endif
5496 c          print *,xj,yj,zj,'polozenie j'
5497           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5498 c          print *,rrij
5499           sss=sscale(1.0d0/(dsqrt(rrij)))
5500 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5501 c          if (sss.eq.0) print *,'czasem jest OK'
5502           if (sss.le.0.0d0) cycle
5503           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5504           fac=rrij**expon2
5505           e1=fac*fac*aad(itypj,iteli)
5506           e2=fac*bad(itypj,iteli)
5507           if (iabs(j-i) .le. 2) then
5508             e1=scal14*e1
5509             e2=scal14*e2
5510             evdw2_14=evdw2_14+(e1+e2)*sss
5511           endif
5512           evdwij=e1+e2
5513           evdw2=evdw2+evdwij*sss
5514           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5515      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5516      &       bad(itypj,iteli)
5517 C
5518 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5519 C
5520           fac=-(evdwij+e1)*rrij*sss
5521           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5522           ggg(1)=xj*fac
5523           ggg(2)=yj*fac
5524           ggg(3)=zj*fac
5525 cgrad          if (j.lt.i) then
5526 cd          write (iout,*) 'j<i'
5527 C Uncomment following three lines for SC-p interactions
5528 c           do k=1,3
5529 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5530 c           enddo
5531 cgrad          else
5532 cd          write (iout,*) 'j>i'
5533 cgrad            do k=1,3
5534 cgrad              ggg(k)=-ggg(k)
5535 C Uncomment following line for SC-p interactions
5536 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5537 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5538 cgrad            enddo
5539 cgrad          endif
5540 cgrad          do k=1,3
5541 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5542 cgrad          enddo
5543 cgrad          kstart=min0(i+1,j)
5544 cgrad          kend=max0(i-1,j-1)
5545 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5546 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5547 cgrad          do k=kstart,kend
5548 cgrad            do l=1,3
5549 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5550 cgrad            enddo
5551 cgrad          enddo
5552           do k=1,3
5553             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5554             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5555           enddo
5556 c        endif !endif for sscale cutoff
5557         enddo ! j
5558
5559         enddo ! iint
5560       enddo ! i
5561 c      enddo !zshift
5562 c      enddo !yshift
5563 c      enddo !xshift
5564       do i=1,nct
5565         do j=1,3
5566           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5567           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5568           gradx_scp(j,i)=expon*gradx_scp(j,i)
5569         enddo
5570       enddo
5571 C******************************************************************************
5572 C
5573 C                              N O T E !!!
5574 C
5575 C To save time the factor EXPON has been extracted from ALL components
5576 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5577 C use!
5578 C
5579 C******************************************************************************
5580       return
5581       end
5582 C--------------------------------------------------------------------------
5583       subroutine edis(ehpb)
5584 C
5585 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5586 C
5587       implicit real*8 (a-h,o-z)
5588       include 'DIMENSIONS'
5589       include 'COMMON.SBRIDGE'
5590       include 'COMMON.CHAIN'
5591       include 'COMMON.DERIV'
5592       include 'COMMON.VAR'
5593       include 'COMMON.INTERACT'
5594       include 'COMMON.IOUNITS'
5595       include 'COMMON.CONTROL'
5596       dimension ggg(3)
5597       ehpb=0.0D0
5598       do i=1,3
5599        ggg(i)=0.0d0
5600       enddo
5601 C      write (iout,*) ,"link_end",link_end,constr_dist
5602 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5603 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5604       if (link_end.eq.0) return
5605       do i=link_start,link_end
5606 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5607 C CA-CA distance used in regularization of structure.
5608         ii=ihpb(i)
5609         jj=jhpb(i)
5610 C iii and jjj point to the residues for which the distance is assigned.
5611         if (ii.gt.nres) then
5612           iii=ii-nres
5613           jjj=jj-nres
5614         else
5615           iii=ii
5616           jjj=jj
5617         endif
5618 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5619 c     &    dhpb(i),dhpb1(i),forcon(i)
5620 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5621 C    distance and angle dependent SS bond potential.
5622 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5623 C     & iabs(itype(jjj)).eq.1) then
5624 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5625 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5626         if (.not.dyn_ss .and. i.le.nss) then
5627 C 15/02/13 CC dynamic SSbond - additional check
5628          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5629      & iabs(itype(jjj)).eq.1) then
5630           call ssbond_ene(iii,jjj,eij)
5631           ehpb=ehpb+2*eij
5632          endif
5633 cd          write (iout,*) "eij",eij
5634 cd   &   ' waga=',waga,' fac=',fac
5635         else if (ii.gt.nres .and. jj.gt.nres) then
5636 c Restraints from contact prediction
5637           dd=dist(ii,jj)
5638           if (constr_dist.eq.11) then
5639             ehpb=ehpb+fordepth(i)**4.0d0
5640      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5641             fac=fordepth(i)**4.0d0
5642      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5643           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5644      &    ehpb,fordepth(i),dd
5645            else
5646           if (dhpb1(i).gt.0.0d0) then
5647             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5648             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5649 c            write (iout,*) "beta nmr",
5650 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5651           else
5652             dd=dist(ii,jj)
5653             rdis=dd-dhpb(i)
5654 C Get the force constant corresponding to this distance.
5655             waga=forcon(i)
5656 C Calculate the contribution to energy.
5657             ehpb=ehpb+waga*rdis*rdis
5658 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5659 C
5660 C Evaluate gradient.
5661 C
5662             fac=waga*rdis/dd
5663           endif
5664           endif
5665           do j=1,3
5666             ggg(j)=fac*(c(j,jj)-c(j,ii))
5667           enddo
5668           do j=1,3
5669             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5670             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5671           enddo
5672           do k=1,3
5673             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5674             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5675           enddo
5676         else
5677 C Calculate the distance between the two points and its difference from the
5678 C target distance.
5679           dd=dist(ii,jj)
5680           if (constr_dist.eq.11) then
5681             ehpb=ehpb+fordepth(i)**4.0d0
5682      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5683             fac=fordepth(i)**4.0d0
5684      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5685           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5686      &    ehpb,fordepth(i),dd
5687            else
5688           if (dhpb1(i).gt.0.0d0) then
5689             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5690             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5691 c            write (iout,*) "alph nmr",
5692 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5693           else
5694             rdis=dd-dhpb(i)
5695 C Get the force constant corresponding to this distance.
5696             waga=forcon(i)
5697 C Calculate the contribution to energy.
5698             ehpb=ehpb+waga*rdis*rdis
5699 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5700 C
5701 C Evaluate gradient.
5702 C
5703             fac=waga*rdis/dd
5704           endif
5705           endif
5706             do j=1,3
5707               ggg(j)=fac*(c(j,jj)-c(j,ii))
5708             enddo
5709 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5710 C If this is a SC-SC distance, we need to calculate the contributions to the
5711 C Cartesian gradient in the SC vectors (ghpbx).
5712           if (iii.lt.ii) then
5713           do j=1,3
5714             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5715             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5716           enddo
5717           endif
5718 cgrad        do j=iii,jjj-1
5719 cgrad          do k=1,3
5720 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5721 cgrad          enddo
5722 cgrad        enddo
5723           do k=1,3
5724             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5725             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5726           enddo
5727         endif
5728       enddo
5729       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5730       return
5731       end
5732 C--------------------------------------------------------------------------
5733       subroutine ssbond_ene(i,j,eij)
5734 C
5735 C Calculate the distance and angle dependent SS-bond potential energy
5736 C using a free-energy function derived based on RHF/6-31G** ab initio
5737 C calculations of diethyl disulfide.
5738 C
5739 C A. Liwo and U. Kozlowska, 11/24/03
5740 C
5741       implicit real*8 (a-h,o-z)
5742       include 'DIMENSIONS'
5743       include 'COMMON.SBRIDGE'
5744       include 'COMMON.CHAIN'
5745       include 'COMMON.DERIV'
5746       include 'COMMON.LOCAL'
5747       include 'COMMON.INTERACT'
5748       include 'COMMON.VAR'
5749       include 'COMMON.IOUNITS'
5750       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5751       itypi=iabs(itype(i))
5752       xi=c(1,nres+i)
5753       yi=c(2,nres+i)
5754       zi=c(3,nres+i)
5755       dxi=dc_norm(1,nres+i)
5756       dyi=dc_norm(2,nres+i)
5757       dzi=dc_norm(3,nres+i)
5758 c      dsci_inv=dsc_inv(itypi)
5759       dsci_inv=vbld_inv(nres+i)
5760       itypj=iabs(itype(j))
5761 c      dscj_inv=dsc_inv(itypj)
5762       dscj_inv=vbld_inv(nres+j)
5763       xj=c(1,nres+j)-xi
5764       yj=c(2,nres+j)-yi
5765       zj=c(3,nres+j)-zi
5766       dxj=dc_norm(1,nres+j)
5767       dyj=dc_norm(2,nres+j)
5768       dzj=dc_norm(3,nres+j)
5769       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5770       rij=dsqrt(rrij)
5771       erij(1)=xj*rij
5772       erij(2)=yj*rij
5773       erij(3)=zj*rij
5774       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5775       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5776       om12=dxi*dxj+dyi*dyj+dzi*dzj
5777       do k=1,3
5778         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5779         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5780       enddo
5781       rij=1.0d0/rij
5782       deltad=rij-d0cm
5783       deltat1=1.0d0-om1
5784       deltat2=1.0d0+om2
5785       deltat12=om2-om1+2.0d0
5786       cosphi=om12-om1*om2
5787       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5788      &  +akct*deltad*deltat12
5789      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5790 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5791 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5792 c     &  " deltat12",deltat12," eij",eij
5793       ed=2*akcm*deltad+akct*deltat12
5794       pom1=akct*deltad
5795       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5796       eom1=-2*akth*deltat1-pom1-om2*pom2
5797       eom2= 2*akth*deltat2+pom1-om1*pom2
5798       eom12=pom2
5799       do k=1,3
5800         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5801         ghpbx(k,i)=ghpbx(k,i)-ggk
5802      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5803      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5804         ghpbx(k,j)=ghpbx(k,j)+ggk
5805      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5806      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5807         ghpbc(k,i)=ghpbc(k,i)-ggk
5808         ghpbc(k,j)=ghpbc(k,j)+ggk
5809       enddo
5810 C
5811 C Calculate the components of the gradient in DC and X
5812 C
5813 cgrad      do k=i,j-1
5814 cgrad        do l=1,3
5815 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5816 cgrad        enddo
5817 cgrad      enddo
5818       return
5819       end
5820 C--------------------------------------------------------------------------
5821       subroutine ebond(estr)
5822 c
5823 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5824 c
5825       implicit real*8 (a-h,o-z)
5826       include 'DIMENSIONS'
5827       include 'COMMON.LOCAL'
5828       include 'COMMON.GEO'
5829       include 'COMMON.INTERACT'
5830       include 'COMMON.DERIV'
5831       include 'COMMON.VAR'
5832       include 'COMMON.CHAIN'
5833       include 'COMMON.IOUNITS'
5834       include 'COMMON.NAMES'
5835       include 'COMMON.FFIELD'
5836       include 'COMMON.CONTROL'
5837       include 'COMMON.SETUP'
5838       double precision u(3),ud(3)
5839       estr=0.0d0
5840       estr1=0.0d0
5841       do i=ibondp_start,ibondp_end
5842         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5843 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5844 c          do j=1,3
5845 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5846 c     &      *dc(j,i-1)/vbld(i)
5847 c          enddo
5848 c          if (energy_dec) write(iout,*)
5849 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5850 c        else
5851 C       Checking if it involves dummy (NH3+ or COO-) group
5852          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5853 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5854         diff = vbld(i)-vbldpDUM
5855         if (energy_dec) write(iout,*) "dum_bond",i,diff
5856          else
5857 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5858         diff = vbld(i)-vbldp0
5859          endif
5860         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5861      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5862         estr=estr+diff*diff
5863         do j=1,3
5864           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5865         enddo
5866 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5867 c        endif
5868       enddo
5869
5870       estr=0.5d0*AKP*estr+estr1
5871 c
5872 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5873 c
5874       do i=ibond_start,ibond_end
5875         iti=iabs(itype(i))
5876         if (iti.ne.10 .and. iti.ne.ntyp1) then
5877           nbi=nbondterm(iti)
5878           if (nbi.eq.1) then
5879             diff=vbld(i+nres)-vbldsc0(1,iti)
5880             if (energy_dec)  write (iout,*)
5881      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5882      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5883             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5884             do j=1,3
5885               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5886             enddo
5887           else
5888             do j=1,nbi
5889               diff=vbld(i+nres)-vbldsc0(j,iti)
5890               ud(j)=aksc(j,iti)*diff
5891               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5892             enddo
5893             uprod=u(1)
5894             do j=2,nbi
5895               uprod=uprod*u(j)
5896             enddo
5897             usum=0.0d0
5898             usumsqder=0.0d0
5899             do j=1,nbi
5900               uprod1=1.0d0
5901               uprod2=1.0d0
5902               do k=1,nbi
5903                 if (k.ne.j) then
5904                   uprod1=uprod1*u(k)
5905                   uprod2=uprod2*u(k)*u(k)
5906                 endif
5907               enddo
5908               usum=usum+uprod1
5909               usumsqder=usumsqder+ud(j)*uprod2
5910             enddo
5911             estr=estr+uprod/usum
5912             do j=1,3
5913              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5914             enddo
5915           endif
5916         endif
5917       enddo
5918       return
5919       end
5920 #ifdef CRYST_THETA
5921 C--------------------------------------------------------------------------
5922       subroutine ebend(etheta,ethetacnstr)
5923 C
5924 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5925 C angles gamma and its derivatives in consecutive thetas and gammas.
5926 C
5927       implicit real*8 (a-h,o-z)
5928       include 'DIMENSIONS'
5929       include 'COMMON.LOCAL'
5930       include 'COMMON.GEO'
5931       include 'COMMON.INTERACT'
5932       include 'COMMON.DERIV'
5933       include 'COMMON.VAR'
5934       include 'COMMON.CHAIN'
5935       include 'COMMON.IOUNITS'
5936       include 'COMMON.NAMES'
5937       include 'COMMON.FFIELD'
5938       include 'COMMON.CONTROL'
5939       include 'COMMON.TORCNSTR'
5940       common /calcthet/ term1,term2,termm,diffak,ratak,
5941      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5942      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5943       double precision y(2),z(2)
5944       delta=0.02d0*pi
5945 c      time11=dexp(-2*time)
5946 c      time12=1.0d0
5947       etheta=0.0D0
5948 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5949       do i=ithet_start,ithet_end
5950         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5951      &  .or.itype(i).eq.ntyp1) cycle
5952 C Zero the energy function and its derivative at 0 or pi.
5953         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5954         it=itype(i-1)
5955         ichir1=isign(1,itype(i-2))
5956         ichir2=isign(1,itype(i))
5957          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5958          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5959          if (itype(i-1).eq.10) then
5960           itype1=isign(10,itype(i-2))
5961           ichir11=isign(1,itype(i-2))
5962           ichir12=isign(1,itype(i-2))
5963           itype2=isign(10,itype(i))
5964           ichir21=isign(1,itype(i))
5965           ichir22=isign(1,itype(i))
5966          endif
5967
5968         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5969 #ifdef OSF
5970           phii=phi(i)
5971           if (phii.ne.phii) phii=150.0
5972 #else
5973           phii=phi(i)
5974 #endif
5975           y(1)=dcos(phii)
5976           y(2)=dsin(phii)
5977         else
5978           y(1)=0.0D0
5979           y(2)=0.0D0
5980         endif
5981         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5982 #ifdef OSF
5983           phii1=phi(i+1)
5984           if (phii1.ne.phii1) phii1=150.0
5985           phii1=pinorm(phii1)
5986           z(1)=cos(phii1)
5987 #else
5988           phii1=phi(i+1)
5989 #endif
5990           z(1)=dcos(phii1)
5991           z(2)=dsin(phii1)
5992         else
5993           z(1)=0.0D0
5994           z(2)=0.0D0
5995         endif
5996 C Calculate the "mean" value of theta from the part of the distribution
5997 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5998 C In following comments this theta will be referred to as t_c.
5999         thet_pred_mean=0.0d0
6000         do k=1,2
6001             athetk=athet(k,it,ichir1,ichir2)
6002             bthetk=bthet(k,it,ichir1,ichir2)
6003           if (it.eq.10) then
6004              athetk=athet(k,itype1,ichir11,ichir12)
6005              bthetk=bthet(k,itype2,ichir21,ichir22)
6006           endif
6007          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6008 c         write(iout,*) 'chuj tu', y(k),z(k)
6009         enddo
6010         dthett=thet_pred_mean*ssd
6011         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6012 C Derivatives of the "mean" values in gamma1 and gamma2.
6013         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6014      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6015          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6016      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6017          if (it.eq.10) then
6018       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6019      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6020         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6021      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6022          endif
6023         if (theta(i).gt.pi-delta) then
6024           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6025      &         E_tc0)
6026           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6027           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6028           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6029      &        E_theta)
6030           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6031      &        E_tc)
6032         else if (theta(i).lt.delta) then
6033           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6034           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6035           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6036      &        E_theta)
6037           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6038           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6039      &        E_tc)
6040         else
6041           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6042      &        E_theta,E_tc)
6043         endif
6044         etheta=etheta+ethetai
6045         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6046      &      'ebend',i,ethetai,theta(i),itype(i)
6047         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6048         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6049         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6050       enddo
6051       ethetacnstr=0.0d0
6052 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6053       do i=ithetaconstr_start,ithetaconstr_end
6054         itheta=itheta_constr(i)
6055         thetiii=theta(itheta)
6056         difi=pinorm(thetiii-theta_constr0(i))
6057         if (difi.gt.theta_drange(i)) then
6058           difi=difi-theta_drange(i)
6059           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6060           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6061      &    +for_thet_constr(i)*difi**3
6062         else if (difi.lt.-drange(i)) then
6063           difi=difi+drange(i)
6064           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6065           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6066      &    +for_thet_constr(i)*difi**3
6067         else
6068           difi=0.0
6069         endif
6070        if (energy_dec) then
6071         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6072      &    i,itheta,rad2deg*thetiii,
6073      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6074      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6075      &    gloc(itheta+nphi-2,icg)
6076         endif
6077       enddo
6078
6079 C Ufff.... We've done all this!!!
6080       return
6081       end
6082 C---------------------------------------------------------------------------
6083       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6084      &     E_tc)
6085       implicit real*8 (a-h,o-z)
6086       include 'DIMENSIONS'
6087       include 'COMMON.LOCAL'
6088       include 'COMMON.IOUNITS'
6089       common /calcthet/ term1,term2,termm,diffak,ratak,
6090      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6091      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6092 C Calculate the contributions to both Gaussian lobes.
6093 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6094 C The "polynomial part" of the "standard deviation" of this part of
6095 C the distributioni.
6096 ccc        write (iout,*) thetai,thet_pred_mean
6097         sig=polthet(3,it)
6098         do j=2,0,-1
6099           sig=sig*thet_pred_mean+polthet(j,it)
6100         enddo
6101 C Derivative of the "interior part" of the "standard deviation of the"
6102 C gamma-dependent Gaussian lobe in t_c.
6103         sigtc=3*polthet(3,it)
6104         do j=2,1,-1
6105           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6106         enddo
6107         sigtc=sig*sigtc
6108 C Set the parameters of both Gaussian lobes of the distribution.
6109 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6110         fac=sig*sig+sigc0(it)
6111         sigcsq=fac+fac
6112         sigc=1.0D0/sigcsq
6113 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6114         sigsqtc=-4.0D0*sigcsq*sigtc
6115 c       print *,i,sig,sigtc,sigsqtc
6116 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6117         sigtc=-sigtc/(fac*fac)
6118 C Following variable is sigma(t_c)**(-2)
6119         sigcsq=sigcsq*sigcsq
6120         sig0i=sig0(it)
6121         sig0inv=1.0D0/sig0i**2
6122         delthec=thetai-thet_pred_mean
6123         delthe0=thetai-theta0i
6124         term1=-0.5D0*sigcsq*delthec*delthec
6125         term2=-0.5D0*sig0inv*delthe0*delthe0
6126 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6127 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6128 C NaNs in taking the logarithm. We extract the largest exponent which is added
6129 C to the energy (this being the log of the distribution) at the end of energy
6130 C term evaluation for this virtual-bond angle.
6131         if (term1.gt.term2) then
6132           termm=term1
6133           term2=dexp(term2-termm)
6134           term1=1.0d0
6135         else
6136           termm=term2
6137           term1=dexp(term1-termm)
6138           term2=1.0d0
6139         endif
6140 C The ratio between the gamma-independent and gamma-dependent lobes of
6141 C the distribution is a Gaussian function of thet_pred_mean too.
6142         diffak=gthet(2,it)-thet_pred_mean
6143         ratak=diffak/gthet(3,it)**2
6144         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6145 C Let's differentiate it in thet_pred_mean NOW.
6146         aktc=ak*ratak
6147 C Now put together the distribution terms to make complete distribution.
6148         termexp=term1+ak*term2
6149         termpre=sigc+ak*sig0i
6150 C Contribution of the bending energy from this theta is just the -log of
6151 C the sum of the contributions from the two lobes and the pre-exponential
6152 C factor. Simple enough, isn't it?
6153         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6154 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6155 C NOW the derivatives!!!
6156 C 6/6/97 Take into account the deformation.
6157         E_theta=(delthec*sigcsq*term1
6158      &       +ak*delthe0*sig0inv*term2)/termexp
6159         E_tc=((sigtc+aktc*sig0i)/termpre
6160      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6161      &       aktc*term2)/termexp)
6162       return
6163       end
6164 c-----------------------------------------------------------------------------
6165       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6166       implicit real*8 (a-h,o-z)
6167       include 'DIMENSIONS'
6168       include 'COMMON.LOCAL'
6169       include 'COMMON.IOUNITS'
6170       common /calcthet/ term1,term2,termm,diffak,ratak,
6171      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6172      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6173       delthec=thetai-thet_pred_mean
6174       delthe0=thetai-theta0i
6175 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6176       t3 = thetai-thet_pred_mean
6177       t6 = t3**2
6178       t9 = term1
6179       t12 = t3*sigcsq
6180       t14 = t12+t6*sigsqtc
6181       t16 = 1.0d0
6182       t21 = thetai-theta0i
6183       t23 = t21**2
6184       t26 = term2
6185       t27 = t21*t26
6186       t32 = termexp
6187       t40 = t32**2
6188       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6189      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6190      & *(-t12*t9-ak*sig0inv*t27)
6191       return
6192       end
6193 #else
6194 C--------------------------------------------------------------------------
6195       subroutine ebend(etheta,ethetacnstr)
6196 C
6197 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6198 C angles gamma and its derivatives in consecutive thetas and gammas.
6199 C ab initio-derived potentials from
6200 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6201 C
6202       implicit real*8 (a-h,o-z)
6203       include 'DIMENSIONS'
6204       include 'COMMON.LOCAL'
6205       include 'COMMON.GEO'
6206       include 'COMMON.INTERACT'
6207       include 'COMMON.DERIV'
6208       include 'COMMON.VAR'
6209       include 'COMMON.CHAIN'
6210       include 'COMMON.IOUNITS'
6211       include 'COMMON.NAMES'
6212       include 'COMMON.FFIELD'
6213       include 'COMMON.CONTROL'
6214       include 'COMMON.TORCNSTR'
6215       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6216      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6217      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6218      & sinph1ph2(maxdouble,maxdouble)
6219       logical lprn /.false./, lprn1 /.false./
6220       etheta=0.0D0
6221       do i=ithet_start,ithet_end
6222 c        print *,i,itype(i-1),itype(i),itype(i-2)
6223         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6224      &  .or.itype(i).eq.ntyp1) cycle
6225 C        print *,i,theta(i)
6226         if (iabs(itype(i+1)).eq.20) iblock=2
6227         if (iabs(itype(i+1)).ne.20) iblock=1
6228         dethetai=0.0d0
6229         dephii=0.0d0
6230         dephii1=0.0d0
6231         theti2=0.5d0*theta(i)
6232         ityp2=ithetyp((itype(i-1)))
6233         do k=1,nntheterm
6234           coskt(k)=dcos(k*theti2)
6235           sinkt(k)=dsin(k*theti2)
6236         enddo
6237 C        print *,ethetai
6238         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6239 #ifdef OSF
6240           phii=phi(i)
6241           if (phii.ne.phii) phii=150.0
6242 #else
6243           phii=phi(i)
6244 #endif
6245           ityp1=ithetyp((itype(i-2)))
6246 C propagation of chirality for glycine type
6247           do k=1,nsingle
6248             cosph1(k)=dcos(k*phii)
6249             sinph1(k)=dsin(k*phii)
6250           enddo
6251         else
6252           phii=0.0d0
6253           do k=1,nsingle
6254           ityp1=ithetyp((itype(i-2)))
6255             cosph1(k)=0.0d0
6256             sinph1(k)=0.0d0
6257           enddo
6258         endif
6259         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6260 #ifdef OSF
6261           phii1=phi(i+1)
6262           if (phii1.ne.phii1) phii1=150.0
6263           phii1=pinorm(phii1)
6264 #else
6265           phii1=phi(i+1)
6266 #endif
6267           ityp3=ithetyp((itype(i)))
6268           do k=1,nsingle
6269             cosph2(k)=dcos(k*phii1)
6270             sinph2(k)=dsin(k*phii1)
6271           enddo
6272         else
6273           phii1=0.0d0
6274           ityp3=ithetyp((itype(i)))
6275           do k=1,nsingle
6276             cosph2(k)=0.0d0
6277             sinph2(k)=0.0d0
6278           enddo
6279         endif
6280         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6281         do k=1,ndouble
6282           do l=1,k-1
6283             ccl=cosph1(l)*cosph2(k-l)
6284             ssl=sinph1(l)*sinph2(k-l)
6285             scl=sinph1(l)*cosph2(k-l)
6286             csl=cosph1(l)*sinph2(k-l)
6287             cosph1ph2(l,k)=ccl-ssl
6288             cosph1ph2(k,l)=ccl+ssl
6289             sinph1ph2(l,k)=scl+csl
6290             sinph1ph2(k,l)=scl-csl
6291           enddo
6292         enddo
6293         if (lprn) then
6294         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6295      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6296         write (iout,*) "coskt and sinkt"
6297         do k=1,nntheterm
6298           write (iout,*) k,coskt(k),sinkt(k)
6299         enddo
6300         endif
6301         do k=1,ntheterm
6302           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6303           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6304      &      *coskt(k)
6305           if (lprn)
6306      &    write (iout,*) "k",k,"
6307      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6308      &     " ethetai",ethetai
6309         enddo
6310         if (lprn) then
6311         write (iout,*) "cosph and sinph"
6312         do k=1,nsingle
6313           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6314         enddo
6315         write (iout,*) "cosph1ph2 and sinph2ph2"
6316         do k=2,ndouble
6317           do l=1,k-1
6318             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6319      &         sinph1ph2(l,k),sinph1ph2(k,l)
6320           enddo
6321         enddo
6322         write(iout,*) "ethetai",ethetai
6323         endif
6324 C       print *,ethetai
6325         do m=1,ntheterm2
6326           do k=1,nsingle
6327             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6328      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6329      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6330      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6331             ethetai=ethetai+sinkt(m)*aux
6332             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6333             dephii=dephii+k*sinkt(m)*(
6334      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6335      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6336             dephii1=dephii1+k*sinkt(m)*(
6337      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6338      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6339             if (lprn)
6340      &      write (iout,*) "m",m," k",k," bbthet",
6341      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6342      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6343      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6344      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6345 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6346           enddo
6347         enddo
6348 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6349 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6350 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6351 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6352         if (lprn)
6353      &  write(iout,*) "ethetai",ethetai
6354 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6355         do m=1,ntheterm3
6356           do k=2,ndouble
6357             do l=1,k-1
6358               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6359      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6360      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6361      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6362               ethetai=ethetai+sinkt(m)*aux
6363               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6364               dephii=dephii+l*sinkt(m)*(
6365      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6366      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6367      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6368      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6369               dephii1=dephii1+(k-l)*sinkt(m)*(
6370      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6371      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6372      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6373      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6374               if (lprn) then
6375               write (iout,*) "m",m," k",k," l",l," ffthet",
6376      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6377      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6378      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6379      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6380      &            " ethetai",ethetai
6381               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6382      &            cosph1ph2(k,l)*sinkt(m),
6383      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6384               endif
6385             enddo
6386           enddo
6387         enddo
6388 10      continue
6389 c        lprn1=.true.
6390 C        print *,ethetai
6391         if (lprn1)
6392      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6393      &   i,theta(i)*rad2deg,phii*rad2deg,
6394      &   phii1*rad2deg,ethetai
6395 c        lprn1=.false.
6396         etheta=etheta+ethetai
6397         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6398         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6399         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6400       enddo
6401 C now constrains
6402       ethetacnstr=0.0d0
6403 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6404       do i=ithetaconstr_start,ithetaconstr_end
6405         itheta=itheta_constr(i)
6406         thetiii=theta(itheta)
6407         difi=pinorm(thetiii-theta_constr0(i))
6408         if (difi.gt.theta_drange(i)) then
6409           difi=difi-theta_drange(i)
6410           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6411           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6412      &    +for_thet_constr(i)*difi**3
6413         else if (difi.lt.-drange(i)) then
6414           difi=difi+drange(i)
6415           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6416           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6417      &    +for_thet_constr(i)*difi**3
6418         else
6419           difi=0.0
6420         endif
6421        if (energy_dec) then
6422         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6423      &    i,itheta,rad2deg*thetiii,
6424      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6425      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6426      &    gloc(itheta+nphi-2,icg)
6427         endif
6428       enddo
6429
6430       return
6431       end
6432 #endif
6433 #ifdef CRYST_SC
6434 c-----------------------------------------------------------------------------
6435       subroutine esc(escloc)
6436 C Calculate the local energy of a side chain and its derivatives in the
6437 C corresponding virtual-bond valence angles THETA and the spherical angles
6438 C ALPHA and OMEGA.
6439       implicit real*8 (a-h,o-z)
6440       include 'DIMENSIONS'
6441       include 'COMMON.GEO'
6442       include 'COMMON.LOCAL'
6443       include 'COMMON.VAR'
6444       include 'COMMON.INTERACT'
6445       include 'COMMON.DERIV'
6446       include 'COMMON.CHAIN'
6447       include 'COMMON.IOUNITS'
6448       include 'COMMON.NAMES'
6449       include 'COMMON.FFIELD'
6450       include 'COMMON.CONTROL'
6451       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6452      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6453       common /sccalc/ time11,time12,time112,theti,it,nlobit
6454       delta=0.02d0*pi
6455       escloc=0.0D0
6456 c     write (iout,'(a)') 'ESC'
6457       do i=loc_start,loc_end
6458         it=itype(i)
6459         if (it.eq.ntyp1) cycle
6460         if (it.eq.10) goto 1
6461         nlobit=nlob(iabs(it))
6462 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6463 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6464         theti=theta(i+1)-pipol
6465         x(1)=dtan(theti)
6466         x(2)=alph(i)
6467         x(3)=omeg(i)
6468
6469         if (x(2).gt.pi-delta) then
6470           xtemp(1)=x(1)
6471           xtemp(2)=pi-delta
6472           xtemp(3)=x(3)
6473           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6474           xtemp(2)=pi
6475           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6476           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6477      &        escloci,dersc(2))
6478           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6479      &        ddersc0(1),dersc(1))
6480           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6481      &        ddersc0(3),dersc(3))
6482           xtemp(2)=pi-delta
6483           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6484           xtemp(2)=pi
6485           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6486           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6487      &            dersc0(2),esclocbi,dersc02)
6488           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6489      &            dersc12,dersc01)
6490           call splinthet(x(2),0.5d0*delta,ss,ssd)
6491           dersc0(1)=dersc01
6492           dersc0(2)=dersc02
6493           dersc0(3)=0.0d0
6494           do k=1,3
6495             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6496           enddo
6497           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6498 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6499 c    &             esclocbi,ss,ssd
6500           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6501 c         escloci=esclocbi
6502 c         write (iout,*) escloci
6503         else if (x(2).lt.delta) then
6504           xtemp(1)=x(1)
6505           xtemp(2)=delta
6506           xtemp(3)=x(3)
6507           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6508           xtemp(2)=0.0d0
6509           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6510           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6511      &        escloci,dersc(2))
6512           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6513      &        ddersc0(1),dersc(1))
6514           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6515      &        ddersc0(3),dersc(3))
6516           xtemp(2)=delta
6517           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6518           xtemp(2)=0.0d0
6519           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6520           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6521      &            dersc0(2),esclocbi,dersc02)
6522           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6523      &            dersc12,dersc01)
6524           dersc0(1)=dersc01
6525           dersc0(2)=dersc02
6526           dersc0(3)=0.0d0
6527           call splinthet(x(2),0.5d0*delta,ss,ssd)
6528           do k=1,3
6529             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6530           enddo
6531           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6532 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6533 c    &             esclocbi,ss,ssd
6534           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6535 c         write (iout,*) escloci
6536         else
6537           call enesc(x,escloci,dersc,ddummy,.false.)
6538         endif
6539
6540         escloc=escloc+escloci
6541         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6542      &     'escloc',i,escloci
6543 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6544
6545         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6546      &   wscloc*dersc(1)
6547         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6548         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6549     1   continue
6550       enddo
6551       return
6552       end
6553 C---------------------------------------------------------------------------
6554       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6555       implicit real*8 (a-h,o-z)
6556       include 'DIMENSIONS'
6557       include 'COMMON.GEO'
6558       include 'COMMON.LOCAL'
6559       include 'COMMON.IOUNITS'
6560       common /sccalc/ time11,time12,time112,theti,it,nlobit
6561       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6562       double precision contr(maxlob,-1:1)
6563       logical mixed
6564 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6565         escloc_i=0.0D0
6566         do j=1,3
6567           dersc(j)=0.0D0
6568           if (mixed) ddersc(j)=0.0d0
6569         enddo
6570         x3=x(3)
6571
6572 C Because of periodicity of the dependence of the SC energy in omega we have
6573 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6574 C To avoid underflows, first compute & store the exponents.
6575
6576         do iii=-1,1
6577
6578           x(3)=x3+iii*dwapi
6579
6580           do j=1,nlobit
6581             do k=1,3
6582               z(k)=x(k)-censc(k,j,it)
6583             enddo
6584             do k=1,3
6585               Axk=0.0D0
6586               do l=1,3
6587                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6588               enddo
6589               Ax(k,j,iii)=Axk
6590             enddo
6591             expfac=0.0D0
6592             do k=1,3
6593               expfac=expfac+Ax(k,j,iii)*z(k)
6594             enddo
6595             contr(j,iii)=expfac
6596           enddo ! j
6597
6598         enddo ! iii
6599
6600         x(3)=x3
6601 C As in the case of ebend, we want to avoid underflows in exponentiation and
6602 C subsequent NaNs and INFs in energy calculation.
6603 C Find the largest exponent
6604         emin=contr(1,-1)
6605         do iii=-1,1
6606           do j=1,nlobit
6607             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6608           enddo
6609         enddo
6610         emin=0.5D0*emin
6611 cd      print *,'it=',it,' emin=',emin
6612
6613 C Compute the contribution to SC energy and derivatives
6614         do iii=-1,1
6615
6616           do j=1,nlobit
6617 #ifdef OSF
6618             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6619             if(adexp.ne.adexp) adexp=1.0
6620             expfac=dexp(adexp)
6621 #else
6622             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6623 #endif
6624 cd          print *,'j=',j,' expfac=',expfac
6625             escloc_i=escloc_i+expfac
6626             do k=1,3
6627               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6628             enddo
6629             if (mixed) then
6630               do k=1,3,2
6631                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6632      &            +gaussc(k,2,j,it))*expfac
6633               enddo
6634             endif
6635           enddo
6636
6637         enddo ! iii
6638
6639         dersc(1)=dersc(1)/cos(theti)**2
6640         ddersc(1)=ddersc(1)/cos(theti)**2
6641         ddersc(3)=ddersc(3)
6642
6643         escloci=-(dlog(escloc_i)-emin)
6644         do j=1,3
6645           dersc(j)=dersc(j)/escloc_i
6646         enddo
6647         if (mixed) then
6648           do j=1,3,2
6649             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6650           enddo
6651         endif
6652       return
6653       end
6654 C------------------------------------------------------------------------------
6655       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6656       implicit real*8 (a-h,o-z)
6657       include 'DIMENSIONS'
6658       include 'COMMON.GEO'
6659       include 'COMMON.LOCAL'
6660       include 'COMMON.IOUNITS'
6661       common /sccalc/ time11,time12,time112,theti,it,nlobit
6662       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6663       double precision contr(maxlob)
6664       logical mixed
6665
6666       escloc_i=0.0D0
6667
6668       do j=1,3
6669         dersc(j)=0.0D0
6670       enddo
6671
6672       do j=1,nlobit
6673         do k=1,2
6674           z(k)=x(k)-censc(k,j,it)
6675         enddo
6676         z(3)=dwapi
6677         do k=1,3
6678           Axk=0.0D0
6679           do l=1,3
6680             Axk=Axk+gaussc(l,k,j,it)*z(l)
6681           enddo
6682           Ax(k,j)=Axk
6683         enddo
6684         expfac=0.0D0
6685         do k=1,3
6686           expfac=expfac+Ax(k,j)*z(k)
6687         enddo
6688         contr(j)=expfac
6689       enddo ! j
6690
6691 C As in the case of ebend, we want to avoid underflows in exponentiation and
6692 C subsequent NaNs and INFs in energy calculation.
6693 C Find the largest exponent
6694       emin=contr(1)
6695       do j=1,nlobit
6696         if (emin.gt.contr(j)) emin=contr(j)
6697       enddo
6698       emin=0.5D0*emin
6699
6700 C Compute the contribution to SC energy and derivatives
6701
6702       dersc12=0.0d0
6703       do j=1,nlobit
6704         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6705         escloc_i=escloc_i+expfac
6706         do k=1,2
6707           dersc(k)=dersc(k)+Ax(k,j)*expfac
6708         enddo
6709         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6710      &            +gaussc(1,2,j,it))*expfac
6711         dersc(3)=0.0d0
6712       enddo
6713
6714       dersc(1)=dersc(1)/cos(theti)**2
6715       dersc12=dersc12/cos(theti)**2
6716       escloci=-(dlog(escloc_i)-emin)
6717       do j=1,2
6718         dersc(j)=dersc(j)/escloc_i
6719       enddo
6720       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6721       return
6722       end
6723 #else
6724 c----------------------------------------------------------------------------------
6725       subroutine esc(escloc)
6726 C Calculate the local energy of a side chain and its derivatives in the
6727 C corresponding virtual-bond valence angles THETA and the spherical angles
6728 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6729 C added by Urszula Kozlowska. 07/11/2007
6730 C
6731       implicit real*8 (a-h,o-z)
6732       include 'DIMENSIONS'
6733       include 'COMMON.GEO'
6734       include 'COMMON.LOCAL'
6735       include 'COMMON.VAR'
6736       include 'COMMON.SCROT'
6737       include 'COMMON.INTERACT'
6738       include 'COMMON.DERIV'
6739       include 'COMMON.CHAIN'
6740       include 'COMMON.IOUNITS'
6741       include 'COMMON.NAMES'
6742       include 'COMMON.FFIELD'
6743       include 'COMMON.CONTROL'
6744       include 'COMMON.VECTORS'
6745       double precision x_prime(3),y_prime(3),z_prime(3)
6746      &    , sumene,dsc_i,dp2_i,x(65),
6747      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6748      &    de_dxx,de_dyy,de_dzz,de_dt
6749       double precision s1_t,s1_6_t,s2_t,s2_6_t
6750       double precision
6751      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6752      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6753      & dt_dCi(3),dt_dCi1(3)
6754       common /sccalc/ time11,time12,time112,theti,it,nlobit
6755       delta=0.02d0*pi
6756       escloc=0.0D0
6757       do i=loc_start,loc_end
6758         if (itype(i).eq.ntyp1) cycle
6759         costtab(i+1) =dcos(theta(i+1))
6760         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6761         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6762         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6763         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6764         cosfac=dsqrt(cosfac2)
6765         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6766         sinfac=dsqrt(sinfac2)
6767         it=iabs(itype(i))
6768         if (it.eq.10) goto 1
6769 c
6770 C  Compute the axes of tghe local cartesian coordinates system; store in
6771 c   x_prime, y_prime and z_prime
6772 c
6773         do j=1,3
6774           x_prime(j) = 0.00
6775           y_prime(j) = 0.00
6776           z_prime(j) = 0.00
6777         enddo
6778 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6779 C     &   dc_norm(3,i+nres)
6780         do j = 1,3
6781           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6782           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6783         enddo
6784         do j = 1,3
6785           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6786         enddo
6787 c       write (2,*) "i",i
6788 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6789 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6790 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6791 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6792 c      & " xy",scalar(x_prime(1),y_prime(1)),
6793 c      & " xz",scalar(x_prime(1),z_prime(1)),
6794 c      & " yy",scalar(y_prime(1),y_prime(1)),
6795 c      & " yz",scalar(y_prime(1),z_prime(1)),
6796 c      & " zz",scalar(z_prime(1),z_prime(1))
6797 c
6798 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6799 C to local coordinate system. Store in xx, yy, zz.
6800 c
6801         xx=0.0d0
6802         yy=0.0d0
6803         zz=0.0d0
6804         do j = 1,3
6805           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6806           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6807           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6808         enddo
6809
6810         xxtab(i)=xx
6811         yytab(i)=yy
6812         zztab(i)=zz
6813 C
6814 C Compute the energy of the ith side cbain
6815 C
6816 c        write (2,*) "xx",xx," yy",yy," zz",zz
6817         it=iabs(itype(i))
6818         do j = 1,65
6819           x(j) = sc_parmin(j,it)
6820         enddo
6821 #ifdef CHECK_COORD
6822 Cc diagnostics - remove later
6823         xx1 = dcos(alph(2))
6824         yy1 = dsin(alph(2))*dcos(omeg(2))
6825         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6826         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6827      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6828      &    xx1,yy1,zz1
6829 C,"  --- ", xx_w,yy_w,zz_w
6830 c end diagnostics
6831 #endif
6832         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6833      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6834      &   + x(10)*yy*zz
6835         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6836      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6837      & + x(20)*yy*zz
6838         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6839      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6840      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6841      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6842      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6843      &  +x(40)*xx*yy*zz
6844         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6845      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6846      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6847      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6848      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6849      &  +x(60)*xx*yy*zz
6850         dsc_i   = 0.743d0+x(61)
6851         dp2_i   = 1.9d0+x(62)
6852         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6853      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6854         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6855      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6856         s1=(1+x(63))/(0.1d0 + dscp1)
6857         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6858         s2=(1+x(65))/(0.1d0 + dscp2)
6859         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6860         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6861      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6862 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6863 c     &   sumene4,
6864 c     &   dscp1,dscp2,sumene
6865 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6866         escloc = escloc + sumene
6867 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6868 c     & ,zz,xx,yy
6869 c#define DEBUG
6870 #ifdef DEBUG
6871 C
6872 C This section to check the numerical derivatives of the energy of ith side
6873 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6874 C #define DEBUG in the code to turn it on.
6875 C
6876         write (2,*) "sumene               =",sumene
6877         aincr=1.0d-7
6878         xxsave=xx
6879         xx=xx+aincr
6880         write (2,*) xx,yy,zz
6881         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6882         de_dxx_num=(sumenep-sumene)/aincr
6883         xx=xxsave
6884         write (2,*) "xx+ sumene from enesc=",sumenep
6885         yysave=yy
6886         yy=yy+aincr
6887         write (2,*) xx,yy,zz
6888         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6889         de_dyy_num=(sumenep-sumene)/aincr
6890         yy=yysave
6891         write (2,*) "yy+ sumene from enesc=",sumenep
6892         zzsave=zz
6893         zz=zz+aincr
6894         write (2,*) xx,yy,zz
6895         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6896         de_dzz_num=(sumenep-sumene)/aincr
6897         zz=zzsave
6898         write (2,*) "zz+ sumene from enesc=",sumenep
6899         costsave=cost2tab(i+1)
6900         sintsave=sint2tab(i+1)
6901         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6902         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6903         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6904         de_dt_num=(sumenep-sumene)/aincr
6905         write (2,*) " t+ sumene from enesc=",sumenep
6906         cost2tab(i+1)=costsave
6907         sint2tab(i+1)=sintsave
6908 C End of diagnostics section.
6909 #endif
6910 C
6911 C Compute the gradient of esc
6912 C
6913 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6914         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6915         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6916         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6917         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6918         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6919         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6920         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6921         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6922         pom1=(sumene3*sint2tab(i+1)+sumene1)
6923      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6924         pom2=(sumene4*cost2tab(i+1)+sumene2)
6925      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6926         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6927         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6928      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6929      &  +x(40)*yy*zz
6930         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6931         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6932      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6933      &  +x(60)*yy*zz
6934         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6935      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6936      &        +(pom1+pom2)*pom_dx
6937 #ifdef DEBUG
6938         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6939 #endif
6940 C
6941         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6942         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6943      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6944      &  +x(40)*xx*zz
6945         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6946         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6947      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6948      &  +x(59)*zz**2 +x(60)*xx*zz
6949         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6950      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6951      &        +(pom1-pom2)*pom_dy
6952 #ifdef DEBUG
6953         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6954 #endif
6955 C
6956         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6957      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6958      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6959      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6960      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6961      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6962      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6963      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6964 #ifdef DEBUG
6965         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6966 #endif
6967 C
6968         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6969      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6970      &  +pom1*pom_dt1+pom2*pom_dt2
6971 #ifdef DEBUG
6972         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6973 #endif
6974 c#undef DEBUG
6975 c
6976 C
6977        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6978        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6979        cosfac2xx=cosfac2*xx
6980        sinfac2yy=sinfac2*yy
6981        do k = 1,3
6982          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6983      &      vbld_inv(i+1)
6984          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6985      &      vbld_inv(i)
6986          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6987          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6988 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6989 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6990 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6991 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6992          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6993          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6994          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6995          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6996          dZZ_Ci1(k)=0.0d0
6997          dZZ_Ci(k)=0.0d0
6998          do j=1,3
6999            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7000      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7001            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7002      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7003          enddo
7004
7005          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7006          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7007          dZZ_XYZ(k)=vbld_inv(i+nres)*
7008      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7009 c
7010          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7011          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7012        enddo
7013
7014        do k=1,3
7015          dXX_Ctab(k,i)=dXX_Ci(k)
7016          dXX_C1tab(k,i)=dXX_Ci1(k)
7017          dYY_Ctab(k,i)=dYY_Ci(k)
7018          dYY_C1tab(k,i)=dYY_Ci1(k)
7019          dZZ_Ctab(k,i)=dZZ_Ci(k)
7020          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7021          dXX_XYZtab(k,i)=dXX_XYZ(k)
7022          dYY_XYZtab(k,i)=dYY_XYZ(k)
7023          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7024        enddo
7025
7026        do k = 1,3
7027 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7028 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7029 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7030 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7031 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7032 c     &    dt_dci(k)
7033 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7034 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7035          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7036      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7037          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7038      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7039          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7040      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7041        enddo
7042 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7043 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7044
7045 C to check gradient call subroutine check_grad
7046
7047     1 continue
7048       enddo
7049       return
7050       end
7051 c------------------------------------------------------------------------------
7052       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7053       implicit none
7054       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7055      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7056       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7057      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7058      &   + x(10)*yy*zz
7059       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7060      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7061      & + x(20)*yy*zz
7062       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7063      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7064      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7065      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7066      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7067      &  +x(40)*xx*yy*zz
7068       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7069      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7070      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7071      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7072      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7073      &  +x(60)*xx*yy*zz
7074       dsc_i   = 0.743d0+x(61)
7075       dp2_i   = 1.9d0+x(62)
7076       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7077      &          *(xx*cost2+yy*sint2))
7078       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7079      &          *(xx*cost2-yy*sint2))
7080       s1=(1+x(63))/(0.1d0 + dscp1)
7081       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7082       s2=(1+x(65))/(0.1d0 + dscp2)
7083       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7084       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7085      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7086       enesc=sumene
7087       return
7088       end
7089 #endif
7090 c------------------------------------------------------------------------------
7091       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7092 C
7093 C This procedure calculates two-body contact function g(rij) and its derivative:
7094 C
7095 C           eps0ij                                     !       x < -1
7096 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7097 C            0                                         !       x > 1
7098 C
7099 C where x=(rij-r0ij)/delta
7100 C
7101 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7102 C
7103       implicit none
7104       double precision rij,r0ij,eps0ij,fcont,fprimcont
7105       double precision x,x2,x4,delta
7106 c     delta=0.02D0*r0ij
7107 c      delta=0.2D0*r0ij
7108       x=(rij-r0ij)/delta
7109       if (x.lt.-1.0D0) then
7110         fcont=eps0ij
7111         fprimcont=0.0D0
7112       else if (x.le.1.0D0) then
7113         x2=x*x
7114         x4=x2*x2
7115         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7116         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7117       else
7118         fcont=0.0D0
7119         fprimcont=0.0D0
7120       endif
7121       return
7122       end
7123 c------------------------------------------------------------------------------
7124       subroutine splinthet(theti,delta,ss,ssder)
7125       implicit real*8 (a-h,o-z)
7126       include 'DIMENSIONS'
7127       include 'COMMON.VAR'
7128       include 'COMMON.GEO'
7129       thetup=pi-delta
7130       thetlow=delta
7131       if (theti.gt.pipol) then
7132         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7133       else
7134         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7135         ssder=-ssder
7136       endif
7137       return
7138       end
7139 c------------------------------------------------------------------------------
7140       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7141       implicit none
7142       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7143       double precision ksi,ksi2,ksi3,a1,a2,a3
7144       a1=fprim0*delta/(f1-f0)
7145       a2=3.0d0-2.0d0*a1
7146       a3=a1-2.0d0
7147       ksi=(x-x0)/delta
7148       ksi2=ksi*ksi
7149       ksi3=ksi2*ksi
7150       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7151       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7152       return
7153       end
7154 c------------------------------------------------------------------------------
7155       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7156       implicit none
7157       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7158       double precision ksi,ksi2,ksi3,a1,a2,a3
7159       ksi=(x-x0)/delta
7160       ksi2=ksi*ksi
7161       ksi3=ksi2*ksi
7162       a1=fprim0x*delta
7163       a2=3*(f1x-f0x)-2*fprim0x*delta
7164       a3=fprim0x*delta-2*(f1x-f0x)
7165       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7166       return
7167       end
7168 C-----------------------------------------------------------------------------
7169 #ifdef CRYST_TOR
7170 C-----------------------------------------------------------------------------
7171       subroutine etor(etors,edihcnstr)
7172       implicit real*8 (a-h,o-z)
7173       include 'DIMENSIONS'
7174       include 'COMMON.VAR'
7175       include 'COMMON.GEO'
7176       include 'COMMON.LOCAL'
7177       include 'COMMON.TORSION'
7178       include 'COMMON.INTERACT'
7179       include 'COMMON.DERIV'
7180       include 'COMMON.CHAIN'
7181       include 'COMMON.NAMES'
7182       include 'COMMON.IOUNITS'
7183       include 'COMMON.FFIELD'
7184       include 'COMMON.TORCNSTR'
7185       include 'COMMON.CONTROL'
7186       logical lprn
7187 C Set lprn=.true. for debugging
7188       lprn=.false.
7189 c      lprn=.true.
7190       etors=0.0D0
7191       do i=iphi_start,iphi_end
7192       etors_ii=0.0D0
7193         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7194      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7195         itori=itortyp(itype(i-2))
7196         itori1=itortyp(itype(i-1))
7197         phii=phi(i)
7198         gloci=0.0D0
7199 C Proline-Proline pair is a special case...
7200         if (itori.eq.3 .and. itori1.eq.3) then
7201           if (phii.gt.-dwapi3) then
7202             cosphi=dcos(3*phii)
7203             fac=1.0D0/(1.0D0-cosphi)
7204             etorsi=v1(1,3,3)*fac
7205             etorsi=etorsi+etorsi
7206             etors=etors+etorsi-v1(1,3,3)
7207             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7208             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7209           endif
7210           do j=1,3
7211             v1ij=v1(j+1,itori,itori1)
7212             v2ij=v2(j+1,itori,itori1)
7213             cosphi=dcos(j*phii)
7214             sinphi=dsin(j*phii)
7215             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7216             if (energy_dec) etors_ii=etors_ii+
7217      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7218             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7219           enddo
7220         else
7221           do j=1,nterm_old
7222             v1ij=v1(j,itori,itori1)
7223             v2ij=v2(j,itori,itori1)
7224             cosphi=dcos(j*phii)
7225             sinphi=dsin(j*phii)
7226             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7227             if (energy_dec) etors_ii=etors_ii+
7228      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7229             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7230           enddo
7231         endif
7232         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7233              'etor',i,etors_ii
7234         if (lprn)
7235      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7236      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7237      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7238         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7239 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7240       enddo
7241 ! 6/20/98 - dihedral angle constraints
7242       edihcnstr=0.0d0
7243       do i=1,ndih_constr
7244         itori=idih_constr(i)
7245         phii=phi(itori)
7246         difi=phii-phi0(i)
7247         if (difi.gt.drange(i)) then
7248           difi=difi-drange(i)
7249           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7250           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7251         else if (difi.lt.-drange(i)) then
7252           difi=difi+drange(i)
7253           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7254           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7255         endif
7256 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7257 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7258       enddo
7259 !      write (iout,*) 'edihcnstr',edihcnstr
7260       return
7261       end
7262 c------------------------------------------------------------------------------
7263       subroutine etor_d(etors_d)
7264       etors_d=0.0d0
7265       return
7266       end
7267 c----------------------------------------------------------------------------
7268 #else
7269       subroutine etor(etors,edihcnstr)
7270       implicit real*8 (a-h,o-z)
7271       include 'DIMENSIONS'
7272       include 'COMMON.VAR'
7273       include 'COMMON.GEO'
7274       include 'COMMON.LOCAL'
7275       include 'COMMON.TORSION'
7276       include 'COMMON.INTERACT'
7277       include 'COMMON.DERIV'
7278       include 'COMMON.CHAIN'
7279       include 'COMMON.NAMES'
7280       include 'COMMON.IOUNITS'
7281       include 'COMMON.FFIELD'
7282       include 'COMMON.TORCNSTR'
7283       include 'COMMON.CONTROL'
7284       logical lprn
7285 C Set lprn=.true. for debugging
7286       lprn=.false.
7287 c     lprn=.true.
7288       etors=0.0D0
7289       do i=iphi_start,iphi_end
7290 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7291 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7292 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7293 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7294         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7295      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7296 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7297 C For introducing the NH3+ and COO- group please check the etor_d for reference
7298 C and guidance
7299         etors_ii=0.0D0
7300          if (iabs(itype(i)).eq.20) then
7301          iblock=2
7302          else
7303          iblock=1
7304          endif
7305         itori=itortyp(itype(i-2))
7306         itori1=itortyp(itype(i-1))
7307         phii=phi(i)
7308         gloci=0.0D0
7309 C Regular cosine and sine terms
7310         do j=1,nterm(itori,itori1,iblock)
7311           v1ij=v1(j,itori,itori1,iblock)
7312           v2ij=v2(j,itori,itori1,iblock)
7313           cosphi=dcos(j*phii)
7314           sinphi=dsin(j*phii)
7315           etors=etors+v1ij*cosphi+v2ij*sinphi
7316           if (energy_dec) etors_ii=etors_ii+
7317      &                v1ij*cosphi+v2ij*sinphi
7318           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7319         enddo
7320 C Lorentz terms
7321 C                         v1
7322 C  E = SUM ----------------------------------- - v1
7323 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7324 C
7325         cosphi=dcos(0.5d0*phii)
7326         sinphi=dsin(0.5d0*phii)
7327         do j=1,nlor(itori,itori1,iblock)
7328           vl1ij=vlor1(j,itori,itori1)
7329           vl2ij=vlor2(j,itori,itori1)
7330           vl3ij=vlor3(j,itori,itori1)
7331           pom=vl2ij*cosphi+vl3ij*sinphi
7332           pom1=1.0d0/(pom*pom+1.0d0)
7333           etors=etors+vl1ij*pom1
7334           if (energy_dec) etors_ii=etors_ii+
7335      &                vl1ij*pom1
7336           pom=-pom*pom1*pom1
7337           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7338         enddo
7339 C Subtract the constant term
7340         etors=etors-v0(itori,itori1,iblock)
7341           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7342      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7343         if (lprn)
7344      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7345      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7346      &  (v1(j,itori,itori1,iblock),j=1,6),
7347      &  (v2(j,itori,itori1,iblock),j=1,6)
7348         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7349 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7350       enddo
7351 ! 6/20/98 - dihedral angle constraints
7352       edihcnstr=0.0d0
7353 c      do i=1,ndih_constr
7354       do i=idihconstr_start,idihconstr_end
7355         itori=idih_constr(i)
7356         phii=phi(itori)
7357         difi=pinorm(phii-phi0(i))
7358         if (difi.gt.drange(i)) then
7359           difi=difi-drange(i)
7360           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7361           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7362         else if (difi.lt.-drange(i)) then
7363           difi=difi+drange(i)
7364           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7365           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7366         else
7367           difi=0.0
7368         endif
7369        if (energy_dec) then
7370         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7371      &    i,itori,rad2deg*phii,
7372      &    rad2deg*phi0(i),  rad2deg*drange(i),
7373      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7374         endif
7375       enddo
7376 cd       write (iout,*) 'edihcnstr',edihcnstr
7377       return
7378       end
7379 c----------------------------------------------------------------------------
7380       subroutine etor_d(etors_d)
7381 C 6/23/01 Compute double torsional energy
7382       implicit real*8 (a-h,o-z)
7383       include 'DIMENSIONS'
7384       include 'COMMON.VAR'
7385       include 'COMMON.GEO'
7386       include 'COMMON.LOCAL'
7387       include 'COMMON.TORSION'
7388       include 'COMMON.INTERACT'
7389       include 'COMMON.DERIV'
7390       include 'COMMON.CHAIN'
7391       include 'COMMON.NAMES'
7392       include 'COMMON.IOUNITS'
7393       include 'COMMON.FFIELD'
7394       include 'COMMON.TORCNSTR'
7395       logical lprn
7396 C Set lprn=.true. for debugging
7397       lprn=.false.
7398 c     lprn=.true.
7399       etors_d=0.0D0
7400 c      write(iout,*) "a tu??"
7401       do i=iphid_start,iphid_end
7402 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7403 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7404 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7405 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7406 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7407          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7408      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7409      &  (itype(i+1).eq.ntyp1)) cycle
7410 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7411         itori=itortyp(itype(i-2))
7412         itori1=itortyp(itype(i-1))
7413         itori2=itortyp(itype(i))
7414         phii=phi(i)
7415         phii1=phi(i+1)
7416         gloci1=0.0D0
7417         gloci2=0.0D0
7418         iblock=1
7419         if (iabs(itype(i+1)).eq.20) iblock=2
7420 C Iblock=2 Proline type
7421 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7422 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7423 C        if (itype(i+1).eq.ntyp1) iblock=3
7424 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7425 C IS or IS NOT need for this
7426 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7427 C        is (itype(i-3).eq.ntyp1) ntblock=2
7428 C        ntblock is N-terminal blocking group
7429
7430 C Regular cosine and sine terms
7431         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7432 C Example of changes for NH3+ blocking group
7433 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7434 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7435           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7436           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7437           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7438           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7439           cosphi1=dcos(j*phii)
7440           sinphi1=dsin(j*phii)
7441           cosphi2=dcos(j*phii1)
7442           sinphi2=dsin(j*phii1)
7443           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7444      &     v2cij*cosphi2+v2sij*sinphi2
7445           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7446           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7447         enddo
7448         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7449           do l=1,k-1
7450             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7451             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7452             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7453             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7454             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7455             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7456             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7457             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7458             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7459      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7460             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7461      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7462             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7463      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7464           enddo
7465         enddo
7466         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7467         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7468       enddo
7469       return
7470       end
7471 #endif
7472 C----------------------------------------------------------------------------------
7473 C The rigorous attempt to derive energy function
7474       subroutine etor_kcc(etors,edihcnstr)
7475       implicit real*8 (a-h,o-z)
7476       include 'DIMENSIONS'
7477       include 'COMMON.VAR'
7478       include 'COMMON.GEO'
7479       include 'COMMON.LOCAL'
7480       include 'COMMON.TORSION'
7481       include 'COMMON.INTERACT'
7482       include 'COMMON.DERIV'
7483       include 'COMMON.CHAIN'
7484       include 'COMMON.NAMES'
7485       include 'COMMON.IOUNITS'
7486       include 'COMMON.FFIELD'
7487       include 'COMMON.TORCNSTR'
7488       include 'COMMON.CONTROL'
7489       logical lprn
7490 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7491 C Set lprn=.true. for debugging
7492       lprn=.false.
7493 c     lprn=.true.
7494 C      print *,"wchodze kcc"
7495       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7496       if (tor_mode.ne.2) then
7497       etors=0.0D0
7498       endif
7499       do i=iphi_start,iphi_end
7500 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7501 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7502 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7503 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7504         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7505      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7506         itori=itortyp_kcc(itype(i-2))
7507         itori1=itortyp_kcc(itype(i-1))
7508         phii=phi(i)
7509         glocig=0.0D0
7510         glocit1=0.0d0
7511         glocit2=0.0d0
7512         sumnonchebyshev=0.0d0
7513         sumchebyshev=0.0d0
7514 C to avoid multiple devision by 2
7515 c        theti22=0.5d0*theta(i)
7516 C theta 12 is the theta_1 /2
7517 C theta 22 is theta_2 /2
7518 c        theti12=0.5d0*theta(i-1)
7519 C and appropriate sinus function
7520         sinthet1=dsin(theta(i-1))
7521         sinthet2=dsin(theta(i))
7522         costhet1=dcos(theta(i-1))
7523         costhet2=dcos(theta(i))
7524 c Cosines of halves thetas
7525         costheti12=0.5d0*(1.0d0+costhet1)
7526         costheti22=0.5d0*(1.0d0+costhet2)
7527 C to speed up lets store its mutliplication
7528         sint1t2=sinthet2*sinthet1
7529         sint1t2n=1.0d0
7530 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7531 C +d_n*sin(n*gamma)) *
7532 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7533 C we have two sum 1) Non-Chebyshev which is with n and gamma
7534         etori=0.0d0
7535         do j=1,nterm_kcc(itori,itori1)
7536
7537           nval=nterm_kcc_Tb(itori,itori1)
7538           v1ij=v1_kcc(j,itori,itori1)
7539           v2ij=v2_kcc(j,itori,itori1)
7540 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7541 C v1ij is c_n and d_n in euation above
7542           cosphi=dcos(j*phii)
7543           sinphi=dsin(j*phii)
7544           sint1t2n1=sint1t2n
7545           sint1t2n=sint1t2n*sint1t2
7546           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7547      &        costheti12)
7548           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7549      &        v11_chyb(1,j,itori,itori1),costheti12)
7550 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7551 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7552           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7553      &        costheti22)
7554           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7555      &        v21_chyb(1,j,itori,itori1),costheti22)
7556 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7557 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7558           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7559      &        costheti12)
7560           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7561      &        v12_chyb(1,j,itori,itori1),costheti12)
7562 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7563 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7564           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7565      &        costheti22)
7566           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7567      &        v22_chyb(1,j,itori,itori1),costheti22)
7568 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7569 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7570 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7571 C          if (energy_dec) etors_ii=etors_ii+
7572 C     &                v1ij*cosphi+v2ij*sinphi
7573 C glocig is the gradient local i site in gamma
7574           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7575           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7576           etori=etori+sint1t2n*(actval1+actval2)
7577           glocig=glocig+
7578      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7579      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7580 C now gradient over theta_1
7581           glocit1=glocit1+
7582      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7583      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7584           glocit2=glocit2+
7585      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7586      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7587
7588 C now the Czebyshev polinominal sum
7589 c        do k=1,nterm_kcc_Tb(itori,itori1)
7590 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7591 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7592 C         thybt1(k)=0.0
7593 C         thybt2(k)=0.0
7594 c        enddo
7595 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7596 C     &         gradtschebyshev
7597 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7598 C     &         dcos(theti22)**2),
7599 C     &         dsin(theti22)
7600
7601 C now overal sumation
7602 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7603         enddo ! j
7604         etors=etors+etori
7605 C derivative over gamma
7606         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7607 C derivative over theta1
7608         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7609 C now derivative over theta2
7610         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7611         if (lprn)
7612      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7613      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7614       enddo
7615 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7616 ! 6/20/98 - dihedral angle constraints
7617       if (tor_mode.ne.2) then
7618       edihcnstr=0.0d0
7619 c      do i=1,ndih_constr
7620       do i=idihconstr_start,idihconstr_end
7621         itori=idih_constr(i)
7622         phii=phi(itori)
7623         difi=pinorm(phii-phi0(i))
7624         if (difi.gt.drange(i)) then
7625           difi=difi-drange(i)
7626           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7627           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7628         else if (difi.lt.-drange(i)) then
7629           difi=difi+drange(i)
7630           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7631           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7632         else
7633           difi=0.0
7634         endif
7635        enddo
7636        endif
7637       return
7638       end
7639
7640 C The rigorous attempt to derive energy function
7641       subroutine ebend_kcc(etheta,ethetacnstr)
7642
7643       implicit real*8 (a-h,o-z)
7644       include 'DIMENSIONS'
7645       include 'COMMON.VAR'
7646       include 'COMMON.GEO'
7647       include 'COMMON.LOCAL'
7648       include 'COMMON.TORSION'
7649       include 'COMMON.INTERACT'
7650       include 'COMMON.DERIV'
7651       include 'COMMON.CHAIN'
7652       include 'COMMON.NAMES'
7653       include 'COMMON.IOUNITS'
7654       include 'COMMON.FFIELD'
7655       include 'COMMON.TORCNSTR'
7656       include 'COMMON.CONTROL'
7657       logical lprn
7658       double precision thybt1(maxtermkcc)
7659 C Set lprn=.true. for debugging
7660       lprn=.false.
7661 c     lprn=.true.
7662 C      print *,"wchodze kcc"
7663       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7664       if (tor_mode.ne.2) etheta=0.0D0
7665       do i=ithet_start,ithet_end
7666 c        print *,i,itype(i-1),itype(i),itype(i-2)
7667         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7668      &  .or.itype(i).eq.ntyp1) cycle
7669          iti=itortyp_kcc(itype(i-1))
7670         sinthet=dsin(theta(i)/2.0d0)
7671         costhet=dcos(theta(i)/2.0d0)
7672          do j=1,nbend_kcc_Tb(iti)
7673           thybt1(j)=v1bend_chyb(j,iti)
7674          enddo
7675          sumth1thyb=tschebyshev
7676      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7677         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7678      &    sumth1thyb
7679         ihelp=nbend_kcc_Tb(iti)-1
7680         gradthybt1=gradtschebyshev
7681      &         (0,ihelp,thybt1(1),costhet)
7682         etheta=etheta+sumth1thyb
7683 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7684         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7685      &   gradthybt1*sinthet*(-0.5d0)
7686       enddo
7687       if (tor_mode.ne.2) then
7688       ethetacnstr=0.0d0
7689 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7690       do i=ithetaconstr_start,ithetaconstr_end
7691         itheta=itheta_constr(i)
7692         thetiii=theta(itheta)
7693         difi=pinorm(thetiii-theta_constr0(i))
7694         if (difi.gt.theta_drange(i)) then
7695           difi=difi-theta_drange(i)
7696           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7697           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7698      &    +for_thet_constr(i)*difi**3
7699         else if (difi.lt.-drange(i)) then
7700           difi=difi+drange(i)
7701           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7702           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7703      &    +for_thet_constr(i)*difi**3
7704         else
7705           difi=0.0
7706         endif
7707        if (energy_dec) then
7708         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7709      &    i,itheta,rad2deg*thetiii,
7710      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7711      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7712      &    gloc(itheta+nphi-2,icg)
7713         endif
7714       enddo
7715       endif
7716       return
7717       end
7718 c------------------------------------------------------------------------------
7719       subroutine eback_sc_corr(esccor)
7720 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7721 c        conformational states; temporarily implemented as differences
7722 c        between UNRES torsional potentials (dependent on three types of
7723 c        residues) and the torsional potentials dependent on all 20 types
7724 c        of residues computed from AM1  energy surfaces of terminally-blocked
7725 c        amino-acid residues.
7726       implicit real*8 (a-h,o-z)
7727       include 'DIMENSIONS'
7728       include 'COMMON.VAR'
7729       include 'COMMON.GEO'
7730       include 'COMMON.LOCAL'
7731       include 'COMMON.TORSION'
7732       include 'COMMON.SCCOR'
7733       include 'COMMON.INTERACT'
7734       include 'COMMON.DERIV'
7735       include 'COMMON.CHAIN'
7736       include 'COMMON.NAMES'
7737       include 'COMMON.IOUNITS'
7738       include 'COMMON.FFIELD'
7739       include 'COMMON.CONTROL'
7740       logical lprn
7741 C Set lprn=.true. for debugging
7742       lprn=.false.
7743 c      lprn=.true.
7744 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7745       esccor=0.0D0
7746       do i=itau_start,itau_end
7747         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7748         esccor_ii=0.0D0
7749         isccori=isccortyp(itype(i-2))
7750         isccori1=isccortyp(itype(i-1))
7751 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7752         phii=phi(i)
7753         do intertyp=1,3 !intertyp
7754 cc Added 09 May 2012 (Adasko)
7755 cc  Intertyp means interaction type of backbone mainchain correlation:
7756 c   1 = SC...Ca...Ca...Ca
7757 c   2 = Ca...Ca...Ca...SC
7758 c   3 = SC...Ca...Ca...SCi
7759         gloci=0.0D0
7760         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7761      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7762      &      (itype(i-1).eq.ntyp1)))
7763      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7764      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7765      &     .or.(itype(i).eq.ntyp1)))
7766      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7767      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7768      &      (itype(i-3).eq.ntyp1)))) cycle
7769         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7770         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7771      & cycle
7772        do j=1,nterm_sccor(isccori,isccori1)
7773           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7774           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7775           cosphi=dcos(j*tauangle(intertyp,i))
7776           sinphi=dsin(j*tauangle(intertyp,i))
7777           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7778           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7779         enddo
7780 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7781         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7782         if (lprn)
7783      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7784      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7785      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7786      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7787         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7788        enddo !intertyp
7789       enddo
7790
7791       return
7792       end
7793 c----------------------------------------------------------------------------
7794       subroutine multibody(ecorr)
7795 C This subroutine calculates multi-body contributions to energy following
7796 C the idea of Skolnick et al. If side chains I and J make a contact and
7797 C at the same time side chains I+1 and J+1 make a contact, an extra
7798 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7799       implicit real*8 (a-h,o-z)
7800       include 'DIMENSIONS'
7801       include 'COMMON.IOUNITS'
7802       include 'COMMON.DERIV'
7803       include 'COMMON.INTERACT'
7804       include 'COMMON.CONTACTS'
7805       double precision gx(3),gx1(3)
7806       logical lprn
7807
7808 C Set lprn=.true. for debugging
7809       lprn=.false.
7810
7811       if (lprn) then
7812         write (iout,'(a)') 'Contact function values:'
7813         do i=nnt,nct-2
7814           write (iout,'(i2,20(1x,i2,f10.5))')
7815      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7816         enddo
7817       endif
7818       ecorr=0.0D0
7819       do i=nnt,nct
7820         do j=1,3
7821           gradcorr(j,i)=0.0D0
7822           gradxorr(j,i)=0.0D0
7823         enddo
7824       enddo
7825       do i=nnt,nct-2
7826
7827         DO ISHIFT = 3,4
7828
7829         i1=i+ishift
7830         num_conti=num_cont(i)
7831         num_conti1=num_cont(i1)
7832         do jj=1,num_conti
7833           j=jcont(jj,i)
7834           do kk=1,num_conti1
7835             j1=jcont(kk,i1)
7836             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7837 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7838 cd   &                   ' ishift=',ishift
7839 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7840 C The system gains extra energy.
7841               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7842             endif   ! j1==j+-ishift
7843           enddo     ! kk
7844         enddo       ! jj
7845
7846         ENDDO ! ISHIFT
7847
7848       enddo         ! i
7849       return
7850       end
7851 c------------------------------------------------------------------------------
7852       double precision function esccorr(i,j,k,l,jj,kk)
7853       implicit real*8 (a-h,o-z)
7854       include 'DIMENSIONS'
7855       include 'COMMON.IOUNITS'
7856       include 'COMMON.DERIV'
7857       include 'COMMON.INTERACT'
7858       include 'COMMON.CONTACTS'
7859       include 'COMMON.SHIELD'
7860       double precision gx(3),gx1(3)
7861       logical lprn
7862       lprn=.false.
7863       eij=facont(jj,i)
7864       ekl=facont(kk,k)
7865 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7866 C Calculate the multi-body contribution to energy.
7867 C Calculate multi-body contributions to the gradient.
7868 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7869 cd   & k,l,(gacont(m,kk,k),m=1,3)
7870       do m=1,3
7871         gx(m) =ekl*gacont(m,jj,i)
7872         gx1(m)=eij*gacont(m,kk,k)
7873         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7874         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7875         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7876         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7877       enddo
7878       do m=i,j-1
7879         do ll=1,3
7880           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7881         enddo
7882       enddo
7883       do m=k,l-1
7884         do ll=1,3
7885           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7886         enddo
7887       enddo
7888       esccorr=-eij*ekl
7889       return
7890       end
7891 c------------------------------------------------------------------------------
7892       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7893 C This subroutine calculates multi-body contributions to hydrogen-bonding
7894       implicit real*8 (a-h,o-z)
7895       include 'DIMENSIONS'
7896       include 'COMMON.IOUNITS'
7897 #ifdef MPI
7898       include "mpif.h"
7899       parameter (max_cont=maxconts)
7900       parameter (max_dim=26)
7901       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7902       double precision zapas(max_dim,maxconts,max_fg_procs),
7903      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7904       common /przechowalnia/ zapas
7905       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7906      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7907 #endif
7908       include 'COMMON.SETUP'
7909       include 'COMMON.FFIELD'
7910       include 'COMMON.DERIV'
7911       include 'COMMON.INTERACT'
7912       include 'COMMON.CONTACTS'
7913       include 'COMMON.CONTROL'
7914       include 'COMMON.LOCAL'
7915       double precision gx(3),gx1(3),time00
7916       logical lprn,ldone
7917
7918 C Set lprn=.true. for debugging
7919       lprn=.false.
7920 #ifdef MPI
7921       n_corr=0
7922       n_corr1=0
7923       if (nfgtasks.le.1) goto 30
7924       if (lprn) then
7925         write (iout,'(a)') 'Contact function values before RECEIVE:'
7926         do i=nnt,nct-2
7927           write (iout,'(2i3,50(1x,i2,f5.2))')
7928      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7929      &    j=1,num_cont_hb(i))
7930         enddo
7931       endif
7932       call flush(iout)
7933       do i=1,ntask_cont_from
7934         ncont_recv(i)=0
7935       enddo
7936       do i=1,ntask_cont_to
7937         ncont_sent(i)=0
7938       enddo
7939 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7940 c     & ntask_cont_to
7941 C Make the list of contacts to send to send to other procesors
7942 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7943 c      call flush(iout)
7944       do i=iturn3_start,iturn3_end
7945 c        write (iout,*) "make contact list turn3",i," num_cont",
7946 c     &    num_cont_hb(i)
7947         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7948       enddo
7949       do i=iturn4_start,iturn4_end
7950 c        write (iout,*) "make contact list turn4",i," num_cont",
7951 c     &   num_cont_hb(i)
7952         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7953       enddo
7954       do ii=1,nat_sent
7955         i=iat_sent(ii)
7956 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7957 c     &    num_cont_hb(i)
7958         do j=1,num_cont_hb(i)
7959         do k=1,4
7960           jjc=jcont_hb(j,i)
7961           iproc=iint_sent_local(k,jjc,ii)
7962 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7963           if (iproc.gt.0) then
7964             ncont_sent(iproc)=ncont_sent(iproc)+1
7965             nn=ncont_sent(iproc)
7966             zapas(1,nn,iproc)=i
7967             zapas(2,nn,iproc)=jjc
7968             zapas(3,nn,iproc)=facont_hb(j,i)
7969             zapas(4,nn,iproc)=ees0p(j,i)
7970             zapas(5,nn,iproc)=ees0m(j,i)
7971             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7972             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7973             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7974             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7975             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7976             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7977             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7978             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7979             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7980             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7981             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7982             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7983             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7984             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7985             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7986             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7987             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7988             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7989             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7990             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7991             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7992           endif
7993         enddo
7994         enddo
7995       enddo
7996       if (lprn) then
7997       write (iout,*)
7998      &  "Numbers of contacts to be sent to other processors",
7999      &  (ncont_sent(i),i=1,ntask_cont_to)
8000       write (iout,*) "Contacts sent"
8001       do ii=1,ntask_cont_to
8002         nn=ncont_sent(ii)
8003         iproc=itask_cont_to(ii)
8004         write (iout,*) nn," contacts to processor",iproc,
8005      &   " of CONT_TO_COMM group"
8006         do i=1,nn
8007           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8008         enddo
8009       enddo
8010       call flush(iout)
8011       endif
8012       CorrelType=477
8013       CorrelID=fg_rank+1
8014       CorrelType1=478
8015       CorrelID1=nfgtasks+fg_rank+1
8016       ireq=0
8017 C Receive the numbers of needed contacts from other processors
8018       do ii=1,ntask_cont_from
8019         iproc=itask_cont_from(ii)
8020         ireq=ireq+1
8021         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8022      &    FG_COMM,req(ireq),IERR)
8023       enddo
8024 c      write (iout,*) "IRECV ended"
8025 c      call flush(iout)
8026 C Send the number of contacts needed by other processors
8027       do ii=1,ntask_cont_to
8028         iproc=itask_cont_to(ii)
8029         ireq=ireq+1
8030         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8031      &    FG_COMM,req(ireq),IERR)
8032       enddo
8033 c      write (iout,*) "ISEND ended"
8034 c      write (iout,*) "number of requests (nn)",ireq
8035       call flush(iout)
8036       if (ireq.gt.0)
8037      &  call MPI_Waitall(ireq,req,status_array,ierr)
8038 c      write (iout,*)
8039 c     &  "Numbers of contacts to be received from other processors",
8040 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8041 c      call flush(iout)
8042 C Receive contacts
8043       ireq=0
8044       do ii=1,ntask_cont_from
8045         iproc=itask_cont_from(ii)
8046         nn=ncont_recv(ii)
8047 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8048 c     &   " of CONT_TO_COMM group"
8049         call flush(iout)
8050         if (nn.gt.0) then
8051           ireq=ireq+1
8052           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8053      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8054 c          write (iout,*) "ireq,req",ireq,req(ireq)
8055         endif
8056       enddo
8057 C Send the contacts to processors that need them
8058       do ii=1,ntask_cont_to
8059         iproc=itask_cont_to(ii)
8060         nn=ncont_sent(ii)
8061 c        write (iout,*) nn," contacts to processor",iproc,
8062 c     &   " of CONT_TO_COMM group"
8063         if (nn.gt.0) then
8064           ireq=ireq+1
8065           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8066      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8067 c          write (iout,*) "ireq,req",ireq,req(ireq)
8068 c          do i=1,nn
8069 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8070 c          enddo
8071         endif
8072       enddo
8073 c      write (iout,*) "number of requests (contacts)",ireq
8074 c      write (iout,*) "req",(req(i),i=1,4)
8075 c      call flush(iout)
8076       if (ireq.gt.0)
8077      & call MPI_Waitall(ireq,req,status_array,ierr)
8078       do iii=1,ntask_cont_from
8079         iproc=itask_cont_from(iii)
8080         nn=ncont_recv(iii)
8081         if (lprn) then
8082         write (iout,*) "Received",nn," contacts from processor",iproc,
8083      &   " of CONT_FROM_COMM group"
8084         call flush(iout)
8085         do i=1,nn
8086           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8087         enddo
8088         call flush(iout)
8089         endif
8090         do i=1,nn
8091           ii=zapas_recv(1,i,iii)
8092 c Flag the received contacts to prevent double-counting
8093           jj=-zapas_recv(2,i,iii)
8094 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8095 c          call flush(iout)
8096           nnn=num_cont_hb(ii)+1
8097           num_cont_hb(ii)=nnn
8098           jcont_hb(nnn,ii)=jj
8099           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8100           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8101           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8102           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8103           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8104           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8105           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8106           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8107           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8108           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8109           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8110           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8111           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8112           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8113           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8114           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8115           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8116           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8117           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8118           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8119           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8120           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8121           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8122           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8123         enddo
8124       enddo
8125       call flush(iout)
8126       if (lprn) then
8127         write (iout,'(a)') 'Contact function values after receive:'
8128         do i=nnt,nct-2
8129           write (iout,'(2i3,50(1x,i3,f5.2))')
8130      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8131      &    j=1,num_cont_hb(i))
8132         enddo
8133         call flush(iout)
8134       endif
8135    30 continue
8136 #endif
8137       if (lprn) then
8138         write (iout,'(a)') 'Contact function values:'
8139         do i=nnt,nct-2
8140           write (iout,'(2i3,50(1x,i3,f5.2))')
8141      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8142      &    j=1,num_cont_hb(i))
8143         enddo
8144       endif
8145       ecorr=0.0D0
8146 C Remove the loop below after debugging !!!
8147       do i=nnt,nct
8148         do j=1,3
8149           gradcorr(j,i)=0.0D0
8150           gradxorr(j,i)=0.0D0
8151         enddo
8152       enddo
8153 C Calculate the local-electrostatic correlation terms
8154       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8155         i1=i+1
8156         num_conti=num_cont_hb(i)
8157         num_conti1=num_cont_hb(i+1)
8158         do jj=1,num_conti
8159           j=jcont_hb(jj,i)
8160           jp=iabs(j)
8161           do kk=1,num_conti1
8162             j1=jcont_hb(kk,i1)
8163             jp1=iabs(j1)
8164 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8165 c     &         ' jj=',jj,' kk=',kk
8166             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8167      &          .or. j.lt.0 .and. j1.gt.0) .and.
8168      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8169 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8170 C The system gains extra energy.
8171               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8172               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8173      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8174               n_corr=n_corr+1
8175             else if (j1.eq.j) then
8176 C Contacts I-J and I-(J+1) occur simultaneously.
8177 C The system loses extra energy.
8178 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8179             endif
8180           enddo ! kk
8181           do kk=1,num_conti
8182             j1=jcont_hb(kk,i)
8183 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8184 c    &         ' jj=',jj,' kk=',kk
8185             if (j1.eq.j+1) then
8186 C Contacts I-J and (I+1)-J occur simultaneously.
8187 C The system loses extra energy.
8188 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8189             endif ! j1==j+1
8190           enddo ! kk
8191         enddo ! jj
8192       enddo ! i
8193       return
8194       end
8195 c------------------------------------------------------------------------------
8196       subroutine add_hb_contact(ii,jj,itask)
8197       implicit real*8 (a-h,o-z)
8198       include "DIMENSIONS"
8199       include "COMMON.IOUNITS"
8200       integer max_cont
8201       integer max_dim
8202       parameter (max_cont=maxconts)
8203       parameter (max_dim=26)
8204       include "COMMON.CONTACTS"
8205       double precision zapas(max_dim,maxconts,max_fg_procs),
8206      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8207       common /przechowalnia/ zapas
8208       integer i,j,ii,jj,iproc,itask(4),nn
8209 c      write (iout,*) "itask",itask
8210       do i=1,2
8211         iproc=itask(i)
8212         if (iproc.gt.0) then
8213           do j=1,num_cont_hb(ii)
8214             jjc=jcont_hb(j,ii)
8215 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8216             if (jjc.eq.jj) then
8217               ncont_sent(iproc)=ncont_sent(iproc)+1
8218               nn=ncont_sent(iproc)
8219               zapas(1,nn,iproc)=ii
8220               zapas(2,nn,iproc)=jjc
8221               zapas(3,nn,iproc)=facont_hb(j,ii)
8222               zapas(4,nn,iproc)=ees0p(j,ii)
8223               zapas(5,nn,iproc)=ees0m(j,ii)
8224               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8225               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8226               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8227               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8228               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8229               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8230               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8231               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8232               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8233               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8234               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8235               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8236               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8237               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8238               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8239               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8240               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8241               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8242               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8243               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8244               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8245               exit
8246             endif
8247           enddo
8248         endif
8249       enddo
8250       return
8251       end
8252 c------------------------------------------------------------------------------
8253       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8254      &  n_corr1)
8255 C This subroutine calculates multi-body contributions to hydrogen-bonding
8256       implicit real*8 (a-h,o-z)
8257       include 'DIMENSIONS'
8258       include 'COMMON.IOUNITS'
8259 #ifdef MPI
8260       include "mpif.h"
8261       parameter (max_cont=maxconts)
8262       parameter (max_dim=70)
8263       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8264       double precision zapas(max_dim,maxconts,max_fg_procs),
8265      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8266       common /przechowalnia/ zapas
8267       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8268      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8269 #endif
8270       include 'COMMON.SETUP'
8271       include 'COMMON.FFIELD'
8272       include 'COMMON.DERIV'
8273       include 'COMMON.LOCAL'
8274       include 'COMMON.INTERACT'
8275       include 'COMMON.CONTACTS'
8276       include 'COMMON.CHAIN'
8277       include 'COMMON.CONTROL'
8278       include 'COMMON.SHIELD'
8279       double precision gx(3),gx1(3)
8280       integer num_cont_hb_old(maxres)
8281       logical lprn,ldone
8282       double precision eello4,eello5,eelo6,eello_turn6
8283       external eello4,eello5,eello6,eello_turn6
8284 C Set lprn=.true. for debugging
8285       lprn=.false.
8286       eturn6=0.0d0
8287 #ifdef MPI
8288       do i=1,nres
8289         num_cont_hb_old(i)=num_cont_hb(i)
8290       enddo
8291       n_corr=0
8292       n_corr1=0
8293       if (nfgtasks.le.1) goto 30
8294       if (lprn) then
8295         write (iout,'(a)') 'Contact function values before RECEIVE:'
8296         do i=nnt,nct-2
8297           write (iout,'(2i3,50(1x,i2,f5.2))')
8298      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8299      &    j=1,num_cont_hb(i))
8300         enddo
8301       endif
8302       call flush(iout)
8303       do i=1,ntask_cont_from
8304         ncont_recv(i)=0
8305       enddo
8306       do i=1,ntask_cont_to
8307         ncont_sent(i)=0
8308       enddo
8309 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8310 c     & ntask_cont_to
8311 C Make the list of contacts to send to send to other procesors
8312       do i=iturn3_start,iturn3_end
8313 c        write (iout,*) "make contact list turn3",i," num_cont",
8314 c     &    num_cont_hb(i)
8315         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8316       enddo
8317       do i=iturn4_start,iturn4_end
8318 c        write (iout,*) "make contact list turn4",i," num_cont",
8319 c     &   num_cont_hb(i)
8320         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8321       enddo
8322       do ii=1,nat_sent
8323         i=iat_sent(ii)
8324 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8325 c     &    num_cont_hb(i)
8326         do j=1,num_cont_hb(i)
8327         do k=1,4
8328           jjc=jcont_hb(j,i)
8329           iproc=iint_sent_local(k,jjc,ii)
8330 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8331           if (iproc.ne.0) then
8332             ncont_sent(iproc)=ncont_sent(iproc)+1
8333             nn=ncont_sent(iproc)
8334             zapas(1,nn,iproc)=i
8335             zapas(2,nn,iproc)=jjc
8336             zapas(3,nn,iproc)=d_cont(j,i)
8337             ind=3
8338             do kk=1,3
8339               ind=ind+1
8340               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8341             enddo
8342             do kk=1,2
8343               do ll=1,2
8344                 ind=ind+1
8345                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8346               enddo
8347             enddo
8348             do jj=1,5
8349               do kk=1,3
8350                 do ll=1,2
8351                   do mm=1,2
8352                     ind=ind+1
8353                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8354                   enddo
8355                 enddo
8356               enddo
8357             enddo
8358           endif
8359         enddo
8360         enddo
8361       enddo
8362       if (lprn) then
8363       write (iout,*)
8364      &  "Numbers of contacts to be sent to other processors",
8365      &  (ncont_sent(i),i=1,ntask_cont_to)
8366       write (iout,*) "Contacts sent"
8367       do ii=1,ntask_cont_to
8368         nn=ncont_sent(ii)
8369         iproc=itask_cont_to(ii)
8370         write (iout,*) nn," contacts to processor",iproc,
8371      &   " of CONT_TO_COMM group"
8372         do i=1,nn
8373           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8374         enddo
8375       enddo
8376       call flush(iout)
8377       endif
8378       CorrelType=477
8379       CorrelID=fg_rank+1
8380       CorrelType1=478
8381       CorrelID1=nfgtasks+fg_rank+1
8382       ireq=0
8383 C Receive the numbers of needed contacts from other processors
8384       do ii=1,ntask_cont_from
8385         iproc=itask_cont_from(ii)
8386         ireq=ireq+1
8387         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8388      &    FG_COMM,req(ireq),IERR)
8389       enddo
8390 c      write (iout,*) "IRECV ended"
8391 c      call flush(iout)
8392 C Send the number of contacts needed by other processors
8393       do ii=1,ntask_cont_to
8394         iproc=itask_cont_to(ii)
8395         ireq=ireq+1
8396         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8397      &    FG_COMM,req(ireq),IERR)
8398       enddo
8399 c      write (iout,*) "ISEND ended"
8400 c      write (iout,*) "number of requests (nn)",ireq
8401       call flush(iout)
8402       if (ireq.gt.0)
8403      &  call MPI_Waitall(ireq,req,status_array,ierr)
8404 c      write (iout,*)
8405 c     &  "Numbers of contacts to be received from other processors",
8406 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8407 c      call flush(iout)
8408 C Receive contacts
8409       ireq=0
8410       do ii=1,ntask_cont_from
8411         iproc=itask_cont_from(ii)
8412         nn=ncont_recv(ii)
8413 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8414 c     &   " of CONT_TO_COMM group"
8415         call flush(iout)
8416         if (nn.gt.0) then
8417           ireq=ireq+1
8418           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8419      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8420 c          write (iout,*) "ireq,req",ireq,req(ireq)
8421         endif
8422       enddo
8423 C Send the contacts to processors that need them
8424       do ii=1,ntask_cont_to
8425         iproc=itask_cont_to(ii)
8426         nn=ncont_sent(ii)
8427 c        write (iout,*) nn," contacts to processor",iproc,
8428 c     &   " of CONT_TO_COMM group"
8429         if (nn.gt.0) then
8430           ireq=ireq+1
8431           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8432      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8433 c          write (iout,*) "ireq,req",ireq,req(ireq)
8434 c          do i=1,nn
8435 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8436 c          enddo
8437         endif
8438       enddo
8439 c      write (iout,*) "number of requests (contacts)",ireq
8440 c      write (iout,*) "req",(req(i),i=1,4)
8441 c      call flush(iout)
8442       if (ireq.gt.0)
8443      & call MPI_Waitall(ireq,req,status_array,ierr)
8444       do iii=1,ntask_cont_from
8445         iproc=itask_cont_from(iii)
8446         nn=ncont_recv(iii)
8447         if (lprn) then
8448         write (iout,*) "Received",nn," contacts from processor",iproc,
8449      &   " of CONT_FROM_COMM group"
8450         call flush(iout)
8451         do i=1,nn
8452           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8453         enddo
8454         call flush(iout)
8455         endif
8456         do i=1,nn
8457           ii=zapas_recv(1,i,iii)
8458 c Flag the received contacts to prevent double-counting
8459           jj=-zapas_recv(2,i,iii)
8460 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8461 c          call flush(iout)
8462           nnn=num_cont_hb(ii)+1
8463           num_cont_hb(ii)=nnn
8464           jcont_hb(nnn,ii)=jj
8465           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8466           ind=3
8467           do kk=1,3
8468             ind=ind+1
8469             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8470           enddo
8471           do kk=1,2
8472             do ll=1,2
8473               ind=ind+1
8474               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8475             enddo
8476           enddo
8477           do jj=1,5
8478             do kk=1,3
8479               do ll=1,2
8480                 do mm=1,2
8481                   ind=ind+1
8482                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8483                 enddo
8484               enddo
8485             enddo
8486           enddo
8487         enddo
8488       enddo
8489       call flush(iout)
8490       if (lprn) then
8491         write (iout,'(a)') 'Contact function values after receive:'
8492         do i=nnt,nct-2
8493           write (iout,'(2i3,50(1x,i3,5f6.3))')
8494      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8495      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8496         enddo
8497         call flush(iout)
8498       endif
8499    30 continue
8500 #endif
8501       if (lprn) then
8502         write (iout,'(a)') 'Contact function values:'
8503         do i=nnt,nct-2
8504           write (iout,'(2i3,50(1x,i2,5f6.3))')
8505      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8506      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8507         enddo
8508       endif
8509       ecorr=0.0D0
8510       ecorr5=0.0d0
8511       ecorr6=0.0d0
8512 C Remove the loop below after debugging !!!
8513       do i=nnt,nct
8514         do j=1,3
8515           gradcorr(j,i)=0.0D0
8516           gradxorr(j,i)=0.0D0
8517         enddo
8518       enddo
8519 C Calculate the dipole-dipole interaction energies
8520       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8521       do i=iatel_s,iatel_e+1
8522         num_conti=num_cont_hb(i)
8523         do jj=1,num_conti
8524           j=jcont_hb(jj,i)
8525 #ifdef MOMENT
8526           call dipole(i,j,jj)
8527 #endif
8528         enddo
8529       enddo
8530       endif
8531 C Calculate the local-electrostatic correlation terms
8532 c                write (iout,*) "gradcorr5 in eello5 before loop"
8533 c                do iii=1,nres
8534 c                  write (iout,'(i5,3f10.5)')
8535 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8536 c                enddo
8537       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8538 c        write (iout,*) "corr loop i",i
8539         i1=i+1
8540         num_conti=num_cont_hb(i)
8541         num_conti1=num_cont_hb(i+1)
8542         do jj=1,num_conti
8543           j=jcont_hb(jj,i)
8544           jp=iabs(j)
8545           do kk=1,num_conti1
8546             j1=jcont_hb(kk,i1)
8547             jp1=iabs(j1)
8548 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8549 c     &         ' jj=',jj,' kk=',kk
8550 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8551             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8552      &          .or. j.lt.0 .and. j1.gt.0) .and.
8553      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8554 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8555 C The system gains extra energy.
8556               n_corr=n_corr+1
8557               sqd1=dsqrt(d_cont(jj,i))
8558               sqd2=dsqrt(d_cont(kk,i1))
8559               sred_geom = sqd1*sqd2
8560               IF (sred_geom.lt.cutoff_corr) THEN
8561                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8562      &            ekont,fprimcont)
8563 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8564 cd     &         ' jj=',jj,' kk=',kk
8565                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8566                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8567                 do l=1,3
8568                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8569                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8570                 enddo
8571                 n_corr1=n_corr1+1
8572 cd               write (iout,*) 'sred_geom=',sred_geom,
8573 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8574 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8575 cd               write (iout,*) "g_contij",g_contij
8576 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8577 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8578                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8579                 if (wcorr4.gt.0.0d0)
8580      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8581 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8582                   if (energy_dec.and.wcorr4.gt.0.0d0)
8583      1                 write (iout,'(a6,4i5,0pf7.3)')
8584      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8585 c                write (iout,*) "gradcorr5 before eello5"
8586 c                do iii=1,nres
8587 c                  write (iout,'(i5,3f10.5)')
8588 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8589 c                enddo
8590                 if (wcorr5.gt.0.0d0)
8591      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8592 c                write (iout,*) "gradcorr5 after eello5"
8593 c                do iii=1,nres
8594 c                  write (iout,'(i5,3f10.5)')
8595 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8596 c                enddo
8597                   if (energy_dec.and.wcorr5.gt.0.0d0)
8598      1                 write (iout,'(a6,4i5,0pf7.3)')
8599      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8600 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8601 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8602                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8603      &               .or. wturn6.eq.0.0d0))then
8604 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8605                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8606                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8607      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8608 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8609 cd     &            'ecorr6=',ecorr6
8610 cd                write (iout,'(4e15.5)') sred_geom,
8611 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8612 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8613 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8614                 else if (wturn6.gt.0.0d0
8615      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8616 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8617                   eturn6=eturn6+eello_turn6(i,jj,kk)
8618                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8619      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8620 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8621                 endif
8622               ENDIF
8623 1111          continue
8624             endif
8625           enddo ! kk
8626         enddo ! jj
8627       enddo ! i
8628       do i=1,nres
8629         num_cont_hb(i)=num_cont_hb_old(i)
8630       enddo
8631 c                write (iout,*) "gradcorr5 in eello5"
8632 c                do iii=1,nres
8633 c                  write (iout,'(i5,3f10.5)')
8634 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8635 c                enddo
8636       return
8637       end
8638 c------------------------------------------------------------------------------
8639       subroutine add_hb_contact_eello(ii,jj,itask)
8640       implicit real*8 (a-h,o-z)
8641       include "DIMENSIONS"
8642       include "COMMON.IOUNITS"
8643       integer max_cont
8644       integer max_dim
8645       parameter (max_cont=maxconts)
8646       parameter (max_dim=70)
8647       include "COMMON.CONTACTS"
8648       double precision zapas(max_dim,maxconts,max_fg_procs),
8649      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8650       common /przechowalnia/ zapas
8651       integer i,j,ii,jj,iproc,itask(4),nn
8652 c      write (iout,*) "itask",itask
8653       do i=1,2
8654         iproc=itask(i)
8655         if (iproc.gt.0) then
8656           do j=1,num_cont_hb(ii)
8657             jjc=jcont_hb(j,ii)
8658 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8659             if (jjc.eq.jj) then
8660               ncont_sent(iproc)=ncont_sent(iproc)+1
8661               nn=ncont_sent(iproc)
8662               zapas(1,nn,iproc)=ii
8663               zapas(2,nn,iproc)=jjc
8664               zapas(3,nn,iproc)=d_cont(j,ii)
8665               ind=3
8666               do kk=1,3
8667                 ind=ind+1
8668                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8669               enddo
8670               do kk=1,2
8671                 do ll=1,2
8672                   ind=ind+1
8673                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8674                 enddo
8675               enddo
8676               do jj=1,5
8677                 do kk=1,3
8678                   do ll=1,2
8679                     do mm=1,2
8680                       ind=ind+1
8681                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8682                     enddo
8683                   enddo
8684                 enddo
8685               enddo
8686               exit
8687             endif
8688           enddo
8689         endif
8690       enddo
8691       return
8692       end
8693 c------------------------------------------------------------------------------
8694       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8695       implicit real*8 (a-h,o-z)
8696       include 'DIMENSIONS'
8697       include 'COMMON.IOUNITS'
8698       include 'COMMON.DERIV'
8699       include 'COMMON.INTERACT'
8700       include 'COMMON.CONTACTS'
8701       include 'COMMON.SHIELD'
8702       include 'COMMON.CONTROL'
8703       double precision gx(3),gx1(3)
8704       logical lprn
8705       lprn=.false.
8706 C      print *,"wchodze",fac_shield(i),shield_mode
8707       eij=facont_hb(jj,i)
8708       ekl=facont_hb(kk,k)
8709       ees0pij=ees0p(jj,i)
8710       ees0pkl=ees0p(kk,k)
8711       ees0mij=ees0m(jj,i)
8712       ees0mkl=ees0m(kk,k)
8713       ekont=eij*ekl
8714       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8715 C*
8716 C     & fac_shield(i)**2*fac_shield(j)**2
8717 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8718 C Following 4 lines for diagnostics.
8719 cd    ees0pkl=0.0D0
8720 cd    ees0pij=1.0D0
8721 cd    ees0mkl=0.0D0
8722 cd    ees0mij=1.0D0
8723 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8724 c     & 'Contacts ',i,j,
8725 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8726 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8727 c     & 'gradcorr_long'
8728 C Calculate the multi-body contribution to energy.
8729 C      ecorr=ecorr+ekont*ees
8730 C Calculate multi-body contributions to the gradient.
8731       coeffpees0pij=coeffp*ees0pij
8732       coeffmees0mij=coeffm*ees0mij
8733       coeffpees0pkl=coeffp*ees0pkl
8734       coeffmees0mkl=coeffm*ees0mkl
8735       do ll=1,3
8736 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8737         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8738      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8739      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8740         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8741      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8742      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8743 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8744         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8745      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8746      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8747         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8748      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8749      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8750         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8751      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8752      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8753         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8754         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8755         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8756      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8757      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8758         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8759         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8760 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8761       enddo
8762 c      write (iout,*)
8763 cgrad      do m=i+1,j-1
8764 cgrad        do ll=1,3
8765 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8766 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8767 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8768 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8769 cgrad        enddo
8770 cgrad      enddo
8771 cgrad      do m=k+1,l-1
8772 cgrad        do ll=1,3
8773 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8774 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8775 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8776 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8777 cgrad        enddo
8778 cgrad      enddo
8779 c      write (iout,*) "ehbcorr",ekont*ees
8780 C      print *,ekont,ees,i,k
8781       ehbcorr=ekont*ees
8782 C now gradient over shielding
8783 C      return
8784       if (shield_mode.gt.0) then
8785        j=ees0plist(jj,i)
8786        l=ees0plist(kk,k)
8787 C        print *,i,j,fac_shield(i),fac_shield(j),
8788 C     &fac_shield(k),fac_shield(l)
8789         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8790      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8791           do ilist=1,ishield_list(i)
8792            iresshield=shield_list(ilist,i)
8793            do m=1,3
8794            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8795 C     &      *2.0
8796            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8797      &              rlocshield
8798      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8799             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8800      &+rlocshield
8801            enddo
8802           enddo
8803           do ilist=1,ishield_list(j)
8804            iresshield=shield_list(ilist,j)
8805            do m=1,3
8806            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8807 C     &     *2.0
8808            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8809      &              rlocshield
8810      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8811            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8812      &     +rlocshield
8813            enddo
8814           enddo
8815
8816           do ilist=1,ishield_list(k)
8817            iresshield=shield_list(ilist,k)
8818            do m=1,3
8819            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8820 C     &     *2.0
8821            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8822      &              rlocshield
8823      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8824            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8825      &     +rlocshield
8826            enddo
8827           enddo
8828           do ilist=1,ishield_list(l)
8829            iresshield=shield_list(ilist,l)
8830            do m=1,3
8831            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8832 C     &     *2.0
8833            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8834      &              rlocshield
8835      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8836            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8837      &     +rlocshield
8838            enddo
8839           enddo
8840 C          print *,gshieldx(m,iresshield)
8841           do m=1,3
8842             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8843      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8844             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8845      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8846             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8847      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8848             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8849      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8850
8851             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8852      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8853             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8854      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8855             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8856      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8857             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8858      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8859
8860            enddo
8861       endif
8862       endif
8863       return
8864       end
8865 #ifdef MOMENT
8866 C---------------------------------------------------------------------------
8867       subroutine dipole(i,j,jj)
8868       implicit real*8 (a-h,o-z)
8869       include 'DIMENSIONS'
8870       include 'COMMON.IOUNITS'
8871       include 'COMMON.CHAIN'
8872       include 'COMMON.FFIELD'
8873       include 'COMMON.DERIV'
8874       include 'COMMON.INTERACT'
8875       include 'COMMON.CONTACTS'
8876       include 'COMMON.TORSION'
8877       include 'COMMON.VAR'
8878       include 'COMMON.GEO'
8879       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8880      &  auxmat(2,2)
8881       iti1 = itortyp(itype(i+1))
8882       if (j.lt.nres-1) then
8883         itj1 = itype2loc(itype(j+1))
8884       else
8885         itj1=nloctyp
8886       endif
8887       do iii=1,2
8888         dipi(iii,1)=Ub2(iii,i)
8889         dipderi(iii)=Ub2der(iii,i)
8890         dipi(iii,2)=b1(iii,i+1)
8891         dipj(iii,1)=Ub2(iii,j)
8892         dipderj(iii)=Ub2der(iii,j)
8893         dipj(iii,2)=b1(iii,j+1)
8894       enddo
8895       kkk=0
8896       do iii=1,2
8897         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8898         do jjj=1,2
8899           kkk=kkk+1
8900           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8901         enddo
8902       enddo
8903       do kkk=1,5
8904         do lll=1,3
8905           mmm=0
8906           do iii=1,2
8907             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8908      &        auxvec(1))
8909             do jjj=1,2
8910               mmm=mmm+1
8911               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8912             enddo
8913           enddo
8914         enddo
8915       enddo
8916       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8917       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8918       do iii=1,2
8919         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8920       enddo
8921       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8922       do iii=1,2
8923         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8924       enddo
8925       return
8926       end
8927 #endif
8928 C---------------------------------------------------------------------------
8929       subroutine calc_eello(i,j,k,l,jj,kk)
8930 C
8931 C This subroutine computes matrices and vectors needed to calculate
8932 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8933 C
8934       implicit real*8 (a-h,o-z)
8935       include 'DIMENSIONS'
8936       include 'COMMON.IOUNITS'
8937       include 'COMMON.CHAIN'
8938       include 'COMMON.DERIV'
8939       include 'COMMON.INTERACT'
8940       include 'COMMON.CONTACTS'
8941       include 'COMMON.TORSION'
8942       include 'COMMON.VAR'
8943       include 'COMMON.GEO'
8944       include 'COMMON.FFIELD'
8945       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8946      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8947       logical lprn
8948       common /kutas/ lprn
8949 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8950 cd     & ' jj=',jj,' kk=',kk
8951 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8952 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8953 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8954       do iii=1,2
8955         do jjj=1,2
8956           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8957           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8958         enddo
8959       enddo
8960       call transpose2(aa1(1,1),aa1t(1,1))
8961       call transpose2(aa2(1,1),aa2t(1,1))
8962       do kkk=1,5
8963         do lll=1,3
8964           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8965      &      aa1tder(1,1,lll,kkk))
8966           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8967      &      aa2tder(1,1,lll,kkk))
8968         enddo
8969       enddo
8970       if (l.eq.j+1) then
8971 C parallel orientation of the two CA-CA-CA frames.
8972         if (i.gt.1) then
8973           iti=itype2loc(itype(i))
8974         else
8975           iti=nloctyp
8976         endif
8977         itk1=itype2loc(itype(k+1))
8978         itj=itype2loc(itype(j))
8979         if (l.lt.nres-1) then
8980           itl1=itype2loc(itype(l+1))
8981         else
8982           itl1=nloctyp
8983         endif
8984 C A1 kernel(j+1) A2T
8985 cd        do iii=1,2
8986 cd          write (iout,'(3f10.5,5x,3f10.5)')
8987 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8988 cd        enddo
8989         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8990      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8991      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8992 C Following matrices are needed only for 6-th order cumulants
8993         IF (wcorr6.gt.0.0d0) THEN
8994         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8995      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8996      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8997         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8998      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8999      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9000      &   ADtEAderx(1,1,1,1,1,1))
9001         lprn=.false.
9002         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9003      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9004      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9005      &   ADtEA1derx(1,1,1,1,1,1))
9006         ENDIF
9007 C End 6-th order cumulants
9008 cd        lprn=.false.
9009 cd        if (lprn) then
9010 cd        write (2,*) 'In calc_eello6'
9011 cd        do iii=1,2
9012 cd          write (2,*) 'iii=',iii
9013 cd          do kkk=1,5
9014 cd            write (2,*) 'kkk=',kkk
9015 cd            do jjj=1,2
9016 cd              write (2,'(3(2f10.5),5x)')
9017 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9018 cd            enddo
9019 cd          enddo
9020 cd        enddo
9021 cd        endif
9022         call transpose2(EUgder(1,1,k),auxmat(1,1))
9023         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9024         call transpose2(EUg(1,1,k),auxmat(1,1))
9025         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9026         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9027         do iii=1,2
9028           do kkk=1,5
9029             do lll=1,3
9030               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9031      &          EAEAderx(1,1,lll,kkk,iii,1))
9032             enddo
9033           enddo
9034         enddo
9035 C A1T kernel(i+1) A2
9036         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9037      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9038      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9039 C Following matrices are needed only for 6-th order cumulants
9040         IF (wcorr6.gt.0.0d0) THEN
9041         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9042      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9043      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9044         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9045      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9046      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9047      &   ADtEAderx(1,1,1,1,1,2))
9048         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9049      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9050      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9051      &   ADtEA1derx(1,1,1,1,1,2))
9052         ENDIF
9053 C End 6-th order cumulants
9054         call transpose2(EUgder(1,1,l),auxmat(1,1))
9055         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9056         call transpose2(EUg(1,1,l),auxmat(1,1))
9057         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9058         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9059         do iii=1,2
9060           do kkk=1,5
9061             do lll=1,3
9062               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9063      &          EAEAderx(1,1,lll,kkk,iii,2))
9064             enddo
9065           enddo
9066         enddo
9067 C AEAb1 and AEAb2
9068 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9069 C They are needed only when the fifth- or the sixth-order cumulants are
9070 C indluded.
9071         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9072         call transpose2(AEA(1,1,1),auxmat(1,1))
9073         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9074         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9075         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9076         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9077         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9078         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9079         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9080         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9081         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9082         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9083         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9084         call transpose2(AEA(1,1,2),auxmat(1,1))
9085         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9086         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9087         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9088         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9089         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9090         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9091         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9092         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9093         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9094         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9095         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9096 C Calculate the Cartesian derivatives of the vectors.
9097         do iii=1,2
9098           do kkk=1,5
9099             do lll=1,3
9100               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9101               call matvec2(auxmat(1,1),b1(1,i),
9102      &          AEAb1derx(1,lll,kkk,iii,1,1))
9103               call matvec2(auxmat(1,1),Ub2(1,i),
9104      &          AEAb2derx(1,lll,kkk,iii,1,1))
9105               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9106      &          AEAb1derx(1,lll,kkk,iii,2,1))
9107               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9108      &          AEAb2derx(1,lll,kkk,iii,2,1))
9109               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9110               call matvec2(auxmat(1,1),b1(1,j),
9111      &          AEAb1derx(1,lll,kkk,iii,1,2))
9112               call matvec2(auxmat(1,1),Ub2(1,j),
9113      &          AEAb2derx(1,lll,kkk,iii,1,2))
9114               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9115      &          AEAb1derx(1,lll,kkk,iii,2,2))
9116               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9117      &          AEAb2derx(1,lll,kkk,iii,2,2))
9118             enddo
9119           enddo
9120         enddo
9121         ENDIF
9122 C End vectors
9123       else
9124 C Antiparallel orientation of the two CA-CA-CA frames.
9125         if (i.gt.1) then
9126           iti=itype2loc(itype(i))
9127         else
9128           iti=nloctyp
9129         endif
9130         itk1=itype2loc(itype(k+1))
9131         itl=itype2loc(itype(l))
9132         itj=itype2loc(itype(j))
9133         if (j.lt.nres-1) then
9134           itj1=itype2loc(itype(j+1))
9135         else
9136           itj1=nloctyp
9137         endif
9138 C A2 kernel(j-1)T A1T
9139         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9140      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9141      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9142 C Following matrices are needed only for 6-th order cumulants
9143         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9144      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9145         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9146      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9147      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9148         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9149      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9150      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9151      &   ADtEAderx(1,1,1,1,1,1))
9152         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9153      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9154      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9155      &   ADtEA1derx(1,1,1,1,1,1))
9156         ENDIF
9157 C End 6-th order cumulants
9158         call transpose2(EUgder(1,1,k),auxmat(1,1))
9159         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9160         call transpose2(EUg(1,1,k),auxmat(1,1))
9161         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9162         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9163         do iii=1,2
9164           do kkk=1,5
9165             do lll=1,3
9166               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9167      &          EAEAderx(1,1,lll,kkk,iii,1))
9168             enddo
9169           enddo
9170         enddo
9171 C A2T kernel(i+1)T A1
9172         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9173      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9174      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9175 C Following matrices are needed only for 6-th order cumulants
9176         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9177      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9178         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9179      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9180      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9181         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9182      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9183      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9184      &   ADtEAderx(1,1,1,1,1,2))
9185         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9186      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9187      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9188      &   ADtEA1derx(1,1,1,1,1,2))
9189         ENDIF
9190 C End 6-th order cumulants
9191         call transpose2(EUgder(1,1,j),auxmat(1,1))
9192         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9193         call transpose2(EUg(1,1,j),auxmat(1,1))
9194         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9195         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9196         do iii=1,2
9197           do kkk=1,5
9198             do lll=1,3
9199               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9200      &          EAEAderx(1,1,lll,kkk,iii,2))
9201             enddo
9202           enddo
9203         enddo
9204 C AEAb1 and AEAb2
9205 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9206 C They are needed only when the fifth- or the sixth-order cumulants are
9207 C indluded.
9208         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9209      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9210         call transpose2(AEA(1,1,1),auxmat(1,1))
9211         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9212         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9213         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9214         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9215         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9216         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9217         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9218         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9219         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9220         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9221         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9222         call transpose2(AEA(1,1,2),auxmat(1,1))
9223         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9224         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9225         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9226         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9227         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9228         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9229         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9230         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9231         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9232         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9233         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9234 C Calculate the Cartesian derivatives of the vectors.
9235         do iii=1,2
9236           do kkk=1,5
9237             do lll=1,3
9238               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9239               call matvec2(auxmat(1,1),b1(1,i),
9240      &          AEAb1derx(1,lll,kkk,iii,1,1))
9241               call matvec2(auxmat(1,1),Ub2(1,i),
9242      &          AEAb2derx(1,lll,kkk,iii,1,1))
9243               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9244      &          AEAb1derx(1,lll,kkk,iii,2,1))
9245               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9246      &          AEAb2derx(1,lll,kkk,iii,2,1))
9247               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9248               call matvec2(auxmat(1,1),b1(1,l),
9249      &          AEAb1derx(1,lll,kkk,iii,1,2))
9250               call matvec2(auxmat(1,1),Ub2(1,l),
9251      &          AEAb2derx(1,lll,kkk,iii,1,2))
9252               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9253      &          AEAb1derx(1,lll,kkk,iii,2,2))
9254               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9255      &          AEAb2derx(1,lll,kkk,iii,2,2))
9256             enddo
9257           enddo
9258         enddo
9259         ENDIF
9260 C End vectors
9261       endif
9262       return
9263       end
9264 C---------------------------------------------------------------------------
9265       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9266      &  KK,KKderg,AKA,AKAderg,AKAderx)
9267       implicit none
9268       integer nderg
9269       logical transp
9270       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9271      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9272      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9273       integer iii,kkk,lll
9274       integer jjj,mmm
9275       logical lprn
9276       common /kutas/ lprn
9277       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9278       do iii=1,nderg
9279         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9280      &    AKAderg(1,1,iii))
9281       enddo
9282 cd      if (lprn) write (2,*) 'In kernel'
9283       do kkk=1,5
9284 cd        if (lprn) write (2,*) 'kkk=',kkk
9285         do lll=1,3
9286           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9287      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9288 cd          if (lprn) then
9289 cd            write (2,*) 'lll=',lll
9290 cd            write (2,*) 'iii=1'
9291 cd            do jjj=1,2
9292 cd              write (2,'(3(2f10.5),5x)')
9293 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9294 cd            enddo
9295 cd          endif
9296           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9297      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9298 cd          if (lprn) then
9299 cd            write (2,*) 'lll=',lll
9300 cd            write (2,*) 'iii=2'
9301 cd            do jjj=1,2
9302 cd              write (2,'(3(2f10.5),5x)')
9303 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9304 cd            enddo
9305 cd          endif
9306         enddo
9307       enddo
9308       return
9309       end
9310 C---------------------------------------------------------------------------
9311       double precision function eello4(i,j,k,l,jj,kk)
9312       implicit real*8 (a-h,o-z)
9313       include 'DIMENSIONS'
9314       include 'COMMON.IOUNITS'
9315       include 'COMMON.CHAIN'
9316       include 'COMMON.DERIV'
9317       include 'COMMON.INTERACT'
9318       include 'COMMON.CONTACTS'
9319       include 'COMMON.TORSION'
9320       include 'COMMON.VAR'
9321       include 'COMMON.GEO'
9322       double precision pizda(2,2),ggg1(3),ggg2(3)
9323 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9324 cd        eello4=0.0d0
9325 cd        return
9326 cd      endif
9327 cd      print *,'eello4:',i,j,k,l,jj,kk
9328 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9329 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9330 cold      eij=facont_hb(jj,i)
9331 cold      ekl=facont_hb(kk,k)
9332 cold      ekont=eij*ekl
9333       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9334 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9335       gcorr_loc(k-1)=gcorr_loc(k-1)
9336      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9337       if (l.eq.j+1) then
9338         gcorr_loc(l-1)=gcorr_loc(l-1)
9339      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9340       else
9341         gcorr_loc(j-1)=gcorr_loc(j-1)
9342      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9343       endif
9344       do iii=1,2
9345         do kkk=1,5
9346           do lll=1,3
9347             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9348      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9349 cd            derx(lll,kkk,iii)=0.0d0
9350           enddo
9351         enddo
9352       enddo
9353 cd      gcorr_loc(l-1)=0.0d0
9354 cd      gcorr_loc(j-1)=0.0d0
9355 cd      gcorr_loc(k-1)=0.0d0
9356 cd      eel4=1.0d0
9357 cd      write (iout,*)'Contacts have occurred for peptide groups',
9358 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9359 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9360       if (j.lt.nres-1) then
9361         j1=j+1
9362         j2=j-1
9363       else
9364         j1=j-1
9365         j2=j-2
9366       endif
9367       if (l.lt.nres-1) then
9368         l1=l+1
9369         l2=l-1
9370       else
9371         l1=l-1
9372         l2=l-2
9373       endif
9374       do ll=1,3
9375 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9376 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9377         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9378         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9379 cgrad        ghalf=0.5d0*ggg1(ll)
9380         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9381         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9382         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9383         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9384         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9385         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9386 cgrad        ghalf=0.5d0*ggg2(ll)
9387         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9388         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9389         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9390         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9391         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9392         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9393       enddo
9394 cgrad      do m=i+1,j-1
9395 cgrad        do ll=1,3
9396 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9397 cgrad        enddo
9398 cgrad      enddo
9399 cgrad      do m=k+1,l-1
9400 cgrad        do ll=1,3
9401 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9402 cgrad        enddo
9403 cgrad      enddo
9404 cgrad      do m=i+2,j2
9405 cgrad        do ll=1,3
9406 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9407 cgrad        enddo
9408 cgrad      enddo
9409 cgrad      do m=k+2,l2
9410 cgrad        do ll=1,3
9411 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9412 cgrad        enddo
9413 cgrad      enddo
9414 cd      do iii=1,nres-3
9415 cd        write (2,*) iii,gcorr_loc(iii)
9416 cd      enddo
9417       eello4=ekont*eel4
9418 cd      write (2,*) 'ekont',ekont
9419 cd      write (iout,*) 'eello4',ekont*eel4
9420       return
9421       end
9422 C---------------------------------------------------------------------------
9423       double precision function eello5(i,j,k,l,jj,kk)
9424       implicit real*8 (a-h,o-z)
9425       include 'DIMENSIONS'
9426       include 'COMMON.IOUNITS'
9427       include 'COMMON.CHAIN'
9428       include 'COMMON.DERIV'
9429       include 'COMMON.INTERACT'
9430       include 'COMMON.CONTACTS'
9431       include 'COMMON.TORSION'
9432       include 'COMMON.VAR'
9433       include 'COMMON.GEO'
9434       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9435       double precision ggg1(3),ggg2(3)
9436 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9437 C                                                                              C
9438 C                            Parallel chains                                   C
9439 C                                                                              C
9440 C          o             o                   o             o                   C
9441 C         /l\           / \             \   / \           / \   /              C
9442 C        /   \         /   \             \ /   \         /   \ /               C
9443 C       j| o |l1       | o |              o| o |         | o |o                C
9444 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9445 C      \i/   \         /   \ /             /   \         /   \                 C
9446 C       o    k1             o                                                  C
9447 C         (I)          (II)                (III)          (IV)                 C
9448 C                                                                              C
9449 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9450 C                                                                              C
9451 C                            Antiparallel chains                               C
9452 C                                                                              C
9453 C          o             o                   o             o                   C
9454 C         /j\           / \             \   / \           / \   /              C
9455 C        /   \         /   \             \ /   \         /   \ /               C
9456 C      j1| o |l        | o |              o| o |         | o |o                C
9457 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9458 C      \i/   \         /   \ /             /   \         /   \                 C
9459 C       o     k1            o                                                  C
9460 C         (I)          (II)                (III)          (IV)                 C
9461 C                                                                              C
9462 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9463 C                                                                              C
9464 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9465 C                                                                              C
9466 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9467 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9468 cd        eello5=0.0d0
9469 cd        return
9470 cd      endif
9471 cd      write (iout,*)
9472 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9473 cd     &   ' and',k,l
9474       itk=itype2loc(itype(k))
9475       itl=itype2loc(itype(l))
9476       itj=itype2loc(itype(j))
9477       eello5_1=0.0d0
9478       eello5_2=0.0d0
9479       eello5_3=0.0d0
9480       eello5_4=0.0d0
9481 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9482 cd     &   eel5_3_num,eel5_4_num)
9483       do iii=1,2
9484         do kkk=1,5
9485           do lll=1,3
9486             derx(lll,kkk,iii)=0.0d0
9487           enddo
9488         enddo
9489       enddo
9490 cd      eij=facont_hb(jj,i)
9491 cd      ekl=facont_hb(kk,k)
9492 cd      ekont=eij*ekl
9493 cd      write (iout,*)'Contacts have occurred for peptide groups',
9494 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9495 cd      goto 1111
9496 C Contribution from the graph I.
9497 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9498 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9499       call transpose2(EUg(1,1,k),auxmat(1,1))
9500       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9501       vv(1)=pizda(1,1)-pizda(2,2)
9502       vv(2)=pizda(1,2)+pizda(2,1)
9503       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9504      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9505 C Explicit gradient in virtual-dihedral angles.
9506       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9507      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9508      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9509       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9510       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9511       vv(1)=pizda(1,1)-pizda(2,2)
9512       vv(2)=pizda(1,2)+pizda(2,1)
9513       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9514      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9515      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9516       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9517       vv(1)=pizda(1,1)-pizda(2,2)
9518       vv(2)=pizda(1,2)+pizda(2,1)
9519       if (l.eq.j+1) then
9520         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9521      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9522      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9523       else
9524         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9525      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9526      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9527       endif
9528 C Cartesian gradient
9529       do iii=1,2
9530         do kkk=1,5
9531           do lll=1,3
9532             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9533      &        pizda(1,1))
9534             vv(1)=pizda(1,1)-pizda(2,2)
9535             vv(2)=pizda(1,2)+pizda(2,1)
9536             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9537      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9538      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9539           enddo
9540         enddo
9541       enddo
9542 c      goto 1112
9543 c1111  continue
9544 C Contribution from graph II
9545       call transpose2(EE(1,1,k),auxmat(1,1))
9546       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9547       vv(1)=pizda(1,1)+pizda(2,2)
9548       vv(2)=pizda(2,1)-pizda(1,2)
9549       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9550      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9551 C Explicit gradient in virtual-dihedral angles.
9552       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9553      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9554       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9555       vv(1)=pizda(1,1)+pizda(2,2)
9556       vv(2)=pizda(2,1)-pizda(1,2)
9557       if (l.eq.j+1) then
9558         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9559      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9560      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9561       else
9562         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9563      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9564      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9565       endif
9566 C Cartesian gradient
9567       do iii=1,2
9568         do kkk=1,5
9569           do lll=1,3
9570             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9571      &        pizda(1,1))
9572             vv(1)=pizda(1,1)+pizda(2,2)
9573             vv(2)=pizda(2,1)-pizda(1,2)
9574             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9575      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9576      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9577           enddo
9578         enddo
9579       enddo
9580 cd      goto 1112
9581 cd1111  continue
9582       if (l.eq.j+1) then
9583 cd        goto 1110
9584 C Parallel orientation
9585 C Contribution from graph III
9586         call transpose2(EUg(1,1,l),auxmat(1,1))
9587         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9588         vv(1)=pizda(1,1)-pizda(2,2)
9589         vv(2)=pizda(1,2)+pizda(2,1)
9590         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9592 C Explicit gradient in virtual-dihedral angles.
9593         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9594      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9595      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9596         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9597         vv(1)=pizda(1,1)-pizda(2,2)
9598         vv(2)=pizda(1,2)+pizda(2,1)
9599         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9600      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9601      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9602         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9603         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9604         vv(1)=pizda(1,1)-pizda(2,2)
9605         vv(2)=pizda(1,2)+pizda(2,1)
9606         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9607      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9608      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9609 C Cartesian gradient
9610         do iii=1,2
9611           do kkk=1,5
9612             do lll=1,3
9613               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9614      &          pizda(1,1))
9615               vv(1)=pizda(1,1)-pizda(2,2)
9616               vv(2)=pizda(1,2)+pizda(2,1)
9617               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9618      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9619      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9620             enddo
9621           enddo
9622         enddo
9623 cd        goto 1112
9624 C Contribution from graph IV
9625 cd1110    continue
9626         call transpose2(EE(1,1,l),auxmat(1,1))
9627         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9628         vv(1)=pizda(1,1)+pizda(2,2)
9629         vv(2)=pizda(2,1)-pizda(1,2)
9630         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9631      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9632 C Explicit gradient in virtual-dihedral angles.
9633         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9634      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9635         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9636         vv(1)=pizda(1,1)+pizda(2,2)
9637         vv(2)=pizda(2,1)-pizda(1,2)
9638         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9639      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9640      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9641 C Cartesian gradient
9642         do iii=1,2
9643           do kkk=1,5
9644             do lll=1,3
9645               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9646      &          pizda(1,1))
9647               vv(1)=pizda(1,1)+pizda(2,2)
9648               vv(2)=pizda(2,1)-pizda(1,2)
9649               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9650      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9651      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9652             enddo
9653           enddo
9654         enddo
9655       else
9656 C Antiparallel orientation
9657 C Contribution from graph III
9658 c        goto 1110
9659         call transpose2(EUg(1,1,j),auxmat(1,1))
9660         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9661         vv(1)=pizda(1,1)-pizda(2,2)
9662         vv(2)=pizda(1,2)+pizda(2,1)
9663         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9664      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9665 C Explicit gradient in virtual-dihedral angles.
9666         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9667      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9668      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9669         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9670         vv(1)=pizda(1,1)-pizda(2,2)
9671         vv(2)=pizda(1,2)+pizda(2,1)
9672         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9673      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9674      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9675         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9676         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9677         vv(1)=pizda(1,1)-pizda(2,2)
9678         vv(2)=pizda(1,2)+pizda(2,1)
9679         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9680      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9682 C Cartesian gradient
9683         do iii=1,2
9684           do kkk=1,5
9685             do lll=1,3
9686               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9687      &          pizda(1,1))
9688               vv(1)=pizda(1,1)-pizda(2,2)
9689               vv(2)=pizda(1,2)+pizda(2,1)
9690               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9691      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9692      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9693             enddo
9694           enddo
9695         enddo
9696 cd        goto 1112
9697 C Contribution from graph IV
9698 1110    continue
9699         call transpose2(EE(1,1,j),auxmat(1,1))
9700         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9701         vv(1)=pizda(1,1)+pizda(2,2)
9702         vv(2)=pizda(2,1)-pizda(1,2)
9703         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9704      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9705 C Explicit gradient in virtual-dihedral angles.
9706         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9707      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9708         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9709         vv(1)=pizda(1,1)+pizda(2,2)
9710         vv(2)=pizda(2,1)-pizda(1,2)
9711         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9712      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9713      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9714 C Cartesian gradient
9715         do iii=1,2
9716           do kkk=1,5
9717             do lll=1,3
9718               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9719      &          pizda(1,1))
9720               vv(1)=pizda(1,1)+pizda(2,2)
9721               vv(2)=pizda(2,1)-pizda(1,2)
9722               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9723      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9724      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9725             enddo
9726           enddo
9727         enddo
9728       endif
9729 1112  continue
9730       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9731 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9732 cd        write (2,*) 'ijkl',i,j,k,l
9733 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9734 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9735 cd      endif
9736 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9737 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9738 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9739 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9740       if (j.lt.nres-1) then
9741         j1=j+1
9742         j2=j-1
9743       else
9744         j1=j-1
9745         j2=j-2
9746       endif
9747       if (l.lt.nres-1) then
9748         l1=l+1
9749         l2=l-1
9750       else
9751         l1=l-1
9752         l2=l-2
9753       endif
9754 cd      eij=1.0d0
9755 cd      ekl=1.0d0
9756 cd      ekont=1.0d0
9757 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9758 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9759 C        summed up outside the subrouine as for the other subroutines
9760 C        handling long-range interactions. The old code is commented out
9761 C        with "cgrad" to keep track of changes.
9762       do ll=1,3
9763 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9764 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9765         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9766         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9767 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9768 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9769 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9770 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9771 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9772 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9773 c     &   gradcorr5ij,
9774 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9775 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9776 cgrad        ghalf=0.5d0*ggg1(ll)
9777 cd        ghalf=0.0d0
9778         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9779         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9780         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9781         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9782         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9783         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9784 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9785 cgrad        ghalf=0.5d0*ggg2(ll)
9786 cd        ghalf=0.0d0
9787         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9788         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9789         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9790         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9791         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9792         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9793       enddo
9794 cd      goto 1112
9795 cgrad      do m=i+1,j-1
9796 cgrad        do ll=1,3
9797 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9798 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9799 cgrad        enddo
9800 cgrad      enddo
9801 cgrad      do m=k+1,l-1
9802 cgrad        do ll=1,3
9803 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9804 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9805 cgrad        enddo
9806 cgrad      enddo
9807 c1112  continue
9808 cgrad      do m=i+2,j2
9809 cgrad        do ll=1,3
9810 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9811 cgrad        enddo
9812 cgrad      enddo
9813 cgrad      do m=k+2,l2
9814 cgrad        do ll=1,3
9815 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9816 cgrad        enddo
9817 cgrad      enddo
9818 cd      do iii=1,nres-3
9819 cd        write (2,*) iii,g_corr5_loc(iii)
9820 cd      enddo
9821       eello5=ekont*eel5
9822 cd      write (2,*) 'ekont',ekont
9823 cd      write (iout,*) 'eello5',ekont*eel5
9824       return
9825       end
9826 c--------------------------------------------------------------------------
9827       double precision function eello6(i,j,k,l,jj,kk)
9828       implicit real*8 (a-h,o-z)
9829       include 'DIMENSIONS'
9830       include 'COMMON.IOUNITS'
9831       include 'COMMON.CHAIN'
9832       include 'COMMON.DERIV'
9833       include 'COMMON.INTERACT'
9834       include 'COMMON.CONTACTS'
9835       include 'COMMON.TORSION'
9836       include 'COMMON.VAR'
9837       include 'COMMON.GEO'
9838       include 'COMMON.FFIELD'
9839       double precision ggg1(3),ggg2(3)
9840 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9841 cd        eello6=0.0d0
9842 cd        return
9843 cd      endif
9844 cd      write (iout,*)
9845 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9846 cd     &   ' and',k,l
9847       eello6_1=0.0d0
9848       eello6_2=0.0d0
9849       eello6_3=0.0d0
9850       eello6_4=0.0d0
9851       eello6_5=0.0d0
9852       eello6_6=0.0d0
9853 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9854 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9855       do iii=1,2
9856         do kkk=1,5
9857           do lll=1,3
9858             derx(lll,kkk,iii)=0.0d0
9859           enddo
9860         enddo
9861       enddo
9862 cd      eij=facont_hb(jj,i)
9863 cd      ekl=facont_hb(kk,k)
9864 cd      ekont=eij*ekl
9865 cd      eij=1.0d0
9866 cd      ekl=1.0d0
9867 cd      ekont=1.0d0
9868       if (l.eq.j+1) then
9869         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9870         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9871         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9872         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9873         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9874         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9875       else
9876         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9877         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9878         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9879         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9880         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9881           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9882         else
9883           eello6_5=0.0d0
9884         endif
9885         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9886       endif
9887 C If turn contributions are considered, they will be handled separately.
9888       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9889 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9890 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9891 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9892 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9893 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9894 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9895 cd      goto 1112
9896       if (j.lt.nres-1) then
9897         j1=j+1
9898         j2=j-1
9899       else
9900         j1=j-1
9901         j2=j-2
9902       endif
9903       if (l.lt.nres-1) then
9904         l1=l+1
9905         l2=l-1
9906       else
9907         l1=l-1
9908         l2=l-2
9909       endif
9910       do ll=1,3
9911 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9912 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9913 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9914 cgrad        ghalf=0.5d0*ggg1(ll)
9915 cd        ghalf=0.0d0
9916         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9917         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9918         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9919         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9920         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9921         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9922         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9923         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9924 cgrad        ghalf=0.5d0*ggg2(ll)
9925 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9926 cd        ghalf=0.0d0
9927         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9928         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9929         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9930         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9931         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9932         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9933       enddo
9934 cd      goto 1112
9935 cgrad      do m=i+1,j-1
9936 cgrad        do ll=1,3
9937 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9938 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9939 cgrad        enddo
9940 cgrad      enddo
9941 cgrad      do m=k+1,l-1
9942 cgrad        do ll=1,3
9943 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9944 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9945 cgrad        enddo
9946 cgrad      enddo
9947 cgrad1112  continue
9948 cgrad      do m=i+2,j2
9949 cgrad        do ll=1,3
9950 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9951 cgrad        enddo
9952 cgrad      enddo
9953 cgrad      do m=k+2,l2
9954 cgrad        do ll=1,3
9955 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9956 cgrad        enddo
9957 cgrad      enddo
9958 cd      do iii=1,nres-3
9959 cd        write (2,*) iii,g_corr6_loc(iii)
9960 cd      enddo
9961       eello6=ekont*eel6
9962 cd      write (2,*) 'ekont',ekont
9963 cd      write (iout,*) 'eello6',ekont*eel6
9964       return
9965       end
9966 c--------------------------------------------------------------------------
9967       double precision function eello6_graph1(i,j,k,l,imat,swap)
9968       implicit real*8 (a-h,o-z)
9969       include 'DIMENSIONS'
9970       include 'COMMON.IOUNITS'
9971       include 'COMMON.CHAIN'
9972       include 'COMMON.DERIV'
9973       include 'COMMON.INTERACT'
9974       include 'COMMON.CONTACTS'
9975       include 'COMMON.TORSION'
9976       include 'COMMON.VAR'
9977       include 'COMMON.GEO'
9978       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9979       logical swap
9980       logical lprn
9981       common /kutas/ lprn
9982 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9983 C                                                                              C
9984 C      Parallel       Antiparallel                                             C
9985 C                                                                              C
9986 C          o             o                                                     C
9987 C         /l\           /j\                                                    C
9988 C        /   \         /   \                                                   C
9989 C       /| o |         | o |\                                                  C
9990 C     \ j|/k\|  /   \  |/k\|l /                                                C
9991 C      \ /   \ /     \ /   \ /                                                 C
9992 C       o     o       o     o                                                  C
9993 C       i             i                                                        C
9994 C                                                                              C
9995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9996       itk=itype2loc(itype(k))
9997       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9998       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9999       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10000       call transpose2(EUgC(1,1,k),auxmat(1,1))
10001       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10002       vv1(1)=pizda1(1,1)-pizda1(2,2)
10003       vv1(2)=pizda1(1,2)+pizda1(2,1)
10004       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10005       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10006       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10007       s5=scalar2(vv(1),Dtobr2(1,i))
10008 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10009       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10010       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10011      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10012      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10013      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10014      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10015      & +scalar2(vv(1),Dtobr2der(1,i)))
10016       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10017       vv1(1)=pizda1(1,1)-pizda1(2,2)
10018       vv1(2)=pizda1(1,2)+pizda1(2,1)
10019       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10020       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10021       if (l.eq.j+1) then
10022         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10023      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10024      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10025      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10026      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10027       else
10028         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10029      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10030      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10031      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10032      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10033       endif
10034       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10035       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10036       vv1(1)=pizda1(1,1)-pizda1(2,2)
10037       vv1(2)=pizda1(1,2)+pizda1(2,1)
10038       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10039      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10040      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10041      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10042       do iii=1,2
10043         if (swap) then
10044           ind=3-iii
10045         else
10046           ind=iii
10047         endif
10048         do kkk=1,5
10049           do lll=1,3
10050             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10051             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10052             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10053             call transpose2(EUgC(1,1,k),auxmat(1,1))
10054             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10055      &        pizda1(1,1))
10056             vv1(1)=pizda1(1,1)-pizda1(2,2)
10057             vv1(2)=pizda1(1,2)+pizda1(2,1)
10058             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10059             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10060      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10061             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10062      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10063             s5=scalar2(vv(1),Dtobr2(1,i))
10064             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10065           enddo
10066         enddo
10067       enddo
10068       return
10069       end
10070 c----------------------------------------------------------------------------
10071       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10072       implicit real*8 (a-h,o-z)
10073       include 'DIMENSIONS'
10074       include 'COMMON.IOUNITS'
10075       include 'COMMON.CHAIN'
10076       include 'COMMON.DERIV'
10077       include 'COMMON.INTERACT'
10078       include 'COMMON.CONTACTS'
10079       include 'COMMON.TORSION'
10080       include 'COMMON.VAR'
10081       include 'COMMON.GEO'
10082       logical swap
10083       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10084      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10085       logical lprn
10086       common /kutas/ lprn
10087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10088 C                                                                              C
10089 C      Parallel       Antiparallel                                             C
10090 C                                                                              C
10091 C          o             o                                                     C
10092 C     \   /l\           /j\   /                                                C
10093 C      \ /   \         /   \ /                                                 C
10094 C       o| o |         | o |o                                                  C
10095 C     \ j|/k\|      \  |/k\|l                                                  C
10096 C      \ /   \       \ /   \                                                   C
10097 C       o             o                                                        C
10098 C       i             i                                                        C
10099 C                                                                              C
10100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10101 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10102 C AL 7/4/01 s1 would occur in the sixth-order moment,
10103 C           but not in a cluster cumulant
10104 #ifdef MOMENT
10105       s1=dip(1,jj,i)*dip(1,kk,k)
10106 #endif
10107       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10108       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10109       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10110       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10111       call transpose2(EUg(1,1,k),auxmat(1,1))
10112       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10113       vv(1)=pizda(1,1)-pizda(2,2)
10114       vv(2)=pizda(1,2)+pizda(2,1)
10115       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10116 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10117 #ifdef MOMENT
10118       eello6_graph2=-(s1+s2+s3+s4)
10119 #else
10120       eello6_graph2=-(s2+s3+s4)
10121 #endif
10122 c      eello6_graph2=-s3
10123 C Derivatives in gamma(i-1)
10124       if (i.gt.1) then
10125 #ifdef MOMENT
10126         s1=dipderg(1,jj,i)*dip(1,kk,k)
10127 #endif
10128         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10129         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10130         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10131         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10132 #ifdef MOMENT
10133         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10134 #else
10135         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10136 #endif
10137 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10138       endif
10139 C Derivatives in gamma(k-1)
10140 #ifdef MOMENT
10141       s1=dip(1,jj,i)*dipderg(1,kk,k)
10142 #endif
10143       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10144       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10145       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10146       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10147       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10148       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10149       vv(1)=pizda(1,1)-pizda(2,2)
10150       vv(2)=pizda(1,2)+pizda(2,1)
10151       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10152 #ifdef MOMENT
10153       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10154 #else
10155       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10156 #endif
10157 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10158 C Derivatives in gamma(j-1) or gamma(l-1)
10159       if (j.gt.1) then
10160 #ifdef MOMENT
10161         s1=dipderg(3,jj,i)*dip(1,kk,k)
10162 #endif
10163         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10164         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10165         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10166         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10167         vv(1)=pizda(1,1)-pizda(2,2)
10168         vv(2)=pizda(1,2)+pizda(2,1)
10169         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10170 #ifdef MOMENT
10171         if (swap) then
10172           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10173         else
10174           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10175         endif
10176 #endif
10177         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10178 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10179       endif
10180 C Derivatives in gamma(l-1) or gamma(j-1)
10181       if (l.gt.1) then
10182 #ifdef MOMENT
10183         s1=dip(1,jj,i)*dipderg(3,kk,k)
10184 #endif
10185         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10186         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10187         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10188         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10189         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10190         vv(1)=pizda(1,1)-pizda(2,2)
10191         vv(2)=pizda(1,2)+pizda(2,1)
10192         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10193 #ifdef MOMENT
10194         if (swap) then
10195           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10196         else
10197           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10198         endif
10199 #endif
10200         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10201 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10202       endif
10203 C Cartesian derivatives.
10204       if (lprn) then
10205         write (2,*) 'In eello6_graph2'
10206         do iii=1,2
10207           write (2,*) 'iii=',iii
10208           do kkk=1,5
10209             write (2,*) 'kkk=',kkk
10210             do jjj=1,2
10211               write (2,'(3(2f10.5),5x)')
10212      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10213             enddo
10214           enddo
10215         enddo
10216       endif
10217       do iii=1,2
10218         do kkk=1,5
10219           do lll=1,3
10220 #ifdef MOMENT
10221             if (iii.eq.1) then
10222               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10223             else
10224               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10225             endif
10226 #endif
10227             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10228      &        auxvec(1))
10229             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10230             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10231      &        auxvec(1))
10232             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10233             call transpose2(EUg(1,1,k),auxmat(1,1))
10234             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10235      &        pizda(1,1))
10236             vv(1)=pizda(1,1)-pizda(2,2)
10237             vv(2)=pizda(1,2)+pizda(2,1)
10238             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10239 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10240 #ifdef MOMENT
10241             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10242 #else
10243             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10244 #endif
10245             if (swap) then
10246               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10247             else
10248               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10249             endif
10250           enddo
10251         enddo
10252       enddo
10253       return
10254       end
10255 c----------------------------------------------------------------------------
10256       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10257       implicit real*8 (a-h,o-z)
10258       include 'DIMENSIONS'
10259       include 'COMMON.IOUNITS'
10260       include 'COMMON.CHAIN'
10261       include 'COMMON.DERIV'
10262       include 'COMMON.INTERACT'
10263       include 'COMMON.CONTACTS'
10264       include 'COMMON.TORSION'
10265       include 'COMMON.VAR'
10266       include 'COMMON.GEO'
10267       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10268       logical swap
10269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10270 C                                                                              C
10271 C      Parallel       Antiparallel                                             C
10272 C                                                                              C
10273 C          o             o                                                     C
10274 C         /l\   /   \   /j\                                                    C
10275 C        /   \ /     \ /   \                                                   C
10276 C       /| o |o       o| o |\                                                  C
10277 C       j|/k\|  /      |/k\|l /                                                C
10278 C        /   \ /       /   \ /                                                 C
10279 C       /     o       /     o                                                  C
10280 C       i             i                                                        C
10281 C                                                                              C
10282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10283 C
10284 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10285 C           energy moment and not to the cluster cumulant.
10286       iti=itortyp(itype(i))
10287       if (j.lt.nres-1) then
10288         itj1=itype2loc(itype(j+1))
10289       else
10290         itj1=nloctyp
10291       endif
10292       itk=itype2loc(itype(k))
10293       itk1=itype2loc(itype(k+1))
10294       if (l.lt.nres-1) then
10295         itl1=itype2loc(itype(l+1))
10296       else
10297         itl1=nloctyp
10298       endif
10299 #ifdef MOMENT
10300       s1=dip(4,jj,i)*dip(4,kk,k)
10301 #endif
10302       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10303       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10304       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10305       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10306       call transpose2(EE(1,1,k),auxmat(1,1))
10307       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10308       vv(1)=pizda(1,1)+pizda(2,2)
10309       vv(2)=pizda(2,1)-pizda(1,2)
10310       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10311 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10312 cd     & "sum",-(s2+s3+s4)
10313 #ifdef MOMENT
10314       eello6_graph3=-(s1+s2+s3+s4)
10315 #else
10316       eello6_graph3=-(s2+s3+s4)
10317 #endif
10318 c      eello6_graph3=-s4
10319 C Derivatives in gamma(k-1)
10320       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10321       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10322       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10323       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10324 C Derivatives in gamma(l-1)
10325       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10326       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10327       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10328       vv(1)=pizda(1,1)+pizda(2,2)
10329       vv(2)=pizda(2,1)-pizda(1,2)
10330       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10331       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10332 C Cartesian derivatives.
10333       do iii=1,2
10334         do kkk=1,5
10335           do lll=1,3
10336 #ifdef MOMENT
10337             if (iii.eq.1) then
10338               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10339             else
10340               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10341             endif
10342 #endif
10343             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10344      &        auxvec(1))
10345             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10346             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10347      &        auxvec(1))
10348             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10349             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10350      &        pizda(1,1))
10351             vv(1)=pizda(1,1)+pizda(2,2)
10352             vv(2)=pizda(2,1)-pizda(1,2)
10353             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10354 #ifdef MOMENT
10355             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10356 #else
10357             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10358 #endif
10359             if (swap) then
10360               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10361             else
10362               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10363             endif
10364 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10365           enddo
10366         enddo
10367       enddo
10368       return
10369       end
10370 c----------------------------------------------------------------------------
10371       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10372       implicit real*8 (a-h,o-z)
10373       include 'DIMENSIONS'
10374       include 'COMMON.IOUNITS'
10375       include 'COMMON.CHAIN'
10376       include 'COMMON.DERIV'
10377       include 'COMMON.INTERACT'
10378       include 'COMMON.CONTACTS'
10379       include 'COMMON.TORSION'
10380       include 'COMMON.VAR'
10381       include 'COMMON.GEO'
10382       include 'COMMON.FFIELD'
10383       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10384      & auxvec1(2),auxmat1(2,2)
10385       logical swap
10386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10387 C                                                                              C
10388 C      Parallel       Antiparallel                                             C
10389 C                                                                              C
10390 C          o             o                                                     C
10391 C         /l\   /   \   /j\                                                    C
10392 C        /   \ /     \ /   \                                                   C
10393 C       /| o |o       o| o |\                                                  C
10394 C     \ j|/k\|      \  |/k\|l                                                  C
10395 C      \ /   \       \ /   \                                                   C
10396 C       o     \       o     \                                                  C
10397 C       i             i                                                        C
10398 C                                                                              C
10399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10400 C
10401 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10402 C           energy moment and not to the cluster cumulant.
10403 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10404       iti=itype2loc(itype(i))
10405       itj=itype2loc(itype(j))
10406       if (j.lt.nres-1) then
10407         itj1=itype2loc(itype(j+1))
10408       else
10409         itj1=nloctyp
10410       endif
10411       itk=itype2loc(itype(k))
10412       if (k.lt.nres-1) then
10413         itk1=itype2loc(itype(k+1))
10414       else
10415         itk1=nloctyp
10416       endif
10417       itl=itype2loc(itype(l))
10418       if (l.lt.nres-1) then
10419         itl1=itype2loc(itype(l+1))
10420       else
10421         itl1=nloctyp
10422       endif
10423 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10424 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10425 cd     & ' itl',itl,' itl1',itl1
10426 #ifdef MOMENT
10427       if (imat.eq.1) then
10428         s1=dip(3,jj,i)*dip(3,kk,k)
10429       else
10430         s1=dip(2,jj,j)*dip(2,kk,l)
10431       endif
10432 #endif
10433       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10434       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10435       if (j.eq.l+1) then
10436         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10437         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10438       else
10439         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10440         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10441       endif
10442       call transpose2(EUg(1,1,k),auxmat(1,1))
10443       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10444       vv(1)=pizda(1,1)-pizda(2,2)
10445       vv(2)=pizda(2,1)+pizda(1,2)
10446       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10447 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10448 #ifdef MOMENT
10449       eello6_graph4=-(s1+s2+s3+s4)
10450 #else
10451       eello6_graph4=-(s2+s3+s4)
10452 #endif
10453 C Derivatives in gamma(i-1)
10454       if (i.gt.1) then
10455 #ifdef MOMENT
10456         if (imat.eq.1) then
10457           s1=dipderg(2,jj,i)*dip(3,kk,k)
10458         else
10459           s1=dipderg(4,jj,j)*dip(2,kk,l)
10460         endif
10461 #endif
10462         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10463         if (j.eq.l+1) then
10464           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10465           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10466         else
10467           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10468           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10469         endif
10470         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10471         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10472 cd          write (2,*) 'turn6 derivatives'
10473 #ifdef MOMENT
10474           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10475 #else
10476           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10477 #endif
10478         else
10479 #ifdef MOMENT
10480           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10481 #else
10482           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10483 #endif
10484         endif
10485       endif
10486 C Derivatives in gamma(k-1)
10487 #ifdef MOMENT
10488       if (imat.eq.1) then
10489         s1=dip(3,jj,i)*dipderg(2,kk,k)
10490       else
10491         s1=dip(2,jj,j)*dipderg(4,kk,l)
10492       endif
10493 #endif
10494       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10495       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10496       if (j.eq.l+1) then
10497         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10498         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10499       else
10500         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10501         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10502       endif
10503       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10504       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10505       vv(1)=pizda(1,1)-pizda(2,2)
10506       vv(2)=pizda(2,1)+pizda(1,2)
10507       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10508       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10509 #ifdef MOMENT
10510         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10511 #else
10512         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10513 #endif
10514       else
10515 #ifdef MOMENT
10516         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10517 #else
10518         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10519 #endif
10520       endif
10521 C Derivatives in gamma(j-1) or gamma(l-1)
10522       if (l.eq.j+1 .and. l.gt.1) then
10523         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10524         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10525         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10526         vv(1)=pizda(1,1)-pizda(2,2)
10527         vv(2)=pizda(2,1)+pizda(1,2)
10528         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10529         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10530       else if (j.gt.1) then
10531         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10532         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10533         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10534         vv(1)=pizda(1,1)-pizda(2,2)
10535         vv(2)=pizda(2,1)+pizda(1,2)
10536         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10537         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10538           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10539         else
10540           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10541         endif
10542       endif
10543 C Cartesian derivatives.
10544       do iii=1,2
10545         do kkk=1,5
10546           do lll=1,3
10547 #ifdef MOMENT
10548             if (iii.eq.1) then
10549               if (imat.eq.1) then
10550                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10551               else
10552                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10553               endif
10554             else
10555               if (imat.eq.1) then
10556                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10557               else
10558                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10559               endif
10560             endif
10561 #endif
10562             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10563      &        auxvec(1))
10564             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10565             if (j.eq.l+1) then
10566               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10567      &          b1(1,j+1),auxvec(1))
10568               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10569             else
10570               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10571      &          b1(1,l+1),auxvec(1))
10572               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10573             endif
10574             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10575      &        pizda(1,1))
10576             vv(1)=pizda(1,1)-pizda(2,2)
10577             vv(2)=pizda(2,1)+pizda(1,2)
10578             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10579             if (swap) then
10580               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10581 #ifdef MOMENT
10582                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10583      &             -(s1+s2+s4)
10584 #else
10585                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10586      &             -(s2+s4)
10587 #endif
10588                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10589               else
10590 #ifdef MOMENT
10591                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10592 #else
10593                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10594 #endif
10595                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10596               endif
10597             else
10598 #ifdef MOMENT
10599               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10600 #else
10601               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10602 #endif
10603               if (l.eq.j+1) then
10604                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10605               else
10606                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10607               endif
10608             endif
10609           enddo
10610         enddo
10611       enddo
10612       return
10613       end
10614 c----------------------------------------------------------------------------
10615       double precision function eello_turn6(i,jj,kk)
10616       implicit real*8 (a-h,o-z)
10617       include 'DIMENSIONS'
10618       include 'COMMON.IOUNITS'
10619       include 'COMMON.CHAIN'
10620       include 'COMMON.DERIV'
10621       include 'COMMON.INTERACT'
10622       include 'COMMON.CONTACTS'
10623       include 'COMMON.TORSION'
10624       include 'COMMON.VAR'
10625       include 'COMMON.GEO'
10626       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10627      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10628      &  ggg1(3),ggg2(3)
10629       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10630      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10631 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10632 C           the respective energy moment and not to the cluster cumulant.
10633       s1=0.0d0
10634       s8=0.0d0
10635       s13=0.0d0
10636 c
10637       eello_turn6=0.0d0
10638       j=i+4
10639       k=i+1
10640       l=i+3
10641       iti=itype2loc(itype(i))
10642       itk=itype2loc(itype(k))
10643       itk1=itype2loc(itype(k+1))
10644       itl=itype2loc(itype(l))
10645       itj=itype2loc(itype(j))
10646 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10647 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10648 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10649 cd        eello6=0.0d0
10650 cd        return
10651 cd      endif
10652 cd      write (iout,*)
10653 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10654 cd     &   ' and',k,l
10655 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10656       do iii=1,2
10657         do kkk=1,5
10658           do lll=1,3
10659             derx_turn(lll,kkk,iii)=0.0d0
10660           enddo
10661         enddo
10662       enddo
10663 cd      eij=1.0d0
10664 cd      ekl=1.0d0
10665 cd      ekont=1.0d0
10666       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10667 cd      eello6_5=0.0d0
10668 cd      write (2,*) 'eello6_5',eello6_5
10669 #ifdef MOMENT
10670       call transpose2(AEA(1,1,1),auxmat(1,1))
10671       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10672       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10673       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10674 #endif
10675       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10676       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10677       s2 = scalar2(b1(1,k),vtemp1(1))
10678 #ifdef MOMENT
10679       call transpose2(AEA(1,1,2),atemp(1,1))
10680       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10681       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10682       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10683 #endif
10684       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10685       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10686       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10687 #ifdef MOMENT
10688       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10689       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10690       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10691       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10692       ss13 = scalar2(b1(1,k),vtemp4(1))
10693       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10694 #endif
10695 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10696 c      s1=0.0d0
10697 c      s2=0.0d0
10698 c      s8=0.0d0
10699 c      s12=0.0d0
10700 c      s13=0.0d0
10701       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10702 C Derivatives in gamma(i+2)
10703       s1d =0.0d0
10704       s8d =0.0d0
10705 #ifdef MOMENT
10706       call transpose2(AEA(1,1,1),auxmatd(1,1))
10707       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10708       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10709       call transpose2(AEAderg(1,1,2),atempd(1,1))
10710       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10711       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10712 #endif
10713       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10714       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10715       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10716 c      s1d=0.0d0
10717 c      s2d=0.0d0
10718 c      s8d=0.0d0
10719 c      s12d=0.0d0
10720 c      s13d=0.0d0
10721       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10722 C Derivatives in gamma(i+3)
10723 #ifdef MOMENT
10724       call transpose2(AEA(1,1,1),auxmatd(1,1))
10725       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10726       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10727       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10728 #endif
10729       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10730       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10731       s2d = scalar2(b1(1,k),vtemp1d(1))
10732 #ifdef MOMENT
10733       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10734       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10735 #endif
10736       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10737 #ifdef MOMENT
10738       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10739       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10740       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10741 #endif
10742 c      s1d=0.0d0
10743 c      s2d=0.0d0
10744 c      s8d=0.0d0
10745 c      s12d=0.0d0
10746 c      s13d=0.0d0
10747 #ifdef MOMENT
10748       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10749      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10750 #else
10751       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10752      &               -0.5d0*ekont*(s2d+s12d)
10753 #endif
10754 C Derivatives in gamma(i+4)
10755       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10756       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10757       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10758 #ifdef MOMENT
10759       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10760       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10761       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10762 #endif
10763 c      s1d=0.0d0
10764 c      s2d=0.0d0
10765 c      s8d=0.0d0
10766 C      s12d=0.0d0
10767 c      s13d=0.0d0
10768 #ifdef MOMENT
10769       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10770 #else
10771       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10772 #endif
10773 C Derivatives in gamma(i+5)
10774 #ifdef MOMENT
10775       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10776       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10777       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10778 #endif
10779       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10780       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10781       s2d = scalar2(b1(1,k),vtemp1d(1))
10782 #ifdef MOMENT
10783       call transpose2(AEA(1,1,2),atempd(1,1))
10784       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10785       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10786 #endif
10787       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10788       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10789 #ifdef MOMENT
10790       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10791       ss13d = scalar2(b1(1,k),vtemp4d(1))
10792       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10793 #endif
10794 c      s1d=0.0d0
10795 c      s2d=0.0d0
10796 c      s8d=0.0d0
10797 c      s12d=0.0d0
10798 c      s13d=0.0d0
10799 #ifdef MOMENT
10800       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10801      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10802 #else
10803       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10804      &               -0.5d0*ekont*(s2d+s12d)
10805 #endif
10806 C Cartesian derivatives
10807       do iii=1,2
10808         do kkk=1,5
10809           do lll=1,3
10810 #ifdef MOMENT
10811             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10812             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10813             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10814 #endif
10815             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10816             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10817      &          vtemp1d(1))
10818             s2d = scalar2(b1(1,k),vtemp1d(1))
10819 #ifdef MOMENT
10820             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10821             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10822             s8d = -(atempd(1,1)+atempd(2,2))*
10823      &           scalar2(cc(1,1,itl),vtemp2(1))
10824 #endif
10825             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10826      &           auxmatd(1,1))
10827             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10828             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10829 c      s1d=0.0d0
10830 c      s2d=0.0d0
10831 c      s8d=0.0d0
10832 c      s12d=0.0d0
10833 c      s13d=0.0d0
10834 #ifdef MOMENT
10835             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10836      &        - 0.5d0*(s1d+s2d)
10837 #else
10838             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10839      &        - 0.5d0*s2d
10840 #endif
10841 #ifdef MOMENT
10842             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10843      &        - 0.5d0*(s8d+s12d)
10844 #else
10845             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10846      &        - 0.5d0*s12d
10847 #endif
10848           enddo
10849         enddo
10850       enddo
10851 #ifdef MOMENT
10852       do kkk=1,5
10853         do lll=1,3
10854           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10855      &      achuj_tempd(1,1))
10856           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10857           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10858           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10859           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10860           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10861      &      vtemp4d(1))
10862           ss13d = scalar2(b1(1,k),vtemp4d(1))
10863           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10864           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10865         enddo
10866       enddo
10867 #endif
10868 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10869 cd     &  16*eel_turn6_num
10870 cd      goto 1112
10871       if (j.lt.nres-1) then
10872         j1=j+1
10873         j2=j-1
10874       else
10875         j1=j-1
10876         j2=j-2
10877       endif
10878       if (l.lt.nres-1) then
10879         l1=l+1
10880         l2=l-1
10881       else
10882         l1=l-1
10883         l2=l-2
10884       endif
10885       do ll=1,3
10886 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10887 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10888 cgrad        ghalf=0.5d0*ggg1(ll)
10889 cd        ghalf=0.0d0
10890         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10891         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10892         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10893      &    +ekont*derx_turn(ll,2,1)
10894         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10895         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10896      &    +ekont*derx_turn(ll,4,1)
10897         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10898         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10899         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10900 cgrad        ghalf=0.5d0*ggg2(ll)
10901 cd        ghalf=0.0d0
10902         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10903      &    +ekont*derx_turn(ll,2,2)
10904         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10905         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10906      &    +ekont*derx_turn(ll,4,2)
10907         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10908         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10909         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10910       enddo
10911 cd      goto 1112
10912 cgrad      do m=i+1,j-1
10913 cgrad        do ll=1,3
10914 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10915 cgrad        enddo
10916 cgrad      enddo
10917 cgrad      do m=k+1,l-1
10918 cgrad        do ll=1,3
10919 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10920 cgrad        enddo
10921 cgrad      enddo
10922 cgrad1112  continue
10923 cgrad      do m=i+2,j2
10924 cgrad        do ll=1,3
10925 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10926 cgrad        enddo
10927 cgrad      enddo
10928 cgrad      do m=k+2,l2
10929 cgrad        do ll=1,3
10930 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10931 cgrad        enddo
10932 cgrad      enddo
10933 cd      do iii=1,nres-3
10934 cd        write (2,*) iii,g_corr6_loc(iii)
10935 cd      enddo
10936       eello_turn6=ekont*eel_turn6
10937 cd      write (2,*) 'ekont',ekont
10938 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10939       return
10940       end
10941
10942 C-----------------------------------------------------------------------------
10943       double precision function scalar(u,v)
10944 !DIR$ INLINEALWAYS scalar
10945 #ifndef OSF
10946 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10947 #endif
10948       implicit none
10949       double precision u(3),v(3)
10950 cd      double precision sc
10951 cd      integer i
10952 cd      sc=0.0d0
10953 cd      do i=1,3
10954 cd        sc=sc+u(i)*v(i)
10955 cd      enddo
10956 cd      scalar=sc
10957
10958       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10959       return
10960       end
10961 crc-------------------------------------------------
10962       SUBROUTINE MATVEC2(A1,V1,V2)
10963 !DIR$ INLINEALWAYS MATVEC2
10964 #ifndef OSF
10965 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10966 #endif
10967       implicit real*8 (a-h,o-z)
10968       include 'DIMENSIONS'
10969       DIMENSION A1(2,2),V1(2),V2(2)
10970 c      DO 1 I=1,2
10971 c        VI=0.0
10972 c        DO 3 K=1,2
10973 c    3     VI=VI+A1(I,K)*V1(K)
10974 c        Vaux(I)=VI
10975 c    1 CONTINUE
10976
10977       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10978       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10979
10980       v2(1)=vaux1
10981       v2(2)=vaux2
10982       END
10983 C---------------------------------------
10984       SUBROUTINE MATMAT2(A1,A2,A3)
10985 #ifndef OSF
10986 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10987 #endif
10988       implicit real*8 (a-h,o-z)
10989       include 'DIMENSIONS'
10990       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10991 c      DIMENSION AI3(2,2)
10992 c        DO  J=1,2
10993 c          A3IJ=0.0
10994 c          DO K=1,2
10995 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10996 c          enddo
10997 c          A3(I,J)=A3IJ
10998 c       enddo
10999 c      enddo
11000
11001       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11002       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11003       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11004       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11005
11006       A3(1,1)=AI3_11
11007       A3(2,1)=AI3_21
11008       A3(1,2)=AI3_12
11009       A3(2,2)=AI3_22
11010       END
11011
11012 c-------------------------------------------------------------------------
11013       double precision function scalar2(u,v)
11014 !DIR$ INLINEALWAYS scalar2
11015       implicit none
11016       double precision u(2),v(2)
11017       double precision sc
11018       integer i
11019       scalar2=u(1)*v(1)+u(2)*v(2)
11020       return
11021       end
11022
11023 C-----------------------------------------------------------------------------
11024
11025       subroutine transpose2(a,at)
11026 !DIR$ INLINEALWAYS transpose2
11027 #ifndef OSF
11028 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11029 #endif
11030       implicit none
11031       double precision a(2,2),at(2,2)
11032       at(1,1)=a(1,1)
11033       at(1,2)=a(2,1)
11034       at(2,1)=a(1,2)
11035       at(2,2)=a(2,2)
11036       return
11037       end
11038 c--------------------------------------------------------------------------
11039       subroutine transpose(n,a,at)
11040       implicit none
11041       integer n,i,j
11042       double precision a(n,n),at(n,n)
11043       do i=1,n
11044         do j=1,n
11045           at(j,i)=a(i,j)
11046         enddo
11047       enddo
11048       return
11049       end
11050 C---------------------------------------------------------------------------
11051       subroutine prodmat3(a1,a2,kk,transp,prod)
11052 !DIR$ INLINEALWAYS prodmat3
11053 #ifndef OSF
11054 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11055 #endif
11056       implicit none
11057       integer i,j
11058       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11059       logical transp
11060 crc      double precision auxmat(2,2),prod_(2,2)
11061
11062       if (transp) then
11063 crc        call transpose2(kk(1,1),auxmat(1,1))
11064 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11065 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11066
11067            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11068      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11069            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11070      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11071            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11072      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11073            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11074      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11075
11076       else
11077 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11078 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11079
11080            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11081      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11082            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11083      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11084            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11085      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11086            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11087      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11088
11089       endif
11090 c      call transpose2(a2(1,1),a2t(1,1))
11091
11092 crc      print *,transp
11093 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11094 crc      print *,((prod(i,j),i=1,2),j=1,2)
11095
11096       return
11097       end
11098 CCC----------------------------------------------
11099       subroutine Eliptransfer(eliptran)
11100       implicit real*8 (a-h,o-z)
11101       include 'DIMENSIONS'
11102       include 'COMMON.GEO'
11103       include 'COMMON.VAR'
11104       include 'COMMON.LOCAL'
11105       include 'COMMON.CHAIN'
11106       include 'COMMON.DERIV'
11107       include 'COMMON.NAMES'
11108       include 'COMMON.INTERACT'
11109       include 'COMMON.IOUNITS'
11110       include 'COMMON.CALC'
11111       include 'COMMON.CONTROL'
11112       include 'COMMON.SPLITELE'
11113       include 'COMMON.SBRIDGE'
11114 C this is done by Adasko
11115 C      print *,"wchodze"
11116 C structure of box:
11117 C      water
11118 C--bordliptop-- buffore starts
11119 C--bufliptop--- here true lipid starts
11120 C      lipid
11121 C--buflipbot--- lipid ends buffore starts
11122 C--bordlipbot--buffore ends
11123       eliptran=0.0
11124       do i=ilip_start,ilip_end
11125 C       do i=1,1
11126         if (itype(i).eq.ntyp1) cycle
11127
11128         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11129         if (positi.le.0.0) positi=positi+boxzsize
11130 C        print *,i
11131 C first for peptide groups
11132 c for each residue check if it is in lipid or lipid water border area
11133        if ((positi.gt.bordlipbot)
11134      &.and.(positi.lt.bordliptop)) then
11135 C the energy transfer exist
11136         if (positi.lt.buflipbot) then
11137 C what fraction I am in
11138          fracinbuf=1.0d0-
11139      &        ((positi-bordlipbot)/lipbufthick)
11140 C lipbufthick is thickenes of lipid buffore
11141          sslip=sscalelip(fracinbuf)
11142          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11143          eliptran=eliptran+sslip*pepliptran
11144          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11145          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11146 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11147
11148 C        print *,"doing sccale for lower part"
11149 C         print *,i,sslip,fracinbuf,ssgradlip
11150         elseif (positi.gt.bufliptop) then
11151          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11152          sslip=sscalelip(fracinbuf)
11153          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11154          eliptran=eliptran+sslip*pepliptran
11155          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11156          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11157 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11158 C          print *, "doing sscalefor top part"
11159 C         print *,i,sslip,fracinbuf,ssgradlip
11160         else
11161          eliptran=eliptran+pepliptran
11162 C         print *,"I am in true lipid"
11163         endif
11164 C       else
11165 C       eliptran=elpitran+0.0 ! I am in water
11166        endif
11167        enddo
11168 C       print *, "nic nie bylo w lipidzie?"
11169 C now multiply all by the peptide group transfer factor
11170 C       eliptran=eliptran*pepliptran
11171 C now the same for side chains
11172 CV       do i=1,1
11173        do i=ilip_start,ilip_end
11174         if (itype(i).eq.ntyp1) cycle
11175         positi=(mod(c(3,i+nres),boxzsize))
11176         if (positi.le.0) positi=positi+boxzsize
11177 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11178 c for each residue check if it is in lipid or lipid water border area
11179 C       respos=mod(c(3,i+nres),boxzsize)
11180 C       print *,positi,bordlipbot,buflipbot
11181        if ((positi.gt.bordlipbot)
11182      & .and.(positi.lt.bordliptop)) then
11183 C the energy transfer exist
11184         if (positi.lt.buflipbot) then
11185          fracinbuf=1.0d0-
11186      &     ((positi-bordlipbot)/lipbufthick)
11187 C lipbufthick is thickenes of lipid buffore
11188          sslip=sscalelip(fracinbuf)
11189          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11190          eliptran=eliptran+sslip*liptranene(itype(i))
11191          gliptranx(3,i)=gliptranx(3,i)
11192      &+ssgradlip*liptranene(itype(i))
11193          gliptranc(3,i-1)= gliptranc(3,i-1)
11194      &+ssgradlip*liptranene(itype(i))
11195 C         print *,"doing sccale for lower part"
11196         elseif (positi.gt.bufliptop) then
11197          fracinbuf=1.0d0-
11198      &((bordliptop-positi)/lipbufthick)
11199          sslip=sscalelip(fracinbuf)
11200          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11201          eliptran=eliptran+sslip*liptranene(itype(i))
11202          gliptranx(3,i)=gliptranx(3,i)
11203      &+ssgradlip*liptranene(itype(i))
11204          gliptranc(3,i-1)= gliptranc(3,i-1)
11205      &+ssgradlip*liptranene(itype(i))
11206 C          print *, "doing sscalefor top part",sslip,fracinbuf
11207         else
11208          eliptran=eliptran+liptranene(itype(i))
11209 C         print *,"I am in true lipid"
11210         endif
11211         endif ! if in lipid or buffor
11212 C       else
11213 C       eliptran=elpitran+0.0 ! I am in water
11214        enddo
11215        return
11216        end
11217 C---------------------------------------------------------
11218 C AFM soubroutine for constant force
11219        subroutine AFMforce(Eafmforce)
11220        implicit real*8 (a-h,o-z)
11221       include 'DIMENSIONS'
11222       include 'COMMON.GEO'
11223       include 'COMMON.VAR'
11224       include 'COMMON.LOCAL'
11225       include 'COMMON.CHAIN'
11226       include 'COMMON.DERIV'
11227       include 'COMMON.NAMES'
11228       include 'COMMON.INTERACT'
11229       include 'COMMON.IOUNITS'
11230       include 'COMMON.CALC'
11231       include 'COMMON.CONTROL'
11232       include 'COMMON.SPLITELE'
11233       include 'COMMON.SBRIDGE'
11234       real*8 diffafm(3)
11235       dist=0.0d0
11236       Eafmforce=0.0d0
11237       do i=1,3
11238       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11239       dist=dist+diffafm(i)**2
11240       enddo
11241       dist=dsqrt(dist)
11242       Eafmforce=-forceAFMconst*(dist-distafminit)
11243       do i=1,3
11244       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11245       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11246       enddo
11247 C      print *,'AFM',Eafmforce
11248       return
11249       end
11250 C---------------------------------------------------------
11251 C AFM subroutine with pseudoconstant velocity
11252        subroutine AFMvel(Eafmforce)
11253        implicit real*8 (a-h,o-z)
11254       include 'DIMENSIONS'
11255       include 'COMMON.GEO'
11256       include 'COMMON.VAR'
11257       include 'COMMON.LOCAL'
11258       include 'COMMON.CHAIN'
11259       include 'COMMON.DERIV'
11260       include 'COMMON.NAMES'
11261       include 'COMMON.INTERACT'
11262       include 'COMMON.IOUNITS'
11263       include 'COMMON.CALC'
11264       include 'COMMON.CONTROL'
11265       include 'COMMON.SPLITELE'
11266       include 'COMMON.SBRIDGE'
11267       real*8 diffafm(3)
11268 C Only for check grad COMMENT if not used for checkgrad
11269 C      totT=3.0d0
11270 C--------------------------------------------------------
11271 C      print *,"wchodze"
11272       dist=0.0d0
11273       Eafmforce=0.0d0
11274       do i=1,3
11275       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11276       dist=dist+diffafm(i)**2
11277       enddo
11278       dist=dsqrt(dist)
11279       Eafmforce=0.5d0*forceAFMconst
11280      & *(distafminit+totTafm*velAFMconst-dist)**2
11281 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11282       do i=1,3
11283       gradafm(i,afmend-1)=-forceAFMconst*
11284      &(distafminit+totTafm*velAFMconst-dist)
11285      &*diffafm(i)/dist
11286       gradafm(i,afmbeg-1)=forceAFMconst*
11287      &(distafminit+totTafm*velAFMconst-dist)
11288      &*diffafm(i)/dist
11289       enddo
11290 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11291       return
11292       end
11293 C-----------------------------------------------------------
11294 C first for shielding is setting of function of side-chains
11295        subroutine set_shield_fac
11296       implicit real*8 (a-h,o-z)
11297       include 'DIMENSIONS'
11298       include 'COMMON.CHAIN'
11299       include 'COMMON.DERIV'
11300       include 'COMMON.IOUNITS'
11301       include 'COMMON.SHIELD'
11302       include 'COMMON.INTERACT'
11303 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11304       double precision div77_81/0.974996043d0/,
11305      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11306
11307 C the vector between center of side_chain and peptide group
11308        double precision pep_side(3),long,side_calf(3),
11309      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11310      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11311 C the line belowe needs to be changed for FGPROC>1
11312       do i=1,nres-1
11313       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11314       ishield_list(i)=0
11315 Cif there two consequtive dummy atoms there is no peptide group between them
11316 C the line below has to be changed for FGPROC>1
11317       VolumeTotal=0.0
11318       do k=1,nres
11319        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11320        dist_pep_side=0.0
11321        dist_side_calf=0.0
11322        do j=1,3
11323 C first lets set vector conecting the ithe side-chain with kth side-chain
11324       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11325 C      pep_side(j)=2.0d0
11326 C and vector conecting the side-chain with its proper calfa
11327       side_calf(j)=c(j,k+nres)-c(j,k)
11328 C      side_calf(j)=2.0d0
11329       pept_group(j)=c(j,i)-c(j,i+1)
11330 C lets have their lenght
11331       dist_pep_side=pep_side(j)**2+dist_pep_side
11332       dist_side_calf=dist_side_calf+side_calf(j)**2
11333       dist_pept_group=dist_pept_group+pept_group(j)**2
11334       enddo
11335        dist_pep_side=dsqrt(dist_pep_side)
11336        dist_pept_group=dsqrt(dist_pept_group)
11337        dist_side_calf=dsqrt(dist_side_calf)
11338       do j=1,3
11339         pep_side_norm(j)=pep_side(j)/dist_pep_side
11340         side_calf_norm(j)=dist_side_calf
11341       enddo
11342 C now sscale fraction
11343        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11344 C       print *,buff_shield,"buff"
11345 C now sscale
11346         if (sh_frac_dist.le.0.0) cycle
11347 C If we reach here it means that this side chain reaches the shielding sphere
11348 C Lets add him to the list for gradient
11349         ishield_list(i)=ishield_list(i)+1
11350 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11351 C this list is essential otherwise problem would be O3
11352         shield_list(ishield_list(i),i)=k
11353 C Lets have the sscale value
11354         if (sh_frac_dist.gt.1.0) then
11355          scale_fac_dist=1.0d0
11356          do j=1,3
11357          sh_frac_dist_grad(j)=0.0d0
11358          enddo
11359         else
11360          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11361      &                   *(2.0*sh_frac_dist-3.0d0)
11362          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11363      &                  /dist_pep_side/buff_shield*0.5
11364 C remember for the final gradient multiply sh_frac_dist_grad(j)
11365 C for side_chain by factor -2 !
11366          do j=1,3
11367          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11368 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11369 C     &                    sh_frac_dist_grad(j)
11370          enddo
11371         endif
11372 C        if ((i.eq.3).and.(k.eq.2)) then
11373 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11374 C     & ,"TU"
11375 C        endif
11376
11377 C this is what is now we have the distance scaling now volume...
11378       short=short_r_sidechain(itype(k))
11379       long=long_r_sidechain(itype(k))
11380       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11381 C now costhet_grad
11382 C       costhet=0.0d0
11383        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11384 C       costhet_fac=0.0d0
11385        do j=1,3
11386          costhet_grad(j)=costhet_fac*pep_side(j)
11387        enddo
11388 C remember for the final gradient multiply costhet_grad(j)
11389 C for side_chain by factor -2 !
11390 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11391 C pep_side0pept_group is vector multiplication
11392       pep_side0pept_group=0.0
11393       do j=1,3
11394       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11395       enddo
11396       cosalfa=(pep_side0pept_group/
11397      & (dist_pep_side*dist_side_calf))
11398       fac_alfa_sin=1.0-cosalfa**2
11399       fac_alfa_sin=dsqrt(fac_alfa_sin)
11400       rkprim=fac_alfa_sin*(long-short)+short
11401 C now costhet_grad
11402        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11403        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11404
11405        do j=1,3
11406          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11407      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11408      &*(long-short)/fac_alfa_sin*cosalfa/
11409      &((dist_pep_side*dist_side_calf))*
11410      &((side_calf(j))-cosalfa*
11411      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11412
11413         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11414      &*(long-short)/fac_alfa_sin*cosalfa
11415      &/((dist_pep_side*dist_side_calf))*
11416      &(pep_side(j)-
11417      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11418        enddo
11419
11420       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11421      &                    /VSolvSphere_div
11422      &                    *wshield
11423 C now the gradient...
11424 C grad_shield is gradient of Calfa for peptide groups
11425 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11426 C     &               costhet,cosphi
11427 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11428 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11429       do j=1,3
11430       grad_shield(j,i)=grad_shield(j,i)
11431 C gradient po skalowaniu
11432      &                +(sh_frac_dist_grad(j)
11433 C  gradient po costhet
11434      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11435      &-scale_fac_dist*(cosphi_grad_long(j))
11436      &/(1.0-cosphi) )*div77_81
11437      &*VofOverlap
11438 C grad_shield_side is Cbeta sidechain gradient
11439       grad_shield_side(j,ishield_list(i),i)=
11440      &        (sh_frac_dist_grad(j)*-2.0d0
11441      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11442      &       +scale_fac_dist*(cosphi_grad_long(j))
11443      &        *2.0d0/(1.0-cosphi))
11444      &        *div77_81*VofOverlap
11445
11446        grad_shield_loc(j,ishield_list(i),i)=
11447      &   scale_fac_dist*cosphi_grad_loc(j)
11448      &        *2.0d0/(1.0-cosphi)
11449      &        *div77_81*VofOverlap
11450       enddo
11451       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11452       enddo
11453       fac_shield(i)=VolumeTotal*div77_81+div4_81
11454 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11455       enddo
11456       return
11457       end
11458 C--------------------------------------------------------------------------
11459       double precision function tschebyshev(m,n,x,y)
11460       implicit none
11461       include "DIMENSIONS"
11462       integer i,m,n
11463       double precision x(n),y,yy(0:maxvar),aux
11464 c Tschebyshev polynomial. Note that the first term is omitted
11465 c m=0: the constant term is included
11466 c m=1: the constant term is not included
11467       yy(0)=1.0d0
11468       yy(1)=y
11469       do i=2,n
11470         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11471       enddo
11472       aux=0.0d0
11473       do i=m,n
11474         aux=aux+x(i)*yy(i)
11475       enddo
11476       tschebyshev=aux
11477       return
11478       end
11479 C--------------------------------------------------------------------------
11480       double precision function gradtschebyshev(m,n,x,y)
11481       implicit none
11482       include "DIMENSIONS"
11483       integer i,m,n
11484       double precision x(n+1),y,yy(0:maxvar),aux
11485 c Tschebyshev polynomial. Note that the first term is omitted
11486 c m=0: the constant term is included
11487 c m=1: the constant term is not included
11488       yy(0)=1.0d0
11489       yy(1)=2.0d0*y
11490       do i=2,n
11491         yy(i)=2*y*yy(i-1)-yy(i-2)
11492       enddo
11493       aux=0.0d0
11494       do i=m,n
11495         aux=aux+x(i+1)*yy(i)*(i+1)
11496 C        print *, x(i+1),yy(i),i
11497       enddo
11498       gradtschebyshev=aux
11499       return
11500       end
11501 C------------------------------------------------------------------------
11502 C first for shielding is setting of function of side-chains
11503        subroutine set_shield_fac2
11504       implicit real*8 (a-h,o-z)
11505       include 'DIMENSIONS'
11506       include 'COMMON.CHAIN'
11507       include 'COMMON.DERIV'
11508       include 'COMMON.IOUNITS'
11509       include 'COMMON.SHIELD'
11510       include 'COMMON.INTERACT'
11511 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11512       double precision div77_81/0.974996043d0/,
11513      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11514
11515 C the vector between center of side_chain and peptide group
11516        double precision pep_side(3),long,side_calf(3),
11517      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11518      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11519 C the line belowe needs to be changed for FGPROC>1
11520       do i=1,nres-1
11521       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11522       ishield_list(i)=0
11523 Cif there two consequtive dummy atoms there is no peptide group between them
11524 C the line below has to be changed for FGPROC>1
11525       VolumeTotal=0.0
11526       do k=1,nres
11527        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11528        dist_pep_side=0.0
11529        dist_side_calf=0.0
11530        do j=1,3
11531 C first lets set vector conecting the ithe side-chain with kth side-chain
11532       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11533 C      pep_side(j)=2.0d0
11534 C and vector conecting the side-chain with its proper calfa
11535       side_calf(j)=c(j,k+nres)-c(j,k)
11536 C      side_calf(j)=2.0d0
11537       pept_group(j)=c(j,i)-c(j,i+1)
11538 C lets have their lenght
11539       dist_pep_side=pep_side(j)**2+dist_pep_side
11540       dist_side_calf=dist_side_calf+side_calf(j)**2
11541       dist_pept_group=dist_pept_group+pept_group(j)**2
11542       enddo
11543        dist_pep_side=dsqrt(dist_pep_side)
11544        dist_pept_group=dsqrt(dist_pept_group)
11545        dist_side_calf=dsqrt(dist_side_calf)
11546       do j=1,3
11547         pep_side_norm(j)=pep_side(j)/dist_pep_side
11548         side_calf_norm(j)=dist_side_calf
11549       enddo
11550 C now sscale fraction
11551        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11552 C       print *,buff_shield,"buff"
11553 C now sscale
11554         if (sh_frac_dist.le.0.0) cycle
11555 C If we reach here it means that this side chain reaches the shielding sphere
11556 C Lets add him to the list for gradient
11557         ishield_list(i)=ishield_list(i)+1
11558 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11559 C this list is essential otherwise problem would be O3
11560         shield_list(ishield_list(i),i)=k
11561 C Lets have the sscale value
11562         if (sh_frac_dist.gt.1.0) then
11563          scale_fac_dist=1.0d0
11564          do j=1,3
11565          sh_frac_dist_grad(j)=0.0d0
11566          enddo
11567         else
11568          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11569      &                   *(2.0d0*sh_frac_dist-3.0d0)
11570          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11571      &                  /dist_pep_side/buff_shield*0.5d0
11572 C remember for the final gradient multiply sh_frac_dist_grad(j)
11573 C for side_chain by factor -2 !
11574          do j=1,3
11575          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11576 C         sh_frac_dist_grad(j)=0.0d0
11577 C         scale_fac_dist=1.0d0
11578 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11579 C     &                    sh_frac_dist_grad(j)
11580          enddo
11581         endif
11582 C this is what is now we have the distance scaling now volume...
11583       short=short_r_sidechain(itype(k))
11584       long=long_r_sidechain(itype(k))
11585       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11586       sinthet=short/dist_pep_side*costhet
11587 C now costhet_grad
11588 C       costhet=0.6d0
11589 C       sinthet=0.8
11590        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11591 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11592 C     &             -short/dist_pep_side**2/costhet)
11593 C       costhet_fac=0.0d0
11594        do j=1,3
11595          costhet_grad(j)=costhet_fac*pep_side(j)
11596        enddo
11597 C remember for the final gradient multiply costhet_grad(j)
11598 C for side_chain by factor -2 !
11599 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11600 C pep_side0pept_group is vector multiplication
11601       pep_side0pept_group=0.0d0
11602       do j=1,3
11603       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11604       enddo
11605       cosalfa=(pep_side0pept_group/
11606      & (dist_pep_side*dist_side_calf))
11607       fac_alfa_sin=1.0d0-cosalfa**2
11608       fac_alfa_sin=dsqrt(fac_alfa_sin)
11609       rkprim=fac_alfa_sin*(long-short)+short
11610 C      rkprim=short
11611
11612 C now costhet_grad
11613        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11614 C       cosphi=0.6
11615        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11616        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11617      &      dist_pep_side**2)
11618 C       sinphi=0.8
11619        do j=1,3
11620          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11621      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11622      &*(long-short)/fac_alfa_sin*cosalfa/
11623      &((dist_pep_side*dist_side_calf))*
11624      &((side_calf(j))-cosalfa*
11625      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11626 C       cosphi_grad_long(j)=0.0d0
11627         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11628      &*(long-short)/fac_alfa_sin*cosalfa
11629      &/((dist_pep_side*dist_side_calf))*
11630      &(pep_side(j)-
11631      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11632 C       cosphi_grad_loc(j)=0.0d0
11633        enddo
11634 C      print *,sinphi,sinthet
11635       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11636      &                    /VSolvSphere_div
11637 C     &                    *wshield
11638 C now the gradient...
11639       do j=1,3
11640       grad_shield(j,i)=grad_shield(j,i)
11641 C gradient po skalowaniu
11642      &                +(sh_frac_dist_grad(j)*VofOverlap
11643 C  gradient po costhet
11644      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11645      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11646      &       sinphi/sinthet*costhet*costhet_grad(j)
11647      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11648      & )*wshield
11649 C grad_shield_side is Cbeta sidechain gradient
11650       grad_shield_side(j,ishield_list(i),i)=
11651      &        (sh_frac_dist_grad(j)*-2.0d0
11652      &        *VofOverlap
11653      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11654      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11655      &       sinphi/sinthet*costhet*costhet_grad(j)
11656      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11657      &       )*wshield
11658
11659        grad_shield_loc(j,ishield_list(i),i)=
11660      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11661      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11662      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11663      &        ))
11664      &        *wshield
11665       enddo
11666       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11667       enddo
11668       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11669 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11670       enddo
11671       return
11672       end
11673