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           weights_(22)=wtube
  59
  60 C FG Master broadcasts the WEIGHTS_ array
  61           call MPI_Bcast(weights_(1),n_ene,
  62      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  63         else
  64 C FG slaves receive the WEIGHTS array
  65           call MPI_Bcast(weights(1),n_ene,
  66      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  67           wsc=weights(1)
  68           wscp=weights(2)
  69           welec=weights(3)
  70           wcorr=weights(4)
  71           wcorr5=weights(5)
  72           wcorr6=weights(6)
  73           wel_loc=weights(7)
  74           wturn3=weights(8)
  75           wturn4=weights(9)
  76           wturn6=weights(10)
  77           wang=weights(11)
  78           wscloc=weights(12)
  79           wtor=weights(13)
  80           wtor_d=weights(14)
  81           wstrain=weights(15)
  82           wvdwpp=weights(16)
  83           wbond=weights(17)
  84           scal14=weights(18)
  85           wsccor=weights(21)
  86           wtube=weights(22)
  87         endif
  88         time_Bcast=time_Bcast+MPI_Wtime()-time00
  89         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  90 c        call chainbuild_cart
  91       endif
  92 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  93 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  94 #else
  95 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  96 c        call int_from_cart1(.false.)
  97 c      endif
  98 #endif
  99 #ifdef TIMING
 100       time00=MPI_Wtime()
 101 #endif
 102 C
 103 C Compute the side-chain and electrostatic interaction energy
 104 C
 105 C      print *,ipot
 106       goto (101,102,103,104,105,106) ipot
 107 C Lennard-Jones potential.
 108   101 call elj(evdw)
 109 cd    print '(a)','Exit ELJ'
 110       goto 107
 111 C Lennard-Jones-Kihara potential (shifted).
 112   102 call eljk(evdw)
 113       goto 107
 114 C Berne-Pechukas potential (dilated LJ, angular dependence).
 115   103 call ebp(evdw)
 116       goto 107
 117 C Gay-Berne potential (shifted LJ, angular dependence).
 118   104 call egb(evdw)
 119 C      print *,"bylem w egb"
 120       goto 107
 121 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 122   105 call egbv(evdw)
 123       goto 107
 124 C Soft-sphere potential
 125   106 call e_softsphere(evdw)
 126 C
 127 C Calculate electrostatic (H-bonding) energy of the main chain.
 128 C
 129   107 continue
 130 cmc
 131 cmc Sep-06: egb takes care of dynamic ss bonds too
 132 cmc
 133 c      if (dyn_ss) call dyn_set_nss
 134
 135 c      print *,"Processor",myrank," computed USCSC"
 136 #ifdef TIMING
 137       time01=MPI_Wtime()
 138 #endif
 139       call vec_and_deriv
 140 #ifdef TIMING
 141       time_vec=time_vec+MPI_Wtime()-time01
 142 #endif
 143 C Introduction of shielding effect first for each peptide group
 144 C the shielding factor is set this factor is describing how each
 145 C peptide group is shielded by side-chains
 146 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 147 C      write (iout,*) "shield_mode",shield_mode
 148       if (shield_mode.eq.1) then
 149        call set_shield_fac
 150       else if  (shield_mode.eq.2) then
 151        call set_shield_fac2
 152       endif
 153 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 154       if (ipot.lt.6) then
 155 #ifdef SPLITELE
 156          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 160 #else
 161          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 162      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 163      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 164      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 165 #endif
 166             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 167          else
 168             ees=0.0d0
 169             evdw1=0.0d0
 170             eel_loc=0.0d0
 171             eello_turn3=0.0d0
 172             eello_turn4=0.0d0
 173          endif
 174       else
 175         write (iout,*) "Soft-spheer ELEC potential"
 176 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 177 c     &   eello_turn4)
 178       endif
 179 c      print *,"Processor",myrank," computed UELEC"
 180 C
 181 C Calculate excluded-volume interaction energy between peptide groups
 182 C and side chains.
 183 C
 184       if (ipot.lt.6) then
 185        if(wscp.gt.0d0) then
 186         call escp(evdw2,evdw2_14)
 187        else
 188         evdw2=0
 189         evdw2_14=0
 190        endif
 191       else
 192 c        write (iout,*) "Soft-sphere SCP potential"
 193         call escp_soft_sphere(evdw2,evdw2_14)
 194       endif
 195 c
 196 c Calculate the bond-stretching energy
 197 c
 198       call ebond(estr)
 199 C
 200 C Calculate the disulfide-bridge and other energy and the contributions
 201 C from other distance constraints.
 202 cd    print *,'Calling EHPB'
 203       call edis(ehpb)
 204 cd    print *,'EHPB exitted succesfully.'
 205 C
 206 C Calculate the virtual-bond-angle energy.
 207 C
 208       if (wang.gt.0d0) then
 209        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 210         call ebend(ebe,ethetacnstr)
 211         endif
 212 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 213 C energy function
 214        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 215          call ebend_kcc(ebe,ethetacnstr)
 216         endif
 217       else
 218         ebe=0
 219         ethetacnstr=0
 220       endif
 221 c      print *,"Processor",myrank," computed UB"
 222 C
 223 C Calculate the SC local energy.
 224 C
 225 C      print *,"TU DOCHODZE?"
 226       call esc(escloc)
 227 c      print *,"Processor",myrank," computed USC"
 228 C
 229 C Calculate the virtual-bond torsional energy.
 230 C
 231 cd    print *,'nterm=',nterm
 232 C      print *,"tor",tor_mode
 233       if (wtor.gt.0) then
 234        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 235        call etor(etors,edihcnstr)
 236        endif
 237 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 238 C energy function
 239        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 240        call etor_kcc(etors,edihcnstr)
 241        endif
 242       else
 243        etors=0
 244        edihcnstr=0
 245       endif
 246 c      print *,"Processor",myrank," computed Utor"
 247 C
 248 C 6/23/01 Calculate double-torsional energy
 249 C
 250       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 251        call etor_d(etors_d)
 252       else
 253        etors_d=0
 254       endif
 255 c      print *,"Processor",myrank," computed Utord"
 256 C
 257 C 21/5/07 Calculate local sicdechain correlation energy
 258 C
 259       if (wsccor.gt.0.0d0) then
 260         call eback_sc_corr(esccor)
 261       else
 262         esccor=0.0d0
 263       endif
 264 C      print *,"PRZED MULIt"
 265 c      print *,"Processor",myrank," computed Usccorr"
 266 C
 267 C 12/1/95 Multi-body terms
 268 C
 269       n_corr=0
 270       n_corr1=0
 271       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 272      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 273          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 274 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 275 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 276       else
 277          ecorr=0.0d0
 278          ecorr5=0.0d0
 279          ecorr6=0.0d0
 280          eturn6=0.0d0
 281       endif
 282       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 283          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 284 cd         write (iout,*) "multibody_hb ecorr",ecorr
 285       endif
 286 c      print *,"Processor",myrank," computed Ucorr"
 287 C
 288 C If performing constraint dynamics, call the constraint energy
 289 C  after the equilibration time
 290       if(usampl.and.totT.gt.eq_time) then
 291          call EconstrQ
 292          call Econstr_back
 293       else
 294          Uconst=0.0d0
 295          Uconst_back=0.0d0
 296       endif
 297 C 01/27/2015 added by adasko
 298 C the energy component below is energy transfer into lipid environment
 299 C based on partition function
 300 C      print *,"przed lipidami"
 301       if (wliptran.gt.0) then
 302         call Eliptransfer(eliptran)
 303       endif
 304 C      print *,"za lipidami"
 305       if (AFMlog.gt.0) then
 306         call AFMforce(Eafmforce)
 307       else if (selfguide.gt.0) then
 308         call AFMvel(Eafmforce)
 309       endif
 310       if (TUBElog.gt.0) then
 311 C      print *,"just before call"
 312         call calctube(Etube)
 313        else
 314        Etube=0.0d0
 315        endif
 316
 317 #ifdef TIMING
 318       time_enecalc=time_enecalc+MPI_Wtime()-time00
 319 #endif
 320 c      print *,"Processor",myrank," computed Uconstr"
 321 #ifdef TIMING
 322       time00=MPI_Wtime()
 323 #endif
 324 c
 325 C Sum the energies
 326 C
 327       energia(1)=evdw
 328 #ifdef SCP14
 329       energia(2)=evdw2-evdw2_14
 330       energia(18)=evdw2_14
 331 #else
 332       energia(2)=evdw2
 333       energia(18)=0.0d0
 334 #endif
 335 #ifdef SPLITELE
 336       energia(3)=ees
 337       energia(16)=evdw1
 338 #else
 339       energia(3)=ees+evdw1
 340       energia(16)=0.0d0
 341 #endif
 342       energia(4)=ecorr
 343       energia(5)=ecorr5
 344       energia(6)=ecorr6
 345       energia(7)=eel_loc
 346       energia(8)=eello_turn3
 347       energia(9)=eello_turn4
 348       energia(10)=eturn6
 349       energia(11)=ebe
 350       energia(12)=escloc
 351       energia(13)=etors
 352       energia(14)=etors_d
 353       energia(15)=ehpb
 354       energia(19)=edihcnstr
 355       energia(17)=estr
 356       energia(20)=Uconst+Uconst_back
 357       energia(21)=esccor
 358       energia(22)=eliptran
 359       energia(23)=Eafmforce
 360       energia(24)=ethetacnstr
 361       energia(25)=Etube
 362 c    Here are the energies showed per procesor if the are more processors
 363 c    per molecule then we sum it up in sum_energy subroutine
 364 c      print *," Processor",myrank," calls SUM_ENERGY"
 365       call sum_energy(energia,.true.)
 366       if (dyn_ss) call dyn_set_nss
 367 c      print *," Processor",myrank," left SUM_ENERGY"
 368 #ifdef TIMING
 369       time_sumene=time_sumene+MPI_Wtime()-time00
 370 #endif
 371       return
 372       end
 373 c-------------------------------------------------------------------------------
 374       subroutine sum_energy(energia,reduce)
 375       implicit real*8 (a-h,o-z)
 376       include 'DIMENSIONS'
 377 #ifndef ISNAN
 378       external proc_proc
 379 #ifdef WINPGI
 380 cMS$ATTRIBUTES C ::  proc_proc
 381 #endif
 382 #endif
 383 #ifdef MPI
 384       include "mpif.h"
 385 #endif
 386       include 'COMMON.SETUP'
 387       include 'COMMON.IOUNITS'
 388       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 389       include 'COMMON.FFIELD'
 390       include 'COMMON.DERIV'
 391       include 'COMMON.INTERACT'
 392       include 'COMMON.SBRIDGE'
 393       include 'COMMON.CHAIN'
 394       include 'COMMON.VAR'
 395       include 'COMMON.CONTROL'
 396       include 'COMMON.TIME1'
 397       logical reduce
 398 #ifdef MPI
 399       if (nfgtasks.gt.1 .and. reduce) then
 400 #ifdef DEBUG
 401         write (iout,*) "energies before REDUCE"
 402         call enerprint(energia)
 403         call flush(iout)
 404 #endif
 405         do i=0,n_ene
 406           enebuff(i)=energia(i)
 407         enddo
 408         time00=MPI_Wtime()
 409         call MPI_Barrier(FG_COMM,IERR)
 410         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 411         time00=MPI_Wtime()
 412         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 413      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 414 #ifdef DEBUG
 415         write (iout,*) "energies after REDUCE"
 416         call enerprint(energia)
 417         call flush(iout)
 418 #endif
 419         time_Reduce=time_Reduce+MPI_Wtime()-time00
 420       endif
 421       if (fg_rank.eq.0) then
 422 #endif
 423       evdw=energia(1)
 424 #ifdef SCP14
 425       evdw2=energia(2)+energia(18)
 426       evdw2_14=energia(18)
 427 #else
 428       evdw2=energia(2)
 429 #endif
 430 #ifdef SPLITELE
 431       ees=energia(3)
 432       evdw1=energia(16)
 433 #else
 434       ees=energia(3)
 435       evdw1=0.0d0
 436 #endif
 437       ecorr=energia(4)
 438       ecorr5=energia(5)
 439       ecorr6=energia(6)
 440       eel_loc=energia(7)
 441       eello_turn3=energia(8)
 442       eello_turn4=energia(9)
 443       eturn6=energia(10)
 444       ebe=energia(11)
 445       escloc=energia(12)
 446       etors=energia(13)
 447       etors_d=energia(14)
 448       ehpb=energia(15)
 449       edihcnstr=energia(19)
 450       estr=energia(17)
 451       Uconst=energia(20)
 452       esccor=energia(21)
 453       eliptran=energia(22)
 454       Eafmforce=energia(23)
 455       ethetacnstr=energia(24)
 456       Etube=energia(25)
 457 #ifdef SPLITELE
 458       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 459      & +wang*ebe+wtor*etors+wscloc*escloc
 460      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 461      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 462      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 463      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 464      & +ethetacnstr+wtube*Etube
 465 #else
 466       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 467      & +wang*ebe+wtor*etors+wscloc*escloc
 468      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 469      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 470      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 471      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 472      & +Eafmforce
 473      & +ethetacnstr+wtube*Etube
 474 #endif
 475       energia(0)=etot
 476 c detecting NaNQ
 477 #ifdef ISNAN
 478 #ifdef AIX
 479       if (isnan(etot).ne.0) energia(0)=1.0d+99
 480 #else
 481       if (isnan(etot)) energia(0)=1.0d+99
 482 #endif
 483 #else
 484       i=0
 485 #ifdef WINPGI
 486       idumm=proc_proc(etot,i)
 487 #else
 488       call proc_proc(etot,i)
 489 #endif
 490       if(i.eq.1)energia(0)=1.0d+99
 491 #endif
 492 #ifdef MPI
 493       endif
 494 #endif
 495       return
 496       end
 497 c-------------------------------------------------------------------------------
 498       subroutine sum_gradient
 499       implicit real*8 (a-h,o-z)
 500       include 'DIMENSIONS'
 501 #ifndef ISNAN
 502       external proc_proc
 503 #ifdef WINPGI
 504 cMS$ATTRIBUTES C ::  proc_proc
 505 #endif
 506 #endif
 507 #ifdef MPI
 508       include 'mpif.h'
 509 #endif
 510       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 511      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 512      & ,gloc_scbuf(3,-1:maxres)
 513       include 'COMMON.SETUP'
 514       include 'COMMON.IOUNITS'
 515       include 'COMMON.FFIELD'
 516       include 'COMMON.DERIV'
 517       include 'COMMON.INTERACT'
 518       include 'COMMON.SBRIDGE'
 519       include 'COMMON.CHAIN'
 520       include 'COMMON.VAR'
 521       include 'COMMON.CONTROL'
 522       include 'COMMON.TIME1'
 523       include 'COMMON.MAXGRAD'
 524       include 'COMMON.SCCOR'
 525 #ifdef TIMING
 526       time01=MPI_Wtime()
 527 #endif
 528 #ifdef DEBUG
 529       write (iout,*) "sum_gradient gvdwc, gvdwx"
 530       do i=1,nres
 531         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 532      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef MPI
 537 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 538         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 539      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 540 #endif
 541 C
 542 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 543 C            in virtual-bond-vector coordinates
 544 C
 545 #ifdef DEBUG
 546 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 547 c      do i=1,nres-1
 548 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 549 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 550 c      enddo
 551 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 552 c      do i=1,nres-1
 553 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 554 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 555 c      enddo
 556       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 557       do i=1,nres
 558         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 559      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 560      &   g_corr5_loc(i)
 561       enddo
 562       call flush(iout)
 563 #endif
 564 #ifdef SPLITELE
 565       do i=0,nct
 566         do j=1,3
 567           gradbufc(j,i)=wsc*gvdwc(j,i)+
 568      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 569      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 570      &                wel_loc*gel_loc_long(j,i)+
 571      &                wcorr*gradcorr_long(j,i)+
 572      &                wcorr5*gradcorr5_long(j,i)+
 573      &                wcorr6*gradcorr6_long(j,i)+
 574      &                wturn6*gcorr6_turn_long(j,i)+
 575      &                wstrain*ghpbc(j,i)
 576      &                +wliptran*gliptranc(j,i)
 577      &                +gradafm(j,i)
 578      &                 +welec*gshieldc(j,i)
 579      &                 +wcorr*gshieldc_ec(j,i)
 580      &                 +wturn3*gshieldc_t3(j,i)
 581      &                 +wturn4*gshieldc_t4(j,i)
 582      &                 +wel_loc*gshieldc_ll(j,i)
 583      &                +wtube*gg_tube(j,i)
 584
 585
 586
 587         enddo
 588       enddo
 589 #else
 590       do i=0,nct
 591         do j=1,3
 592           gradbufc(j,i)=wsc*gvdwc(j,i)+
 593      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 594      &                welec*gelc_long(j,i)+
 595      &                wbond*gradb(j,i)+
 596      &                wel_loc*gel_loc_long(j,i)+
 597      &                wcorr*gradcorr_long(j,i)+
 598      &                wcorr5*gradcorr5_long(j,i)+
 599      &                wcorr6*gradcorr6_long(j,i)+
 600      &                wturn6*gcorr6_turn_long(j,i)+
 601      &                wstrain*ghpbc(j,i)
 602      &                +wliptran*gliptranc(j,i)
 603      &                +gradafm(j,i)
 604      &                 +welec*gshieldc(j,i)
 605      &                 +wcorr*gshieldc_ec(j,i)
 606      &                 +wturn4*gshieldc_t4(j,i)
 607      &                 +wel_loc*gshieldc_ll(j,i)
 608      &                +wtube*gg_tube(j,i)
 609
 610
 611
 612         enddo
 613       enddo
 614 #endif
 615 #ifdef MPI
 616       if (nfgtasks.gt.1) then
 617       time00=MPI_Wtime()
 618 #ifdef DEBUG
 619       write (iout,*) "gradbufc before allreduce"
 620       do i=1,nres
 621         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 622       enddo
 623       call flush(iout)
 624 #endif
 625       do i=0,nres
 626         do j=1,3
 627           gradbufc_sum(j,i)=gradbufc(j,i)
 628         enddo
 629       enddo
 630 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 631 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 632 c      time_reduce=time_reduce+MPI_Wtime()-time00
 633 #ifdef DEBUG
 634 c      write (iout,*) "gradbufc_sum after allreduce"
 635 c      do i=1,nres
 636 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 637 c      enddo
 638 c      call flush(iout)
 639 #endif
 640 #ifdef TIMING
 641 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 642 #endif
 643       do i=nnt,nres
 644         do k=1,3
 645           gradbufc(k,i)=0.0d0
 646         enddo
 647       enddo
 648 #ifdef DEBUG
 649       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 650       write (iout,*) (i," jgrad_start",jgrad_start(i),
 651      &                  " jgrad_end  ",jgrad_end(i),
 652      &                  i=igrad_start,igrad_end)
 653 #endif
 654 c
 655 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 656 c do not parallelize this part.
 657 c
 658 c      do i=igrad_start,igrad_end
 659 c        do j=jgrad_start(i),jgrad_end(i)
 660 c          do k=1,3
 661 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 662 c          enddo
 663 c        enddo
 664 c      enddo
 665       do j=1,3
 666         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 667       enddo
 668       do i=nres-2,-1,-1
 669         do j=1,3
 670           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 671         enddo
 672       enddo
 673 #ifdef DEBUG
 674       write (iout,*) "gradbufc after summing"
 675       do i=1,nres
 676         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 677       enddo
 678       call flush(iout)
 679 #endif
 680       else
 681 #endif
 682 #ifdef DEBUG
 683       write (iout,*) "gradbufc"
 684       do i=1,nres
 685         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 686       enddo
 687       call flush(iout)
 688 #endif
 689       do i=-1,nres
 690         do j=1,3
 691           gradbufc_sum(j,i)=gradbufc(j,i)
 692           gradbufc(j,i)=0.0d0
 693         enddo
 694       enddo
 695       do j=1,3
 696         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 697       enddo
 698       do i=nres-2,-1,-1
 699         do j=1,3
 700           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 701         enddo
 702       enddo
 703 c      do i=nnt,nres-1
 704 c        do k=1,3
 705 c          gradbufc(k,i)=0.0d0
 706 c        enddo
 707 c        do j=i+1,nres
 708 c          do k=1,3
 709 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 710 c          enddo
 711 c        enddo
 712 c      enddo
 713 #ifdef DEBUG
 714       write (iout,*) "gradbufc after summing"
 715       do i=1,nres
 716         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 717       enddo
 718       call flush(iout)
 719 #endif
 720 #ifdef MPI
 721       endif
 722 #endif
 723       do k=1,3
 724         gradbufc(k,nres)=0.0d0
 725       enddo
 726       do i=-1,nct
 727         do j=1,3
 728 #ifdef SPLITELE
 729 C          print *,gradbufc(1,13)
 730 C          print *,welec*gelc(1,13)
 731 C          print *,wel_loc*gel_loc(1,13)
 732 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 733 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 734 C          print *,wel_loc*gel_loc_long(1,13)
 735 C          print *,gradafm(1,13),"AFM"
 736           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 737      &                wel_loc*gel_loc(j,i)+
 738      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 739      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 740      &                wel_loc*gel_loc_long(j,i)+
 741      &                wcorr*gradcorr_long(j,i)+
 742      &                wcorr5*gradcorr5_long(j,i)+
 743      &                wcorr6*gradcorr6_long(j,i)+
 744      &                wturn6*gcorr6_turn_long(j,i))+
 745      &                wbond*gradb(j,i)+
 746      &                wcorr*gradcorr(j,i)+
 747      &                wturn3*gcorr3_turn(j,i)+
 748      &                wturn4*gcorr4_turn(j,i)+
 749      &                wcorr5*gradcorr5(j,i)+
 750      &                wcorr6*gradcorr6(j,i)+
 751      &                wturn6*gcorr6_turn(j,i)+
 752      &                wsccor*gsccorc(j,i)
 753      &               +wscloc*gscloc(j,i)
 754      &               +wliptran*gliptranc(j,i)
 755      &                +gradafm(j,i)
 756      &                 +welec*gshieldc(j,i)
 757      &                 +welec*gshieldc_loc(j,i)
 758      &                 +wcorr*gshieldc_ec(j,i)
 759      &                 +wcorr*gshieldc_loc_ec(j,i)
 760      &                 +wturn3*gshieldc_t3(j,i)
 761      &                 +wturn3*gshieldc_loc_t3(j,i)
 762      &                 +wturn4*gshieldc_t4(j,i)
 763      &                 +wturn4*gshieldc_loc_t4(j,i)
 764      &                 +wel_loc*gshieldc_ll(j,i)
 765      &                 +wel_loc*gshieldc_loc_ll(j,i)
 766      &                +wtube*gg_tube(j,i)
 767
 768 #else
 769           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 770      &                wel_loc*gel_loc(j,i)+
 771      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 772      &                welec*gelc_long(j,i)+
 773      &                wel_loc*gel_loc_long(j,i)+
 774      &                wcorr*gcorr_long(j,i)+
 775      &                wcorr5*gradcorr5_long(j,i)+
 776      &                wcorr6*gradcorr6_long(j,i)+
 777      &                wturn6*gcorr6_turn_long(j,i))+
 778      &                wbond*gradb(j,i)+
 779      &                wcorr*gradcorr(j,i)+
 780      &                wturn3*gcorr3_turn(j,i)+
 781      &                wturn4*gcorr4_turn(j,i)+
 782      &                wcorr5*gradcorr5(j,i)+
 783      &                wcorr6*gradcorr6(j,i)+
 784      &                wturn6*gcorr6_turn(j,i)+
 785      &                wsccor*gsccorc(j,i)
 786      &               +wscloc*gscloc(j,i)
 787      &               +wliptran*gliptranc(j,i)
 788      &                +gradafm(j,i)
 789      &                 +welec*gshieldc(j,i)
 790      &                 +welec*gshieldc_loc(j,i)
 791      &                 +wcorr*gshieldc_ec(j,i)
 792      &                 +wcorr*gshieldc_loc_ec(j,i)
 793      &                 +wturn3*gshieldc_t3(j,i)
 794      &                 +wturn3*gshieldc_loc_t3(j,i)
 795      &                 +wturn4*gshieldc_t4(j,i)
 796      &                 +wturn4*gshieldc_loc_t4(j,i)
 797      &                 +wel_loc*gshieldc_ll(j,i)
 798      &                 +wel_loc*gshieldc_loc_ll(j,i)
 799      &                +wtube*gg_tube(j,i)
 800
 801
 802 #endif
 803           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 804      &                  wbond*gradbx(j,i)+
 805      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 806      &                  wsccor*gsccorx(j,i)
 807      &                 +wscloc*gsclocx(j,i)
 808      &                 +wliptran*gliptranx(j,i)
 809      &                 +welec*gshieldx(j,i)
 810      &                 +wcorr*gshieldx_ec(j,i)
 811      &                 +wturn3*gshieldx_t3(j,i)
 812      &                 +wturn4*gshieldx_t4(j,i)
 813      &                 +wel_loc*gshieldx_ll(j,i)
 814      &                 +wtube*gg_tube_sc(j,i)
 815
 816
 817
 818         enddo
 819       enddo
 820 #ifdef DEBUG
 821       write (iout,*) "gloc before adding corr"
 822       do i=1,4*nres
 823         write (iout,*) i,gloc(i,icg)
 824       enddo
 825 #endif
 826       do i=1,nres-3
 827         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 828      &   +wcorr5*g_corr5_loc(i)
 829      &   +wcorr6*g_corr6_loc(i)
 830      &   +wturn4*gel_loc_turn4(i)
 831      &   +wturn3*gel_loc_turn3(i)
 832      &   +wturn6*gel_loc_turn6(i)
 833      &   +wel_loc*gel_loc_loc(i)
 834       enddo
 835 #ifdef DEBUG
 836       write (iout,*) "gloc after adding corr"
 837       do i=1,4*nres
 838         write (iout,*) i,gloc(i,icg)
 839       enddo
 840 #endif
 841 #ifdef MPI
 842       if (nfgtasks.gt.1) then
 843         do j=1,3
 844           do i=1,nres
 845             gradbufc(j,i)=gradc(j,i,icg)
 846             gradbufx(j,i)=gradx(j,i,icg)
 847           enddo
 848         enddo
 849         do i=1,4*nres
 850           glocbuf(i)=gloc(i,icg)
 851         enddo
 852 c#define DEBUG
 853 #ifdef DEBUG
 854       write (iout,*) "gloc_sc before reduce"
 855       do i=1,nres
 856        do j=1,1
 857         write (iout,*) i,j,gloc_sc(j,i,icg)
 858        enddo
 859       enddo
 860 #endif
 861 c#undef DEBUG
 862         do i=1,nres
 863          do j=1,3
 864           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 865          enddo
 866         enddo
 867         time00=MPI_Wtime()
 868         call MPI_Barrier(FG_COMM,IERR)
 869         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 870         time00=MPI_Wtime()
 871         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 872      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 873         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 874      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 875         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 876      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 877         time_reduce=time_reduce+MPI_Wtime()-time00
 878         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 879      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 880         time_reduce=time_reduce+MPI_Wtime()-time00
 881 c#define DEBUG
 882 #ifdef DEBUG
 883       write (iout,*) "gloc_sc after reduce"
 884       do i=1,nres
 885        do j=1,1
 886         write (iout,*) i,j,gloc_sc(j,i,icg)
 887        enddo
 888       enddo
 889 #endif
 890 c#undef DEBUG
 891 #ifdef DEBUG
 892       write (iout,*) "gloc after reduce"
 893       do i=1,4*nres
 894         write (iout,*) i,gloc(i,icg)
 895       enddo
 896 #endif
 897       endif
 898 #endif
 899       if (gnorm_check) then
 900 c
 901 c Compute the maximum elements of the gradient
 902 c
 903       gvdwc_max=0.0d0
 904       gvdwc_scp_max=0.0d0
 905       gelc_max=0.0d0
 906       gvdwpp_max=0.0d0
 907       gradb_max=0.0d0
 908       ghpbc_max=0.0d0
 909       gradcorr_max=0.0d0
 910       gel_loc_max=0.0d0
 911       gcorr3_turn_max=0.0d0
 912       gcorr4_turn_max=0.0d0
 913       gradcorr5_max=0.0d0
 914       gradcorr6_max=0.0d0
 915       gcorr6_turn_max=0.0d0
 916       gsccorc_max=0.0d0
 917       gscloc_max=0.0d0
 918       gvdwx_max=0.0d0
 919       gradx_scp_max=0.0d0
 920       ghpbx_max=0.0d0
 921       gradxorr_max=0.0d0
 922       gsccorx_max=0.0d0
 923       gsclocx_max=0.0d0
 924       do i=1,nct
 925         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 926         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 927         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 928         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 929      &   gvdwc_scp_max=gvdwc_scp_norm
 930         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 931         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 932         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 933         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 934         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 935         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 936         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 937         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 938         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 939         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 940         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 941         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 942         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 943      &    gcorr3_turn(1,i)))
 944         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 945      &    gcorr3_turn_max=gcorr3_turn_norm
 946         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 947      &    gcorr4_turn(1,i)))
 948         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 949      &    gcorr4_turn_max=gcorr4_turn_norm
 950         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 951         if (gradcorr5_norm.gt.gradcorr5_max)
 952      &    gradcorr5_max=gradcorr5_norm
 953         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 954         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 955         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 956      &    gcorr6_turn(1,i)))
 957         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 958      &    gcorr6_turn_max=gcorr6_turn_norm
 959         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 960         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 961         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 962         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 963         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 964         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 965         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 966         if (gradx_scp_norm.gt.gradx_scp_max)
 967      &    gradx_scp_max=gradx_scp_norm
 968         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 969         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 970         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 971         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 972         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 973         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 974         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 975         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 976       enddo
 977       if (gradout) then
 978 #ifdef AIX
 979         open(istat,file=statname,position="append")
 980 #else
 981         open(istat,file=statname,access="append")
 982 #endif
 983         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 984      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 985      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 986      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 987      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 988      &     gsccorx_max,gsclocx_max
 989         close(istat)
 990         if (gvdwc_max.gt.1.0d4) then
 991           write (iout,*) "gvdwc gvdwx gradb gradbx"
 992           do i=nnt,nct
 993             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 994      &        gradb(j,i),gradbx(j,i),j=1,3)
 995           enddo
 996           call pdbout(0.0d0,'cipiszcze',iout)
 997           call flush(iout)
 998         endif
 999       endif
1000       endif
1001 #ifdef DEBUG
1002       write (iout,*) "gradc gradx gloc"
1003       do i=1,nres
1004         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1005      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1006       enddo
1007 #endif
1008 #ifdef TIMING
1009       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1010 #endif
1011       return
1012       end
1013 c-------------------------------------------------------------------------------
1014       subroutine rescale_weights(t_bath)
1015       implicit real*8 (a-h,o-z)
1016       include 'DIMENSIONS'
1017       include 'COMMON.IOUNITS'
1018       include 'COMMON.FFIELD'
1019       include 'COMMON.SBRIDGE'
1020       include 'COMMON.CONTROL'
1021       double precision kfac /2.4d0/
1022       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1023 c      facT=temp0/t_bath
1024 c      facT=2*temp0/(t_bath+temp0)
1025       if (rescale_mode.eq.0) then
1026         facT=1.0d0
1027         facT2=1.0d0
1028         facT3=1.0d0
1029         facT4=1.0d0
1030         facT5=1.0d0
1031       else if (rescale_mode.eq.1) then
1032         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1033         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1034         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1035         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1036         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1037       else if (rescale_mode.eq.2) then
1038         x=t_bath/temp0
1039         x2=x*x
1040         x3=x2*x
1041         x4=x3*x
1042         x5=x4*x
1043         facT=licznik/dlog(dexp(x)+dexp(-x))
1044         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1045         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1046         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1047         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1048       else
1049         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1050         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1051 #ifdef MPI
1052        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1053 #endif
1054        stop 555
1055       endif
1056       if (shield_mode.gt.0) then
1057        wscp=weights(2)*fact
1058        wsc=weights(1)*fact
1059        wvdwpp=weights(16)*fact
1060       endif
1061       welec=weights(3)*fact
1062       wcorr=weights(4)*fact3
1063       wcorr5=weights(5)*fact4
1064       wcorr6=weights(6)*fact5
1065       wel_loc=weights(7)*fact2
1066       wturn3=weights(8)*fact2
1067       wturn4=weights(9)*fact3
1068       wturn6=weights(10)*fact5
1069       wtor=weights(13)*fact
1070       wtor_d=weights(14)*fact2
1071       wsccor=weights(21)*fact
1072
1073       return
1074       end
1075 C------------------------------------------------------------------------
1076       subroutine enerprint(energia)
1077       implicit real*8 (a-h,o-z)
1078       include 'DIMENSIONS'
1079       include 'COMMON.IOUNITS'
1080       include 'COMMON.FFIELD'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.MD'
1083       double precision energia(0:n_ene)
1084       etot=energia(0)
1085       evdw=energia(1)
1086       evdw2=energia(2)
1087 #ifdef SCP14
1088       evdw2=energia(2)+energia(18)
1089 #else
1090       evdw2=energia(2)
1091 #endif
1092       ees=energia(3)
1093 #ifdef SPLITELE
1094       evdw1=energia(16)
1095 #endif
1096       ecorr=energia(4)
1097       ecorr5=energia(5)
1098       ecorr6=energia(6)
1099       eel_loc=energia(7)
1100       eello_turn3=energia(8)
1101       eello_turn4=energia(9)
1102       eello_turn6=energia(10)
1103       ebe=energia(11)
1104       escloc=energia(12)
1105       etors=energia(13)
1106       etors_d=energia(14)
1107       ehpb=energia(15)
1108       edihcnstr=energia(19)
1109       estr=energia(17)
1110       Uconst=energia(20)
1111       esccor=energia(21)
1112       eliptran=energia(22)
1113       Eafmforce=energia(23)
1114       ethetacnstr=energia(24)
1115       etube=energia(25)
1116 #ifdef SPLITELE
1117       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1118      &  estr,wbond,ebe,wang,
1119      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1120      &  ecorr,wcorr,
1121      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1122      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1123      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1124      &  etube,wtube,
1125      &  etot
1126    10 format (/'Virtual-chain energies:'//
1127      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1128      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1129      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1130      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1131      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1132      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1133      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1134      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1135      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1136      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1137      & ' (SS bridges & dist. cnstr.)'/
1138      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1139      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1140      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1141      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1142      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1143      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1144      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1145      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1146      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1147      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1148      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1149      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1150      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1151      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1152      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1153      & 'ETOT=  ',1pE16.6,' (total)')
1154
1155 #else
1156       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1157      &  estr,wbond,ebe,wang,
1158      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1159      &  ecorr,wcorr,
1160      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1161      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1162      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1163      &  etube,wtube,
1164      &  etot
1165    10 format (/'Virtual-chain energies:'//
1166      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1167      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1168      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1169      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1170      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1171      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1172      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1173      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1174      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1175      & ' (SS bridges & dist. cnstr.)'/
1176      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1177      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1178      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1179      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1180      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1181      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1182      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1183      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1184      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1185      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1186      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1187      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1188      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1189      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1190      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1191      & 'ETOT=  ',1pE16.6,' (total)')
1192 #endif
1193       return
1194       end
1195 C-----------------------------------------------------------------------
1196       subroutine elj(evdw)
1197 C
1198 C This subroutine calculates the interaction energy of nonbonded side chains
1199 C assuming the LJ potential of interaction.
1200 C
1201       implicit real*8 (a-h,o-z)
1202       include 'DIMENSIONS'
1203       parameter (accur=1.0d-10)
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.TORSION'
1211       include 'COMMON.SBRIDGE'
1212       include 'COMMON.NAMES'
1213       include 'COMMON.IOUNITS'
1214       include 'COMMON.CONTACTS'
1215       dimension gg(3)
1216 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1217       evdw=0.0D0
1218       do i=iatsc_s,iatsc_e
1219         itypi=iabs(itype(i))
1220         if (itypi.eq.ntyp1) cycle
1221         itypi1=iabs(itype(i+1))
1222         xi=c(1,nres+i)
1223         yi=c(2,nres+i)
1224         zi=c(3,nres+i)
1225 C Change 12/1/95
1226         num_conti=0
1227 C
1228 C Calculate SC interaction energy.
1229 C
1230         do iint=1,nint_gr(i)
1231 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1232 cd   &                  'iend=',iend(i,iint)
1233           do j=istart(i,iint),iend(i,iint)
1234             itypj=iabs(itype(j))
1235             if (itypj.eq.ntyp1) cycle
1236             xj=c(1,nres+j)-xi
1237             yj=c(2,nres+j)-yi
1238             zj=c(3,nres+j)-zi
1239 C Change 12/1/95 to calculate four-body interactions
1240             rij=xj*xj+yj*yj+zj*zj
1241             rrij=1.0D0/rij
1242 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1243             eps0ij=eps(itypi,itypj)
1244             fac=rrij**expon2
1245 C have you changed here?
1246             e1=fac*fac*aa
1247             e2=fac*bb
1248             evdwij=e1+e2
1249 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1250 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1251 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1252 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1253 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1254 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1255             evdw=evdw+evdwij
1256 C
1257 C Calculate the components of the gradient in DC and X
1258 C
1259             fac=-rrij*(e1+evdwij)
1260             gg(1)=xj*fac
1261             gg(2)=yj*fac
1262             gg(3)=zj*fac
1263             do k=1,3
1264               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1265               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1266               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1267               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1268             enddo
1269 cgrad            do k=i,j-1
1270 cgrad              do l=1,3
1271 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1272 cgrad              enddo
1273 cgrad            enddo
1274 C
1275 C 12/1/95, revised on 5/20/97
1276 C
1277 C Calculate the contact function. The ith column of the array JCONT will
1278 C contain the numbers of atoms that make contacts with the atom I (of numbers
1279 C greater than I). The arrays FACONT and GACONT will contain the values of
1280 C the contact function and its derivative.
1281 C
1282 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1283 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1284 C Uncomment next line, if the correlation interactions are contact function only
1285             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1286               rij=dsqrt(rij)
1287               sigij=sigma(itypi,itypj)
1288               r0ij=rs0(itypi,itypj)
1289 C
1290 C Check whether the SC's are not too far to make a contact.
1291 C
1292               rcut=1.5d0*r0ij
1293               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1294 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1295 C
1296               if (fcont.gt.0.0D0) then
1297 C If the SC-SC distance if close to sigma, apply spline.
1298 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1299 cAdam &             fcont1,fprimcont1)
1300 cAdam           fcont1=1.0d0-fcont1
1301 cAdam           if (fcont1.gt.0.0d0) then
1302 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1303 cAdam             fcont=fcont*fcont1
1304 cAdam           endif
1305 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1306 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1307 cga             do k=1,3
1308 cga               gg(k)=gg(k)*eps0ij
1309 cga             enddo
1310 cga             eps0ij=-evdwij*eps0ij
1311 C Uncomment for AL's type of SC correlation interactions.
1312 cadam           eps0ij=-evdwij
1313                 num_conti=num_conti+1
1314                 jcont(num_conti,i)=j
1315                 facont(num_conti,i)=fcont*eps0ij
1316                 fprimcont=eps0ij*fprimcont/rij
1317                 fcont=expon*fcont
1318 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1319 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1320 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1321 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1322                 gacont(1,num_conti,i)=-fprimcont*xj
1323                 gacont(2,num_conti,i)=-fprimcont*yj
1324                 gacont(3,num_conti,i)=-fprimcont*zj
1325 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1326 cd              write (iout,'(2i3,3f10.5)')
1327 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1328               endif
1329             endif
1330           enddo      ! j
1331         enddo        ! iint
1332 C Change 12/1/95
1333         num_cont(i)=num_conti
1334       enddo          ! i
1335       do i=1,nct
1336         do j=1,3
1337           gvdwc(j,i)=expon*gvdwc(j,i)
1338           gvdwx(j,i)=expon*gvdwx(j,i)
1339         enddo
1340       enddo
1341 C******************************************************************************
1342 C
1343 C                              N O T E !!!
1344 C
1345 C To save time, the factor of EXPON has been extracted from ALL components
1346 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1347 C use!
1348 C
1349 C******************************************************************************
1350       return
1351       end
1352 C-----------------------------------------------------------------------------
1353       subroutine eljk(evdw)
1354 C
1355 C This subroutine calculates the interaction energy of nonbonded side chains
1356 C assuming the LJK potential of interaction.
1357 C
1358       implicit real*8 (a-h,o-z)
1359       include 'DIMENSIONS'
1360       include 'COMMON.GEO'
1361       include 'COMMON.VAR'
1362       include 'COMMON.LOCAL'
1363       include 'COMMON.CHAIN'
1364       include 'COMMON.DERIV'
1365       include 'COMMON.INTERACT'
1366       include 'COMMON.IOUNITS'
1367       include 'COMMON.NAMES'
1368       dimension gg(3)
1369       logical scheck
1370 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1371       evdw=0.0D0
1372       do i=iatsc_s,iatsc_e
1373         itypi=iabs(itype(i))
1374         if (itypi.eq.ntyp1) cycle
1375         itypi1=iabs(itype(i+1))
1376         xi=c(1,nres+i)
1377         yi=c(2,nres+i)
1378         zi=c(3,nres+i)
1379 C
1380 C Calculate SC interaction energy.
1381 C
1382         do iint=1,nint_gr(i)
1383           do j=istart(i,iint),iend(i,iint)
1384             itypj=iabs(itype(j))
1385             if (itypj.eq.ntyp1) cycle
1386             xj=c(1,nres+j)-xi
1387             yj=c(2,nres+j)-yi
1388             zj=c(3,nres+j)-zi
1389             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1390             fac_augm=rrij**expon
1391             e_augm=augm(itypi,itypj)*fac_augm
1392             r_inv_ij=dsqrt(rrij)
1393             rij=1.0D0/r_inv_ij
1394             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1395             fac=r_shift_inv**expon
1396 C have you changed here?
1397             e1=fac*fac*aa
1398             e2=fac*bb
1399             evdwij=e_augm+e1+e2
1400 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1401 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1402 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1403 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1404 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1405 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1406 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1407             evdw=evdw+evdwij
1408 C
1409 C Calculate the components of the gradient in DC and X
1410 C
1411             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1412             gg(1)=xj*fac
1413             gg(2)=yj*fac
1414             gg(3)=zj*fac
1415             do k=1,3
1416               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1417               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1418               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1419               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1420             enddo
1421 cgrad            do k=i,j-1
1422 cgrad              do l=1,3
1423 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1424 cgrad              enddo
1425 cgrad            enddo
1426           enddo      ! j
1427         enddo        ! iint
1428       enddo          ! i
1429       do i=1,nct
1430         do j=1,3
1431           gvdwc(j,i)=expon*gvdwc(j,i)
1432           gvdwx(j,i)=expon*gvdwx(j,i)
1433         enddo
1434       enddo
1435       return
1436       end
1437 C-----------------------------------------------------------------------------
1438       subroutine ebp(evdw)
1439 C
1440 C This subroutine calculates the interaction energy of nonbonded side chains
1441 C assuming the Berne-Pechukas potential of interaction.
1442 C
1443       implicit real*8 (a-h,o-z)
1444       include 'DIMENSIONS'
1445       include 'COMMON.GEO'
1446       include 'COMMON.VAR'
1447       include 'COMMON.LOCAL'
1448       include 'COMMON.CHAIN'
1449       include 'COMMON.DERIV'
1450       include 'COMMON.NAMES'
1451       include 'COMMON.INTERACT'
1452       include 'COMMON.IOUNITS'
1453       include 'COMMON.CALC'
1454       common /srutu/ icall
1455 c     double precision rrsave(maxdim)
1456       logical lprn
1457       evdw=0.0D0
1458 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1459       evdw=0.0D0
1460 c     if (icall.eq.0) then
1461 c       lprn=.true.
1462 c     else
1463         lprn=.false.
1464 c     endif
1465       ind=0
1466       do i=iatsc_s,iatsc_e
1467         itypi=iabs(itype(i))
1468         if (itypi.eq.ntyp1) cycle
1469         itypi1=iabs(itype(i+1))
1470         xi=c(1,nres+i)
1471         yi=c(2,nres+i)
1472         zi=c(3,nres+i)
1473         dxi=dc_norm(1,nres+i)
1474         dyi=dc_norm(2,nres+i)
1475         dzi=dc_norm(3,nres+i)
1476 c        dsci_inv=dsc_inv(itypi)
1477         dsci_inv=vbld_inv(i+nres)
1478 C
1479 C Calculate SC interaction energy.
1480 C
1481         do iint=1,nint_gr(i)
1482           do j=istart(i,iint),iend(i,iint)
1483             ind=ind+1
1484             itypj=iabs(itype(j))
1485             if (itypj.eq.ntyp1) cycle
1486 c            dscj_inv=dsc_inv(itypj)
1487             dscj_inv=vbld_inv(j+nres)
1488             chi1=chi(itypi,itypj)
1489             chi2=chi(itypj,itypi)
1490             chi12=chi1*chi2
1491             chip1=chip(itypi)
1492             chip2=chip(itypj)
1493             chip12=chip1*chip2
1494             alf1=alp(itypi)
1495             alf2=alp(itypj)
1496             alf12=0.5D0*(alf1+alf2)
1497 C For diagnostics only!!!
1498 c           chi1=0.0D0
1499 c           chi2=0.0D0
1500 c           chi12=0.0D0
1501 c           chip1=0.0D0
1502 c           chip2=0.0D0
1503 c           chip12=0.0D0
1504 c           alf1=0.0D0
1505 c           alf2=0.0D0
1506 c           alf12=0.0D0
1507             xj=c(1,nres+j)-xi
1508             yj=c(2,nres+j)-yi
1509             zj=c(3,nres+j)-zi
1510             dxj=dc_norm(1,nres+j)
1511             dyj=dc_norm(2,nres+j)
1512             dzj=dc_norm(3,nres+j)
1513             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1514 cd          if (icall.eq.0) then
1515 cd            rrsave(ind)=rrij
1516 cd          else
1517 cd            rrij=rrsave(ind)
1518 cd          endif
1519             rij=dsqrt(rrij)
1520 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1521             call sc_angular
1522 C Calculate whole angle-dependent part of epsilon and contributions
1523 C to its derivatives
1524 C have you changed here?
1525             fac=(rrij*sigsq)**expon2
1526             e1=fac*fac*aa
1527             e2=fac*bb
1528             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1529             eps2der=evdwij*eps3rt
1530             eps3der=evdwij*eps2rt
1531             evdwij=evdwij*eps2rt*eps3rt
1532             evdw=evdw+evdwij
1533             if (lprn) then
1534             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1535             epsi=bb**2/aa
1536 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1537 cd     &        restyp(itypi),i,restyp(itypj),j,
1538 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1539 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1540 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1541 cd     &        evdwij
1542             endif
1543 C Calculate gradient components.
1544             e1=e1*eps1*eps2rt**2*eps3rt**2
1545             fac=-expon*(e1+evdwij)
1546             sigder=fac/sigsq
1547             fac=rrij*fac
1548 C Calculate radial part of the gradient
1549             gg(1)=xj*fac
1550             gg(2)=yj*fac
1551             gg(3)=zj*fac
1552 C Calculate the angular part of the gradient and sum add the contributions
1553 C to the appropriate components of the Cartesian gradient.
1554             call sc_grad
1555           enddo      ! j
1556         enddo        ! iint
1557       enddo          ! i
1558 c     stop
1559       return
1560       end
1561 C-----------------------------------------------------------------------------
1562       subroutine egb(evdw)
1563 C
1564 C This subroutine calculates the interaction energy of nonbonded side chains
1565 C assuming the Gay-Berne potential of interaction.
1566 C
1567       implicit real*8 (a-h,o-z)
1568       include 'DIMENSIONS'
1569       include 'COMMON.GEO'
1570       include 'COMMON.VAR'
1571       include 'COMMON.LOCAL'
1572       include 'COMMON.CHAIN'
1573       include 'COMMON.DERIV'
1574       include 'COMMON.NAMES'
1575       include 'COMMON.INTERACT'
1576       include 'COMMON.IOUNITS'
1577       include 'COMMON.CALC'
1578       include 'COMMON.CONTROL'
1579       include 'COMMON.SPLITELE'
1580       include 'COMMON.SBRIDGE'
1581       logical lprn
1582       integer xshift,yshift,zshift
1583
1584       evdw=0.0D0
1585 ccccc      energy_dec=.false.
1586 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1587       evdw=0.0D0
1588       lprn=.false.
1589 c     if (icall.eq.0) lprn=.false.
1590       ind=0
1591 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1592 C we have the original box)
1593 C      do xshift=-1,1
1594 C      do yshift=-1,1
1595 C      do zshift=-1,1
1596       do i=iatsc_s,iatsc_e
1597         itypi=iabs(itype(i))
1598         if (itypi.eq.ntyp1) cycle
1599         itypi1=iabs(itype(i+1))
1600         xi=c(1,nres+i)
1601         yi=c(2,nres+i)
1602         zi=c(3,nres+i)
1603 C Return atom into box, boxxsize is size of box in x dimension
1604 c  134   continue
1605 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1606 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1607 C Condition for being inside the proper box
1608 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1609 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1610 c        go to 134
1611 c        endif
1612 c  135   continue
1613 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1614 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1615 C Condition for being inside the proper box
1616 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1617 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1618 c        go to 135
1619 c        endif
1620 c  136   continue
1621 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1622 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1623 C Condition for being inside the proper box
1624 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1625 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1626 c        go to 136
1627 c        endif
1628           xi=mod(xi,boxxsize)
1629           if (xi.lt.0) xi=xi+boxxsize
1630           yi=mod(yi,boxysize)
1631           if (yi.lt.0) yi=yi+boxysize
1632           zi=mod(zi,boxzsize)
1633           if (zi.lt.0) zi=zi+boxzsize
1634 C define scaling factor for lipids
1635
1636 C        if (positi.le.0) positi=positi+boxzsize
1637 C        print *,i
1638 C first for peptide groups
1639 c for each residue check if it is in lipid or lipid water border area
1640        if ((zi.gt.bordlipbot)
1641      &.and.(zi.lt.bordliptop)) then
1642 C the energy transfer exist
1643         if (zi.lt.buflipbot) then
1644 C what fraction I am in
1645          fracinbuf=1.0d0-
1646      &        ((zi-bordlipbot)/lipbufthick)
1647 C lipbufthick is thickenes of lipid buffore
1648          sslipi=sscalelip(fracinbuf)
1649          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1650         elseif (zi.gt.bufliptop) then
1651          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1652          sslipi=sscalelip(fracinbuf)
1653          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1654         else
1655          sslipi=1.0d0
1656          ssgradlipi=0.0
1657         endif
1658        else
1659          sslipi=0.0d0
1660          ssgradlipi=0.0
1661        endif
1662
1663 C          xi=xi+xshift*boxxsize
1664 C          yi=yi+yshift*boxysize
1665 C          zi=zi+zshift*boxzsize
1666
1667         dxi=dc_norm(1,nres+i)
1668         dyi=dc_norm(2,nres+i)
1669         dzi=dc_norm(3,nres+i)
1670 c        dsci_inv=dsc_inv(itypi)
1671         dsci_inv=vbld_inv(i+nres)
1672 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1673 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1674 C
1675 C Calculate SC interaction energy.
1676 C
1677         do iint=1,nint_gr(i)
1678           do j=istart(i,iint),iend(i,iint)
1679             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1680
1681 c              write(iout,*) "PRZED ZWYKLE", evdwij
1682               call dyn_ssbond_ene(i,j,evdwij)
1683 c              write(iout,*) "PO ZWYKLE", evdwij
1684
1685               evdw=evdw+evdwij
1686               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1687      &                        'evdw',i,j,evdwij,' ss'
1688 C triple bond artifac removal
1689              do k=j+1,iend(i,iint)
1690 C search over all next residues
1691               if (dyn_ss_mask(k)) then
1692 C check if they are cysteins
1693 C              write(iout,*) 'k=',k
1694
1695 c              write(iout,*) "PRZED TRI", evdwij
1696                evdwij_przed_tri=evdwij
1697               call triple_ssbond_ene(i,j,k,evdwij)
1698 c               if(evdwij_przed_tri.ne.evdwij) then
1699 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1700 c               endif
1701
1702 c              write(iout,*) "PO TRI", evdwij
1703 C call the energy function that removes the artifical triple disulfide
1704 C bond the soubroutine is located in ssMD.F
1705               evdw=evdw+evdwij
1706               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1707      &                        'evdw',i,j,evdwij,'tss'
1708               endif!dyn_ss_mask(k)
1709              enddo! k
1710             ELSE
1711             ind=ind+1
1712             itypj=iabs(itype(j))
1713             if (itypj.eq.ntyp1) cycle
1714 c            dscj_inv=dsc_inv(itypj)
1715             dscj_inv=vbld_inv(j+nres)
1716 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1717 c     &       1.0d0/vbld(j+nres)
1718 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1719             sig0ij=sigma(itypi,itypj)
1720             chi1=chi(itypi,itypj)
1721             chi2=chi(itypj,itypi)
1722             chi12=chi1*chi2
1723             chip1=chip(itypi)
1724             chip2=chip(itypj)
1725             chip12=chip1*chip2
1726             alf1=alp(itypi)
1727             alf2=alp(itypj)
1728             alf12=0.5D0*(alf1+alf2)
1729 C For diagnostics only!!!
1730 c           chi1=0.0D0
1731 c           chi2=0.0D0
1732 c           chi12=0.0D0
1733 c           chip1=0.0D0
1734 c           chip2=0.0D0
1735 c           chip12=0.0D0
1736 c           alf1=0.0D0
1737 c           alf2=0.0D0
1738 c           alf12=0.0D0
1739             xj=c(1,nres+j)
1740             yj=c(2,nres+j)
1741             zj=c(3,nres+j)
1742 C Return atom J into box the original box
1743 c  137   continue
1744 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1745 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1746 C Condition for being inside the proper box
1747 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1748 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1749 c        go to 137
1750 c        endif
1751 c  138   continue
1752 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1753 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1754 C Condition for being inside the proper box
1755 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1756 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1757 c        go to 138
1758 c        endif
1759 c  139   continue
1760 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1761 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1762 C Condition for being inside the proper box
1763 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1764 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1765 c        go to 139
1766 c        endif
1767           xj=mod(xj,boxxsize)
1768           if (xj.lt.0) xj=xj+boxxsize
1769           yj=mod(yj,boxysize)
1770           if (yj.lt.0) yj=yj+boxysize
1771           zj=mod(zj,boxzsize)
1772           if (zj.lt.0) zj=zj+boxzsize
1773        if ((zj.gt.bordlipbot)
1774      &.and.(zj.lt.bordliptop)) then
1775 C the energy transfer exist
1776         if (zj.lt.buflipbot) then
1777 C what fraction I am in
1778          fracinbuf=1.0d0-
1779      &        ((zj-bordlipbot)/lipbufthick)
1780 C lipbufthick is thickenes of lipid buffore
1781          sslipj=sscalelip(fracinbuf)
1782          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1783         elseif (zj.gt.bufliptop) then
1784          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1785          sslipj=sscalelip(fracinbuf)
1786          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1787         else
1788          sslipj=1.0d0
1789          ssgradlipj=0.0
1790         endif
1791        else
1792          sslipj=0.0d0
1793          ssgradlipj=0.0
1794        endif
1795       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1796      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1797       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1798      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1799 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1800 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1801 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1802 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1803 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1804       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1805       xj_safe=xj
1806       yj_safe=yj
1807       zj_safe=zj
1808       subchap=0
1809       do xshift=-1,1
1810       do yshift=-1,1
1811       do zshift=-1,1
1812           xj=xj_safe+xshift*boxxsize
1813           yj=yj_safe+yshift*boxysize
1814           zj=zj_safe+zshift*boxzsize
1815           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1816           if(dist_temp.lt.dist_init) then
1817             dist_init=dist_temp
1818             xj_temp=xj
1819             yj_temp=yj
1820             zj_temp=zj
1821             subchap=1
1822           endif
1823        enddo
1824        enddo
1825        enddo
1826        if (subchap.eq.1) then
1827           xj=xj_temp-xi
1828           yj=yj_temp-yi
1829           zj=zj_temp-zi
1830        else
1831           xj=xj_safe-xi
1832           yj=yj_safe-yi
1833           zj=zj_safe-zi
1834        endif
1835             dxj=dc_norm(1,nres+j)
1836             dyj=dc_norm(2,nres+j)
1837             dzj=dc_norm(3,nres+j)
1838 C            xj=xj-xi
1839 C            yj=yj-yi
1840 C            zj=zj-zi
1841 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1842 c            write (iout,*) "j",j," dc_norm",
1843 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1844             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1845             rij=dsqrt(rrij)
1846             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1847             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1848
1849 c            write (iout,'(a7,4f8.3)')
1850 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1851             if (sss.gt.0.0d0) then
1852 C Calculate angle-dependent terms of energy and contributions to their
1853 C derivatives.
1854             call sc_angular
1855             sigsq=1.0D0/sigsq
1856             sig=sig0ij*dsqrt(sigsq)
1857             rij_shift=1.0D0/rij-sig+sig0ij
1858 c for diagnostics; uncomment
1859 c            rij_shift=1.2*sig0ij
1860 C I hate to put IF's in the loops, but here don't have another choice!!!!
1861             if (rij_shift.le.0.0D0) then
1862               evdw=1.0D20
1863 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1864 cd     &        restyp(itypi),i,restyp(itypj),j,
1865 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1866               return
1867             endif
1868             sigder=-sig*sigsq
1869 c---------------------------------------------------------------
1870             rij_shift=1.0D0/rij_shift
1871             fac=rij_shift**expon
1872 C here to start with
1873 C            if (c(i,3).gt.
1874             faclip=fac
1875             e1=fac*fac*aa
1876             e2=fac*bb
1877             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1878             eps2der=evdwij*eps3rt
1879             eps3der=evdwij*eps2rt
1880 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1881 C     &((sslipi+sslipj)/2.0d0+
1882 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1883 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1884 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1885             evdwij=evdwij*eps2rt*eps3rt
1886             evdw=evdw+evdwij*sss
1887             if (lprn) then
1888             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1889             epsi=bb**2/aa
1890             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1891      &        restyp(itypi),i,restyp(itypj),j,
1892      &        epsi,sigm,chi1,chi2,chip1,chip2,
1893      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1894      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1895      &        evdwij
1896             endif
1897
1898             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1899      &                        'evdw',i,j,evdwij
1900
1901 C Calculate gradient components.
1902             e1=e1*eps1*eps2rt**2*eps3rt**2
1903             fac=-expon*(e1+evdwij)*rij_shift
1904             sigder=fac*sigder
1905             fac=rij*fac
1906 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1907 c     &      evdwij,fac,sigma(itypi,itypj),expon
1908             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1909 c            fac=0.0d0
1910 C Calculate the radial part of the gradient
1911             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1912      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1913      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1914      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1915             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1916             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1917 C            gg_lipi(3)=0.0d0
1918 C            gg_lipj(3)=0.0d0
1919             gg(1)=xj*fac
1920             gg(2)=yj*fac
1921             gg(3)=zj*fac
1922 C Calculate angular part of the gradient.
1923             call sc_grad
1924             endif
1925             ENDIF    ! dyn_ss
1926           enddo      ! j
1927         enddo        ! iint
1928       enddo          ! i
1929 C      enddo          ! zshift
1930 C      enddo          ! yshift
1931 C      enddo          ! xshift
1932 c      write (iout,*) "Number of loop steps in EGB:",ind
1933 cccc      energy_dec=.false.
1934       return
1935       end
1936 C-----------------------------------------------------------------------------
1937       subroutine egbv(evdw)
1938 C
1939 C This subroutine calculates the interaction energy of nonbonded side chains
1940 C assuming the Gay-Berne-Vorobjev potential of interaction.
1941 C
1942       implicit real*8 (a-h,o-z)
1943       include 'DIMENSIONS'
1944       include 'COMMON.GEO'
1945       include 'COMMON.VAR'
1946       include 'COMMON.LOCAL'
1947       include 'COMMON.CHAIN'
1948       include 'COMMON.DERIV'
1949       include 'COMMON.NAMES'
1950       include 'COMMON.INTERACT'
1951       include 'COMMON.IOUNITS'
1952       include 'COMMON.CALC'
1953       common /srutu/ icall
1954       logical lprn
1955       evdw=0.0D0
1956 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1957       evdw=0.0D0
1958       lprn=.false.
1959 c     if (icall.eq.0) lprn=.true.
1960       ind=0
1961       do i=iatsc_s,iatsc_e
1962         itypi=iabs(itype(i))
1963         if (itypi.eq.ntyp1) cycle
1964         itypi1=iabs(itype(i+1))
1965         xi=c(1,nres+i)
1966         yi=c(2,nres+i)
1967         zi=c(3,nres+i)
1968           xi=mod(xi,boxxsize)
1969           if (xi.lt.0) xi=xi+boxxsize
1970           yi=mod(yi,boxysize)
1971           if (yi.lt.0) yi=yi+boxysize
1972           zi=mod(zi,boxzsize)
1973           if (zi.lt.0) zi=zi+boxzsize
1974 C define scaling factor for lipids
1975
1976 C        if (positi.le.0) positi=positi+boxzsize
1977 C        print *,i
1978 C first for peptide groups
1979 c for each residue check if it is in lipid or lipid water border area
1980        if ((zi.gt.bordlipbot)
1981      &.and.(zi.lt.bordliptop)) then
1982 C the energy transfer exist
1983         if (zi.lt.buflipbot) then
1984 C what fraction I am in
1985          fracinbuf=1.0d0-
1986      &        ((zi-bordlipbot)/lipbufthick)
1987 C lipbufthick is thickenes of lipid buffore
1988          sslipi=sscalelip(fracinbuf)
1989          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1990         elseif (zi.gt.bufliptop) then
1991          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1992          sslipi=sscalelip(fracinbuf)
1993          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1994         else
1995          sslipi=1.0d0
1996          ssgradlipi=0.0
1997         endif
1998        else
1999          sslipi=0.0d0
2000          ssgradlipi=0.0
2001        endif
2002
2003         dxi=dc_norm(1,nres+i)
2004         dyi=dc_norm(2,nres+i)
2005         dzi=dc_norm(3,nres+i)
2006 c        dsci_inv=dsc_inv(itypi)
2007         dsci_inv=vbld_inv(i+nres)
2008 C
2009 C Calculate SC interaction energy.
2010 C
2011         do iint=1,nint_gr(i)
2012           do j=istart(i,iint),iend(i,iint)
2013             ind=ind+1
2014             itypj=iabs(itype(j))
2015             if (itypj.eq.ntyp1) cycle
2016 c            dscj_inv=dsc_inv(itypj)
2017             dscj_inv=vbld_inv(j+nres)
2018             sig0ij=sigma(itypi,itypj)
2019             r0ij=r0(itypi,itypj)
2020             chi1=chi(itypi,itypj)
2021             chi2=chi(itypj,itypi)
2022             chi12=chi1*chi2
2023             chip1=chip(itypi)
2024             chip2=chip(itypj)
2025             chip12=chip1*chip2
2026             alf1=alp(itypi)
2027             alf2=alp(itypj)
2028             alf12=0.5D0*(alf1+alf2)
2029 C For diagnostics only!!!
2030 c           chi1=0.0D0
2031 c           chi2=0.0D0
2032 c           chi12=0.0D0
2033 c           chip1=0.0D0
2034 c           chip2=0.0D0
2035 c           chip12=0.0D0
2036 c           alf1=0.0D0
2037 c           alf2=0.0D0
2038 c           alf12=0.0D0
2039 C            xj=c(1,nres+j)-xi
2040 C            yj=c(2,nres+j)-yi
2041 C            zj=c(3,nres+j)-zi
2042           xj=mod(xj,boxxsize)
2043           if (xj.lt.0) xj=xj+boxxsize
2044           yj=mod(yj,boxysize)
2045           if (yj.lt.0) yj=yj+boxysize
2046           zj=mod(zj,boxzsize)
2047           if (zj.lt.0) zj=zj+boxzsize
2048        if ((zj.gt.bordlipbot)
2049      &.and.(zj.lt.bordliptop)) then
2050 C the energy transfer exist
2051         if (zj.lt.buflipbot) then
2052 C what fraction I am in
2053          fracinbuf=1.0d0-
2054      &        ((zj-bordlipbot)/lipbufthick)
2055 C lipbufthick is thickenes of lipid buffore
2056          sslipj=sscalelip(fracinbuf)
2057          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2058         elseif (zj.gt.bufliptop) then
2059          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2060          sslipj=sscalelip(fracinbuf)
2061          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2062         else
2063          sslipj=1.0d0
2064          ssgradlipj=0.0
2065         endif
2066        else
2067          sslipj=0.0d0
2068          ssgradlipj=0.0
2069        endif
2070       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2071      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2072       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2073      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2074 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2075 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2076 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2077       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2078       xj_safe=xj
2079       yj_safe=yj
2080       zj_safe=zj
2081       subchap=0
2082       do xshift=-1,1
2083       do yshift=-1,1
2084       do zshift=-1,1
2085           xj=xj_safe+xshift*boxxsize
2086           yj=yj_safe+yshift*boxysize
2087           zj=zj_safe+zshift*boxzsize
2088           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2089           if(dist_temp.lt.dist_init) then
2090             dist_init=dist_temp
2091             xj_temp=xj
2092             yj_temp=yj
2093             zj_temp=zj
2094             subchap=1
2095           endif
2096        enddo
2097        enddo
2098        enddo
2099        if (subchap.eq.1) then
2100           xj=xj_temp-xi
2101           yj=yj_temp-yi
2102           zj=zj_temp-zi
2103        else
2104           xj=xj_safe-xi
2105           yj=yj_safe-yi
2106           zj=zj_safe-zi
2107        endif
2108             dxj=dc_norm(1,nres+j)
2109             dyj=dc_norm(2,nres+j)
2110             dzj=dc_norm(3,nres+j)
2111             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2112             rij=dsqrt(rrij)
2113 C Calculate angle-dependent terms of energy and contributions to their
2114 C derivatives.
2115             call sc_angular
2116             sigsq=1.0D0/sigsq
2117             sig=sig0ij*dsqrt(sigsq)
2118             rij_shift=1.0D0/rij-sig+r0ij
2119 C I hate to put IF's in the loops, but here don't have another choice!!!!
2120             if (rij_shift.le.0.0D0) then
2121               evdw=1.0D20
2122               return
2123             endif
2124             sigder=-sig*sigsq
2125 c---------------------------------------------------------------
2126             rij_shift=1.0D0/rij_shift
2127             fac=rij_shift**expon
2128             e1=fac*fac*aa
2129             e2=fac*bb
2130             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2131             eps2der=evdwij*eps3rt
2132             eps3der=evdwij*eps2rt
2133             fac_augm=rrij**expon
2134             e_augm=augm(itypi,itypj)*fac_augm
2135             evdwij=evdwij*eps2rt*eps3rt
2136             evdw=evdw+evdwij+e_augm
2137             if (lprn) then
2138             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2139             epsi=bb**2/aa
2140             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2141      &        restyp(itypi),i,restyp(itypj),j,
2142      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2143      &        chi1,chi2,chip1,chip2,
2144      &        eps1,eps2rt**2,eps3rt**2,
2145      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2146      &        evdwij+e_augm
2147             endif
2148 C Calculate gradient components.
2149             e1=e1*eps1*eps2rt**2*eps3rt**2
2150             fac=-expon*(e1+evdwij)*rij_shift
2151             sigder=fac*sigder
2152             fac=rij*fac-2*expon*rrij*e_augm
2153             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2154 C Calculate the radial part of the gradient
2155             gg(1)=xj*fac
2156             gg(2)=yj*fac
2157             gg(3)=zj*fac
2158 C Calculate angular part of the gradient.
2159             call sc_grad
2160           enddo      ! j
2161         enddo        ! iint
2162       enddo          ! i
2163       end
2164 C-----------------------------------------------------------------------------
2165       subroutine sc_angular
2166 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2167 C om12. Called by ebp, egb, and egbv.
2168       implicit none
2169       include 'COMMON.CALC'
2170       include 'COMMON.IOUNITS'
2171       erij(1)=xj*rij
2172       erij(2)=yj*rij
2173       erij(3)=zj*rij
2174       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2175       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2176       om12=dxi*dxj+dyi*dyj+dzi*dzj
2177       chiom12=chi12*om12
2178 C Calculate eps1(om12) and its derivative in om12
2179       faceps1=1.0D0-om12*chiom12
2180       faceps1_inv=1.0D0/faceps1
2181       eps1=dsqrt(faceps1_inv)
2182 C Following variable is eps1*deps1/dom12
2183       eps1_om12=faceps1_inv*chiom12
2184 c diagnostics only
2185 c      faceps1_inv=om12
2186 c      eps1=om12
2187 c      eps1_om12=1.0d0
2188 c      write (iout,*) "om12",om12," eps1",eps1
2189 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2190 C and om12.
2191       om1om2=om1*om2
2192       chiom1=chi1*om1
2193       chiom2=chi2*om2
2194       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2195       sigsq=1.0D0-facsig*faceps1_inv
2196       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2197       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2198       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2199 c diagnostics only
2200 c      sigsq=1.0d0
2201 c      sigsq_om1=0.0d0
2202 c      sigsq_om2=0.0d0
2203 c      sigsq_om12=0.0d0
2204 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2205 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2206 c     &    " eps1",eps1
2207 C Calculate eps2 and its derivatives in om1, om2, and om12.
2208       chipom1=chip1*om1
2209       chipom2=chip2*om2
2210       chipom12=chip12*om12
2211       facp=1.0D0-om12*chipom12
2212       facp_inv=1.0D0/facp
2213       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2214 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2215 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2216 C Following variable is the square root of eps2
2217       eps2rt=1.0D0-facp1*facp_inv
2218 C Following three variables are the derivatives of the square root of eps
2219 C in om1, om2, and om12.
2220       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2221       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2222       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2223 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2224       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2225 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2226 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2227 c     &  " eps2rt_om12",eps2rt_om12
2228 C Calculate whole angle-dependent part of epsilon and contributions
2229 C to its derivatives
2230       return
2231       end
2232 C----------------------------------------------------------------------------
2233       subroutine sc_grad
2234       implicit real*8 (a-h,o-z)
2235       include 'DIMENSIONS'
2236       include 'COMMON.CHAIN'
2237       include 'COMMON.DERIV'
2238       include 'COMMON.CALC'
2239       include 'COMMON.IOUNITS'
2240       double precision dcosom1(3),dcosom2(3)
2241 cc      print *,'sss=',sss
2242       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2243       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2244       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2245      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2246 c diagnostics only
2247 c      eom1=0.0d0
2248 c      eom2=0.0d0
2249 c      eom12=evdwij*eps1_om12
2250 c end diagnostics
2251 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2252 c     &  " sigder",sigder
2253 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2254 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2255       do k=1,3
2256         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2257         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2258       enddo
2259       do k=1,3
2260         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2261       enddo
2262 c      write (iout,*) "gg",(gg(k),k=1,3)
2263       do k=1,3
2264         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2265      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2266      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2267         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2268      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2269      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2270 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2271 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2272 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2273 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2274       enddo
2275 C
2276 C Calculate the components of the gradient in DC and X
2277 C
2278 cgrad      do k=i,j-1
2279 cgrad        do l=1,3
2280 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2281 cgrad        enddo
2282 cgrad      enddo
2283       do l=1,3
2284         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2285         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2286       enddo
2287       return
2288       end
2289 C-----------------------------------------------------------------------
2290       subroutine e_softsphere(evdw)
2291 C
2292 C This subroutine calculates the interaction energy of nonbonded side chains
2293 C assuming the LJ potential of interaction.
2294 C
2295       implicit real*8 (a-h,o-z)
2296       include 'DIMENSIONS'
2297       parameter (accur=1.0d-10)
2298       include 'COMMON.GEO'
2299       include 'COMMON.VAR'
2300       include 'COMMON.LOCAL'
2301       include 'COMMON.CHAIN'
2302       include 'COMMON.DERIV'
2303       include 'COMMON.INTERACT'
2304       include 'COMMON.TORSION'
2305       include 'COMMON.SBRIDGE'
2306       include 'COMMON.NAMES'
2307       include 'COMMON.IOUNITS'
2308       include 'COMMON.CONTACTS'
2309       dimension gg(3)
2310 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2311       evdw=0.0D0
2312       do i=iatsc_s,iatsc_e
2313         itypi=iabs(itype(i))
2314         if (itypi.eq.ntyp1) cycle
2315         itypi1=iabs(itype(i+1))
2316         xi=c(1,nres+i)
2317         yi=c(2,nres+i)
2318         zi=c(3,nres+i)
2319 C
2320 C Calculate SC interaction energy.
2321 C
2322         do iint=1,nint_gr(i)
2323 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2324 cd   &                  'iend=',iend(i,iint)
2325           do j=istart(i,iint),iend(i,iint)
2326             itypj=iabs(itype(j))
2327             if (itypj.eq.ntyp1) cycle
2328             xj=c(1,nres+j)-xi
2329             yj=c(2,nres+j)-yi
2330             zj=c(3,nres+j)-zi
2331             rij=xj*xj+yj*yj+zj*zj
2332 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2333             r0ij=r0(itypi,itypj)
2334             r0ijsq=r0ij*r0ij
2335 c            print *,i,j,r0ij,dsqrt(rij)
2336             if (rij.lt.r0ijsq) then
2337               evdwij=0.25d0*(rij-r0ijsq)**2
2338               fac=rij-r0ijsq
2339             else
2340               evdwij=0.0d0
2341               fac=0.0d0
2342             endif
2343             evdw=evdw+evdwij
2344 C
2345 C Calculate the components of the gradient in DC and X
2346 C
2347             gg(1)=xj*fac
2348             gg(2)=yj*fac
2349             gg(3)=zj*fac
2350             do k=1,3
2351               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2352               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2353               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2354               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2355             enddo
2356 cgrad            do k=i,j-1
2357 cgrad              do l=1,3
2358 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2359 cgrad              enddo
2360 cgrad            enddo
2361           enddo ! j
2362         enddo ! iint
2363       enddo ! i
2364       return
2365       end
2366 C--------------------------------------------------------------------------
2367       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2368      &              eello_turn4)
2369 C
2370 C Soft-sphere potential of p-p interaction
2371 C
2372       implicit real*8 (a-h,o-z)
2373       include 'DIMENSIONS'
2374       include 'COMMON.CONTROL'
2375       include 'COMMON.IOUNITS'
2376       include 'COMMON.GEO'
2377       include 'COMMON.VAR'
2378       include 'COMMON.LOCAL'
2379       include 'COMMON.CHAIN'
2380       include 'COMMON.DERIV'
2381       include 'COMMON.INTERACT'
2382       include 'COMMON.CONTACTS'
2383       include 'COMMON.TORSION'
2384       include 'COMMON.VECTORS'
2385       include 'COMMON.FFIELD'
2386       dimension ggg(3)
2387 C      write(iout,*) 'In EELEC_soft_sphere'
2388       ees=0.0D0
2389       evdw1=0.0D0
2390       eel_loc=0.0d0
2391       eello_turn3=0.0d0
2392       eello_turn4=0.0d0
2393       ind=0
2394       do i=iatel_s,iatel_e
2395         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2396         dxi=dc(1,i)
2397         dyi=dc(2,i)
2398         dzi=dc(3,i)
2399         xmedi=c(1,i)+0.5d0*dxi
2400         ymedi=c(2,i)+0.5d0*dyi
2401         zmedi=c(3,i)+0.5d0*dzi
2402           xmedi=mod(xmedi,boxxsize)
2403           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2404           ymedi=mod(ymedi,boxysize)
2405           if (ymedi.lt.0) ymedi=ymedi+boxysize
2406           zmedi=mod(zmedi,boxzsize)
2407           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2408         num_conti=0
2409 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2410         do j=ielstart(i),ielend(i)
2411           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2412           ind=ind+1
2413           iteli=itel(i)
2414           itelj=itel(j)
2415           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2416           r0ij=rpp(iteli,itelj)
2417           r0ijsq=r0ij*r0ij
2418           dxj=dc(1,j)
2419           dyj=dc(2,j)
2420           dzj=dc(3,j)
2421           xj=c(1,j)+0.5D0*dxj
2422           yj=c(2,j)+0.5D0*dyj
2423           zj=c(3,j)+0.5D0*dzj
2424           xj=mod(xj,boxxsize)
2425           if (xj.lt.0) xj=xj+boxxsize
2426           yj=mod(yj,boxysize)
2427           if (yj.lt.0) yj=yj+boxysize
2428           zj=mod(zj,boxzsize)
2429           if (zj.lt.0) zj=zj+boxzsize
2430       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2431       xj_safe=xj
2432       yj_safe=yj
2433       zj_safe=zj
2434       isubchap=0
2435       do xshift=-1,1
2436       do yshift=-1,1
2437       do zshift=-1,1
2438           xj=xj_safe+xshift*boxxsize
2439           yj=yj_safe+yshift*boxysize
2440           zj=zj_safe+zshift*boxzsize
2441           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2442           if(dist_temp.lt.dist_init) then
2443             dist_init=dist_temp
2444             xj_temp=xj
2445             yj_temp=yj
2446             zj_temp=zj
2447             isubchap=1
2448           endif
2449        enddo
2450        enddo
2451        enddo
2452        if (isubchap.eq.1) then
2453           xj=xj_temp-xmedi
2454           yj=yj_temp-ymedi
2455           zj=zj_temp-zmedi
2456        else
2457           xj=xj_safe-xmedi
2458           yj=yj_safe-ymedi
2459           zj=zj_safe-zmedi
2460        endif
2461           rij=xj*xj+yj*yj+zj*zj
2462             sss=sscale(sqrt(rij))
2463             sssgrad=sscagrad(sqrt(rij))
2464           if (rij.lt.r0ijsq) then
2465             evdw1ij=0.25d0*(rij-r0ijsq)**2
2466             fac=rij-r0ijsq
2467           else
2468             evdw1ij=0.0d0
2469             fac=0.0d0
2470           endif
2471           evdw1=evdw1+evdw1ij*sss
2472 C
2473 C Calculate contributions to the Cartesian gradient.
2474 C
2475           ggg(1)=fac*xj*sssgrad
2476           ggg(2)=fac*yj*sssgrad
2477           ggg(3)=fac*zj*sssgrad
2478           do k=1,3
2479             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2480             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2481           enddo
2482 *
2483 * Loop over residues i+1 thru j-1.
2484 *
2485 cgrad          do k=i+1,j-1
2486 cgrad            do l=1,3
2487 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2488 cgrad            enddo
2489 cgrad          enddo
2490         enddo ! j
2491       enddo   ! i
2492 cgrad      do i=nnt,nct-1
2493 cgrad        do k=1,3
2494 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2495 cgrad        enddo
2496 cgrad        do j=i+1,nct-1
2497 cgrad          do k=1,3
2498 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2499 cgrad          enddo
2500 cgrad        enddo
2501 cgrad      enddo
2502       return
2503       end
2504 c------------------------------------------------------------------------------
2505       subroutine vec_and_deriv
2506       implicit real*8 (a-h,o-z)
2507       include 'DIMENSIONS'
2508 #ifdef MPI
2509       include 'mpif.h'
2510 #endif
2511       include 'COMMON.IOUNITS'
2512       include 'COMMON.GEO'
2513       include 'COMMON.VAR'
2514       include 'COMMON.LOCAL'
2515       include 'COMMON.CHAIN'
2516       include 'COMMON.VECTORS'
2517       include 'COMMON.SETUP'
2518       include 'COMMON.TIME1'
2519       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2520 C Compute the local reference systems. For reference system (i), the
2521 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2522 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2523 #ifdef PARVEC
2524       do i=ivec_start,ivec_end
2525 #else
2526       do i=1,nres-1
2527 #endif
2528           if (i.eq.nres-1) then
2529 C Case of the last full residue
2530 C Compute the Z-axis
2531             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2532             costh=dcos(pi-theta(nres))
2533             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2534             do k=1,3
2535               uz(k,i)=fac*uz(k,i)
2536             enddo
2537 C Compute the derivatives of uz
2538             uzder(1,1,1)= 0.0d0
2539             uzder(2,1,1)=-dc_norm(3,i-1)
2540             uzder(3,1,1)= dc_norm(2,i-1)
2541             uzder(1,2,1)= dc_norm(3,i-1)
2542             uzder(2,2,1)= 0.0d0
2543             uzder(3,2,1)=-dc_norm(1,i-1)
2544             uzder(1,3,1)=-dc_norm(2,i-1)
2545             uzder(2,3,1)= dc_norm(1,i-1)
2546             uzder(3,3,1)= 0.0d0
2547             uzder(1,1,2)= 0.0d0
2548             uzder(2,1,2)= dc_norm(3,i)
2549             uzder(3,1,2)=-dc_norm(2,i)
2550             uzder(1,2,2)=-dc_norm(3,i)
2551             uzder(2,2,2)= 0.0d0
2552             uzder(3,2,2)= dc_norm(1,i)
2553             uzder(1,3,2)= dc_norm(2,i)
2554             uzder(2,3,2)=-dc_norm(1,i)
2555             uzder(3,3,2)= 0.0d0
2556 C Compute the Y-axis
2557             facy=fac
2558             do k=1,3
2559               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2560             enddo
2561 C Compute the derivatives of uy
2562             do j=1,3
2563               do k=1,3
2564                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2565      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2566                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2567               enddo
2568               uyder(j,j,1)=uyder(j,j,1)-costh
2569               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2570             enddo
2571             do j=1,2
2572               do k=1,3
2573                 do l=1,3
2574                   uygrad(l,k,j,i)=uyder(l,k,j)
2575                   uzgrad(l,k,j,i)=uzder(l,k,j)
2576                 enddo
2577               enddo
2578             enddo
2579             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2580             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2581             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2582             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2583           else
2584 C Other residues
2585 C Compute the Z-axis
2586             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2587             costh=dcos(pi-theta(i+2))
2588             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2589             do k=1,3
2590               uz(k,i)=fac*uz(k,i)
2591             enddo
2592 C Compute the derivatives of uz
2593             uzder(1,1,1)= 0.0d0
2594             uzder(2,1,1)=-dc_norm(3,i+1)
2595             uzder(3,1,1)= dc_norm(2,i+1)
2596             uzder(1,2,1)= dc_norm(3,i+1)
2597             uzder(2,2,1)= 0.0d0
2598             uzder(3,2,1)=-dc_norm(1,i+1)
2599             uzder(1,3,1)=-dc_norm(2,i+1)
2600             uzder(2,3,1)= dc_norm(1,i+1)
2601             uzder(3,3,1)= 0.0d0
2602             uzder(1,1,2)= 0.0d0
2603             uzder(2,1,2)= dc_norm(3,i)
2604             uzder(3,1,2)=-dc_norm(2,i)
2605             uzder(1,2,2)=-dc_norm(3,i)
2606             uzder(2,2,2)= 0.0d0
2607             uzder(3,2,2)= dc_norm(1,i)
2608             uzder(1,3,2)= dc_norm(2,i)
2609             uzder(2,3,2)=-dc_norm(1,i)
2610             uzder(3,3,2)= 0.0d0
2611 C Compute the Y-axis
2612             facy=fac
2613             do k=1,3
2614               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2615             enddo
2616 C Compute the derivatives of uy
2617             do j=1,3
2618               do k=1,3
2619                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2620      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2621                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2622               enddo
2623               uyder(j,j,1)=uyder(j,j,1)-costh
2624               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2625             enddo
2626             do j=1,2
2627               do k=1,3
2628                 do l=1,3
2629                   uygrad(l,k,j,i)=uyder(l,k,j)
2630                   uzgrad(l,k,j,i)=uzder(l,k,j)
2631                 enddo
2632               enddo
2633             enddo
2634             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2635             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2636             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2637             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2638           endif
2639       enddo
2640       do i=1,nres-1
2641         vbld_inv_temp(1)=vbld_inv(i+1)
2642         if (i.lt.nres-1) then
2643           vbld_inv_temp(2)=vbld_inv(i+2)
2644           else
2645           vbld_inv_temp(2)=vbld_inv(i)
2646           endif
2647         do j=1,2
2648           do k=1,3
2649             do l=1,3
2650               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2651               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2652             enddo
2653           enddo
2654         enddo
2655       enddo
2656 #if defined(PARVEC) && defined(MPI)
2657       if (nfgtasks1.gt.1) then
2658         time00=MPI_Wtime()
2659 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2660 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2661 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2662         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2663      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2664      &   FG_COMM1,IERR)
2665         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2666      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2667      &   FG_COMM1,IERR)
2668         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2669      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2670      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2671         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2672      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2673      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2674         time_gather=time_gather+MPI_Wtime()-time00
2675       endif
2676 c      if (fg_rank.eq.0) then
2677 c        write (iout,*) "Arrays UY and UZ"
2678 c        do i=1,nres-1
2679 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2680 c     &     (uz(k,i),k=1,3)
2681 c        enddo
2682 c      endif
2683 #endif
2684       return
2685       end
2686 C-----------------------------------------------------------------------------
2687       subroutine check_vecgrad
2688       implicit real*8 (a-h,o-z)
2689       include 'DIMENSIONS'
2690       include 'COMMON.IOUNITS'
2691       include 'COMMON.GEO'
2692       include 'COMMON.VAR'
2693       include 'COMMON.LOCAL'
2694       include 'COMMON.CHAIN'
2695       include 'COMMON.VECTORS'
2696       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2697       dimension uyt(3,maxres),uzt(3,maxres)
2698       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2699       double precision delta /1.0d-7/
2700       call vec_and_deriv
2701 cd      do i=1,nres
2702 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2703 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2704 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2705 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2706 cd     &     (dc_norm(if90,i),if90=1,3)
2707 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2708 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2709 cd          write(iout,'(a)')
2710 cd      enddo
2711       do i=1,nres
2712         do j=1,2
2713           do k=1,3
2714             do l=1,3
2715               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2716               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2717             enddo
2718           enddo
2719         enddo
2720       enddo
2721       call vec_and_deriv
2722       do i=1,nres
2723         do j=1,3
2724           uyt(j,i)=uy(j,i)
2725           uzt(j,i)=uz(j,i)
2726         enddo
2727       enddo
2728       do i=1,nres
2729 cd        write (iout,*) 'i=',i
2730         do k=1,3
2731           erij(k)=dc_norm(k,i)
2732         enddo
2733         do j=1,3
2734           do k=1,3
2735             dc_norm(k,i)=erij(k)
2736           enddo
2737           dc_norm(j,i)=dc_norm(j,i)+delta
2738 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2739 c          do k=1,3
2740 c            dc_norm(k,i)=dc_norm(k,i)/fac
2741 c          enddo
2742 c          write (iout,*) (dc_norm(k,i),k=1,3)
2743 c          write (iout,*) (erij(k),k=1,3)
2744           call vec_and_deriv
2745           do k=1,3
2746             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2747             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2748             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2749             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2750           enddo
2751 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2752 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2753 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2754         enddo
2755         do k=1,3
2756           dc_norm(k,i)=erij(k)
2757         enddo
2758 cd        do k=1,3
2759 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2760 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2761 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2762 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2763 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2764 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2765 cd          write (iout,'(a)')
2766 cd        enddo
2767       enddo
2768       return
2769       end
2770 C--------------------------------------------------------------------------
2771       subroutine set_matrices
2772       implicit real*8 (a-h,o-z)
2773       include 'DIMENSIONS'
2774 #ifdef MPI
2775       include "mpif.h"
2776       include "COMMON.SETUP"
2777       integer IERR
2778       integer status(MPI_STATUS_SIZE)
2779 #endif
2780       include 'COMMON.IOUNITS'
2781       include 'COMMON.GEO'
2782       include 'COMMON.VAR'
2783       include 'COMMON.LOCAL'
2784       include 'COMMON.CHAIN'
2785       include 'COMMON.DERIV'
2786       include 'COMMON.INTERACT'
2787       include 'COMMON.CONTACTS'
2788       include 'COMMON.TORSION'
2789       include 'COMMON.VECTORS'
2790       include 'COMMON.FFIELD'
2791       double precision auxvec(2),auxmat(2,2)
2792 C
2793 C Compute the virtual-bond-torsional-angle dependent quantities needed
2794 C to calculate the el-loc multibody terms of various order.
2795 C
2796 c      write(iout,*) 'nphi=',nphi,nres
2797 #ifdef PARMAT
2798       do i=ivec_start+2,ivec_end+2
2799 #else
2800       do i=3,nres+1
2801 #endif
2802 #ifdef NEWCORR
2803         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2804           iti = itype2loc(itype(i-2))
2805         else
2806           iti=nloctyp
2807         endif
2808 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2809         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2810           iti1 = itype2loc(itype(i-1))
2811         else
2812           iti1=nloctyp
2813         endif
2814 c        write(iout,*),i
2815         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2816      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2817      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2818         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2819      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2820      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2821 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2822 c     &*(cos(theta(i)/2.0)
2823         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2824      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2825      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2826 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2827 c     &*(cos(theta(i)/2.0)
2828         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2829      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2830      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2831 c        if (ggb1(1,i).eq.0.0d0) then
2832 c        write(iout,*) 'i=',i,ggb1(1,i),
2833 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2834 c     &bnew1(2,1,iti)*cos(theta(i)),
2835 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2836 c        endif
2837         b1(2,i-2)=bnew1(1,2,iti)
2838         gtb1(2,i-2)=0.0
2839         b2(2,i-2)=bnew2(1,2,iti)
2840         gtb2(2,i-2)=0.0
2841         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2842         EE(1,2,i-2)=eeold(1,2,iti)
2843         EE(2,1,i-2)=eeold(2,1,iti)
2844         EE(2,2,i-2)=eeold(2,2,iti)
2845         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2846         gtEE(1,2,i-2)=0.0d0
2847         gtEE(2,2,i-2)=0.0d0
2848         gtEE(2,1,i-2)=0.0d0
2849 c        EE(2,2,iti)=0.0d0
2850 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2851 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2852 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2853 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2854        b1tilde(1,i-2)=b1(1,i-2)
2855        b1tilde(2,i-2)=-b1(2,i-2)
2856        b2tilde(1,i-2)=b2(1,i-2)
2857        b2tilde(2,i-2)=-b2(2,i-2)
2858 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2859 c       write(iout,*)  'b1=',b1(1,i-2)
2860 c       write (iout,*) 'theta=', theta(i-1)
2861        enddo
2862 #else
2863         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2864           iti = itype2loc(itype(i-2))
2865         else
2866           iti=nloctyp
2867         endif
2868 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2869         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2870           iti1 = itype2loc(itype(i-1))
2871         else
2872           iti1=nloctyp
2873         endif
2874         b1(1,i-2)=b(3,iti)
2875         b1(2,i-2)=b(5,iti)
2876         b2(1,i-2)=b(2,iti)
2877         b2(2,i-2)=b(4,iti)
2878        b1tilde(1,i-2)=b1(1,i-2)
2879        b1tilde(2,i-2)=-b1(2,i-2)
2880        b2tilde(1,i-2)=b2(1,i-2)
2881        b2tilde(2,i-2)=-b2(2,i-2)
2882         EE(1,2,i-2)=eeold(1,2,iti)
2883         EE(2,1,i-2)=eeold(2,1,iti)
2884         EE(2,2,i-2)=eeold(2,2,iti)
2885         EE(1,1,i-2)=eeold(1,1,iti)
2886       enddo
2887 #endif
2888 #ifdef PARMAT
2889       do i=ivec_start+2,ivec_end+2
2890 #else
2891       do i=3,nres+1
2892 #endif
2893         if (i .lt. nres+1) then
2894           sin1=dsin(phi(i))
2895           cos1=dcos(phi(i))
2896           sintab(i-2)=sin1
2897           costab(i-2)=cos1
2898           obrot(1,i-2)=cos1
2899           obrot(2,i-2)=sin1
2900           sin2=dsin(2*phi(i))
2901           cos2=dcos(2*phi(i))
2902           sintab2(i-2)=sin2
2903           costab2(i-2)=cos2
2904           obrot2(1,i-2)=cos2
2905           obrot2(2,i-2)=sin2
2906           Ug(1,1,i-2)=-cos1
2907           Ug(1,2,i-2)=-sin1
2908           Ug(2,1,i-2)=-sin1
2909           Ug(2,2,i-2)= cos1
2910           Ug2(1,1,i-2)=-cos2
2911           Ug2(1,2,i-2)=-sin2
2912           Ug2(2,1,i-2)=-sin2
2913           Ug2(2,2,i-2)= cos2
2914         else
2915           costab(i-2)=1.0d0
2916           sintab(i-2)=0.0d0
2917           obrot(1,i-2)=1.0d0
2918           obrot(2,i-2)=0.0d0
2919           obrot2(1,i-2)=0.0d0
2920           obrot2(2,i-2)=0.0d0
2921           Ug(1,1,i-2)=1.0d0
2922           Ug(1,2,i-2)=0.0d0
2923           Ug(2,1,i-2)=0.0d0
2924           Ug(2,2,i-2)=1.0d0
2925           Ug2(1,1,i-2)=0.0d0
2926           Ug2(1,2,i-2)=0.0d0
2927           Ug2(2,1,i-2)=0.0d0
2928           Ug2(2,2,i-2)=0.0d0
2929         endif
2930         if (i .gt. 3 .and. i .lt. nres+1) then
2931           obrot_der(1,i-2)=-sin1
2932           obrot_der(2,i-2)= cos1
2933           Ugder(1,1,i-2)= sin1
2934           Ugder(1,2,i-2)=-cos1
2935           Ugder(2,1,i-2)=-cos1
2936           Ugder(2,2,i-2)=-sin1
2937           dwacos2=cos2+cos2
2938           dwasin2=sin2+sin2
2939           obrot2_der(1,i-2)=-dwasin2
2940           obrot2_der(2,i-2)= dwacos2
2941           Ug2der(1,1,i-2)= dwasin2
2942           Ug2der(1,2,i-2)=-dwacos2
2943           Ug2der(2,1,i-2)=-dwacos2
2944           Ug2der(2,2,i-2)=-dwasin2
2945         else
2946           obrot_der(1,i-2)=0.0d0
2947           obrot_der(2,i-2)=0.0d0
2948           Ugder(1,1,i-2)=0.0d0
2949           Ugder(1,2,i-2)=0.0d0
2950           Ugder(2,1,i-2)=0.0d0
2951           Ugder(2,2,i-2)=0.0d0
2952           obrot2_der(1,i-2)=0.0d0
2953           obrot2_der(2,i-2)=0.0d0
2954           Ug2der(1,1,i-2)=0.0d0
2955           Ug2der(1,2,i-2)=0.0d0
2956           Ug2der(2,1,i-2)=0.0d0
2957           Ug2der(2,2,i-2)=0.0d0
2958         endif
2959 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2960         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2961           iti = itype2loc(itype(i-2))
2962         else
2963           iti=nloctyp
2964         endif
2965 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2966         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2967           iti1 = itype2loc(itype(i-1))
2968         else
2969           iti1=nloctyp
2970         endif
2971 cd        write (iout,*) '*******i',i,' iti1',iti
2972 cd        write (iout,*) 'b1',b1(:,iti)
2973 cd        write (iout,*) 'b2',b2(:,iti)
2974 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2975 c        if (i .gt. iatel_s+2) then
2976         if (i .gt. nnt+2) then
2977           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2978 #ifdef NEWCORR
2979           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2980 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2981 #endif
2982 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2983 c     &    EE(1,2,iti),EE(2,2,i)
2984           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2985           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2986 c          write(iout,*) "Macierz EUG",
2987 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2988 c     &    eug(2,2,i-2)
2989           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2990      &    then
2991           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2992           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2993           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2994           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2995           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2996           endif
2997         else
2998           do k=1,2
2999             Ub2(k,i-2)=0.0d0
3000             Ctobr(k,i-2)=0.0d0
3001             Dtobr2(k,i-2)=0.0d0
3002             do l=1,2
3003               EUg(l,k,i-2)=0.0d0
3004               CUg(l,k,i-2)=0.0d0
3005               DUg(l,k,i-2)=0.0d0
3006               DtUg2(l,k,i-2)=0.0d0
3007             enddo
3008           enddo
3009         endif
3010         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3011         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3012         do k=1,2
3013           muder(k,i-2)=Ub2der(k,i-2)
3014         enddo
3015 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3016         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3017           if (itype(i-1).le.ntyp) then
3018             iti1 = itype2loc(itype(i-1))
3019           else
3020             iti1=nloctyp
3021           endif
3022         else
3023           iti1=nloctyp
3024         endif
3025         do k=1,2
3026           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3027         enddo
3028 #ifdef MUOUT
3029         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3030      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3031      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3032      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3033      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3034      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3035 #endif
3036 cd        write (iout,*) 'mu1',mu1(:,i-2)
3037 cd        write (iout,*) 'mu2',mu2(:,i-2)
3038         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3039      &  then
3040         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3041         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3042         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3043         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3044         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3045 C Vectors and matrices dependent on a single virtual-bond dihedral.
3046         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3047         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3048         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3049         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3050         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3051         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3052         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3053         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3054         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3055         endif
3056       enddo
3057 C Matrices dependent on two consecutive virtual-bond dihedrals.
3058 C The order of matrices is from left to right.
3059       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3060      &then
3061 c      do i=max0(ivec_start,2),ivec_end
3062       do i=2,nres-1
3063         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3064         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3065         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3066         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3067         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3068         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3069         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3070         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3071       enddo
3072       endif
3073 #if defined(MPI) && defined(PARMAT)
3074 #ifdef DEBUG
3075 c      if (fg_rank.eq.0) then
3076         write (iout,*) "Arrays UG and UGDER before GATHER"
3077         do i=1,nres-1
3078           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3079      &     ((ug(l,k,i),l=1,2),k=1,2),
3080      &     ((ugder(l,k,i),l=1,2),k=1,2)
3081         enddo
3082         write (iout,*) "Arrays UG2 and UG2DER"
3083         do i=1,nres-1
3084           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3085      &     ((ug2(l,k,i),l=1,2),k=1,2),
3086      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3087         enddo
3088         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3089         do i=1,nres-1
3090           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3091      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3092      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3093         enddo
3094         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3095         do i=1,nres-1
3096           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3097      &     costab(i),sintab(i),costab2(i),sintab2(i)
3098         enddo
3099         write (iout,*) "Array MUDER"
3100         do i=1,nres-1
3101           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3102         enddo
3103 c      endif
3104 #endif
3105       if (nfgtasks.gt.1) then
3106         time00=MPI_Wtime()
3107 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3108 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3109 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3110 #ifdef MATGATHER
3111         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3112      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3113      &   FG_COMM1,IERR)
3114         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3115      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3116      &   FG_COMM1,IERR)
3117         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3118      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3119      &   FG_COMM1,IERR)
3120         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3121      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3122      &   FG_COMM1,IERR)
3123         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3124      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3125      &   FG_COMM1,IERR)
3126         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3127      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3128      &   FG_COMM1,IERR)
3129         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3130      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3131      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3132         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3133      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3134      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3135         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3136      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3137      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3138         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3139      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3140      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3141         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3142      &  then
3143         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3144      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3145      &   FG_COMM1,IERR)
3146         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3147      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3148      &   FG_COMM1,IERR)
3149         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3150      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3151      &   FG_COMM1,IERR)
3152        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3153      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3154      &   FG_COMM1,IERR)
3155         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3156      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3157      &   FG_COMM1,IERR)
3158         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3159      &   ivec_count(fg_rank1),
3160      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3161      &   FG_COMM1,IERR)
3162         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3163      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3164      &   FG_COMM1,IERR)
3165         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3166      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3167      &   FG_COMM1,IERR)
3168         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3169      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3170      &   FG_COMM1,IERR)
3171         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3172      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3173      &   FG_COMM1,IERR)
3174         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3175      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3176      &   FG_COMM1,IERR)
3177         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3178      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3179      &   FG_COMM1,IERR)
3180         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3181      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3182      &   FG_COMM1,IERR)
3183         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3184      &   ivec_count(fg_rank1),
3185      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3186      &   FG_COMM1,IERR)
3187         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3188      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3189      &   FG_COMM1,IERR)
3190        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3191      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3192      &   FG_COMM1,IERR)
3193         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3194      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3195      &   FG_COMM1,IERR)
3196        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3197      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3198      &   FG_COMM1,IERR)
3199         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3200      &   ivec_count(fg_rank1),
3201      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3202      &   FG_COMM1,IERR)
3203         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3204      &   ivec_count(fg_rank1),
3205      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3206      &   FG_COMM1,IERR)
3207         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3208      &   ivec_count(fg_rank1),
3209      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3210      &   MPI_MAT2,FG_COMM1,IERR)
3211         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3212      &   ivec_count(fg_rank1),
3213      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3214      &   MPI_MAT2,FG_COMM1,IERR)
3215         endif
3216 #else
3217 c Passes matrix info through the ring
3218       isend=fg_rank1
3219       irecv=fg_rank1-1
3220       if (irecv.lt.0) irecv=nfgtasks1-1
3221       iprev=irecv
3222       inext=fg_rank1+1
3223       if (inext.ge.nfgtasks1) inext=0
3224       do i=1,nfgtasks1-1
3225 c        write (iout,*) "isend",isend," irecv",irecv
3226 c        call flush(iout)
3227         lensend=lentyp(isend)
3228         lenrecv=lentyp(irecv)
3229 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3230 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3231 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3232 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3233 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3234 c        write (iout,*) "Gather ROTAT1"
3235 c        call flush(iout)
3236 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3237 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3238 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3239 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3240 c        write (iout,*) "Gather ROTAT2"
3241 c        call flush(iout)
3242         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3243      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3244      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3245      &   iprev,4400+irecv,FG_COMM,status,IERR)
3246 c        write (iout,*) "Gather ROTAT_OLD"
3247 c        call flush(iout)
3248         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3249      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3250      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3251      &   iprev,5500+irecv,FG_COMM,status,IERR)
3252 c        write (iout,*) "Gather PRECOMP11"
3253 c        call flush(iout)
3254         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3255      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3256      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3257      &   iprev,6600+irecv,FG_COMM,status,IERR)
3258 c        write (iout,*) "Gather PRECOMP12"
3259 c        call flush(iout)
3260         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3261      &  then
3262         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3263      &   MPI_ROTAT2(lensend),inext,7700+isend,
3264      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3265      &   iprev,7700+irecv,FG_COMM,status,IERR)
3266 c        write (iout,*) "Gather PRECOMP21"
3267 c        call flush(iout)
3268         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3269      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3270      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3271      &   iprev,8800+irecv,FG_COMM,status,IERR)
3272 c        write (iout,*) "Gather PRECOMP22"
3273 c        call flush(iout)
3274         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3275      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3276      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3277      &   MPI_PRECOMP23(lenrecv),
3278      &   iprev,9900+irecv,FG_COMM,status,IERR)
3279 c        write (iout,*) "Gather PRECOMP23"
3280 c        call flush(iout)
3281         endif
3282         isend=irecv
3283         irecv=irecv-1
3284         if (irecv.lt.0) irecv=nfgtasks1-1
3285       enddo
3286 #endif
3287         time_gather=time_gather+MPI_Wtime()-time00
3288       endif
3289 #ifdef DEBUG
3290 c      if (fg_rank.eq.0) then
3291         write (iout,*) "Arrays UG and UGDER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     ((ug(l,k,i),l=1,2),k=1,2),
3295      &     ((ugder(l,k,i),l=1,2),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays UG2 and UG2DER"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300      &     ((ug2(l,k,i),l=1,2),k=1,2),
3301      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3302         enddo
3303         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3304         do i=1,nres-1
3305           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3306      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3307      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3308         enddo
3309         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3310         do i=1,nres-1
3311           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3312      &     costab(i),sintab(i),costab2(i),sintab2(i)
3313         enddo
3314         write (iout,*) "Array MUDER"
3315         do i=1,nres-1
3316           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3317         enddo
3318 c      endif
3319 #endif
3320 #endif
3321 cd      do i=1,nres
3322 cd        iti = itype2loc(itype(i))
3323 cd        write (iout,*) i
3324 cd        do j=1,2
3325 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3326 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3327 cd        enddo
3328 cd      enddo
3329       return
3330       end
3331 C--------------------------------------------------------------------------
3332       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3333 C
3334 C This subroutine calculates the average interaction energy and its gradient
3335 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3336 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3337 C The potential depends both on the distance of peptide-group centers and on
3338 C the orientation of the CA-CA virtual bonds.
3339 C
3340       implicit real*8 (a-h,o-z)
3341 #ifdef MPI
3342       include 'mpif.h'
3343 #endif
3344       include 'DIMENSIONS'
3345       include 'COMMON.CONTROL'
3346       include 'COMMON.SETUP'
3347       include 'COMMON.IOUNITS'
3348       include 'COMMON.GEO'
3349       include 'COMMON.VAR'
3350       include 'COMMON.LOCAL'
3351       include 'COMMON.CHAIN'
3352       include 'COMMON.DERIV'
3353       include 'COMMON.INTERACT'
3354       include 'COMMON.CONTACTS'
3355       include 'COMMON.TORSION'
3356       include 'COMMON.VECTORS'
3357       include 'COMMON.FFIELD'
3358       include 'COMMON.TIME1'
3359       include 'COMMON.SPLITELE'
3360       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3361      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3362       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3363      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3364       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3365      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3366      &    num_conti,j1,j2
3367 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3368 #ifdef MOMENT
3369       double precision scal_el /1.0d0/
3370 #else
3371       double precision scal_el /0.5d0/
3372 #endif
3373 C 12/13/98
3374 C 13-go grudnia roku pamietnego...
3375       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3376      &                   0.0d0,1.0d0,0.0d0,
3377      &                   0.0d0,0.0d0,1.0d0/
3378 cd      write(iout,*) 'In EELEC'
3379 cd      do i=1,nloctyp
3380 cd        write(iout,*) 'Type',i
3381 cd        write(iout,*) 'B1',B1(:,i)
3382 cd        write(iout,*) 'B2',B2(:,i)
3383 cd        write(iout,*) 'CC',CC(:,:,i)
3384 cd        write(iout,*) 'DD',DD(:,:,i)
3385 cd        write(iout,*) 'EE',EE(:,:,i)
3386 cd      enddo
3387 cd      call check_vecgrad
3388 cd      stop
3389       if (icheckgrad.eq.1) then
3390         do i=1,nres-1
3391           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3392           do k=1,3
3393             dc_norm(k,i)=dc(k,i)*fac
3394           enddo
3395 c          write (iout,*) 'i',i,' fac',fac
3396         enddo
3397       endif
3398       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3399      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3400      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3401 c        call vec_and_deriv
3402 #ifdef TIMING
3403         time01=MPI_Wtime()
3404 #endif
3405         call set_matrices
3406 #ifdef TIMING
3407         time_mat=time_mat+MPI_Wtime()-time01
3408 #endif
3409       endif
3410 cd      do i=1,nres-1
3411 cd        write (iout,*) 'i=',i
3412 cd        do k=1,3
3413 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3414 cd        enddo
3415 cd        do k=1,3
3416 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3417 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3418 cd        enddo
3419 cd      enddo
3420       t_eelecij=0.0d0
3421       ees=0.0D0
3422       evdw1=0.0D0
3423       eel_loc=0.0d0
3424       eello_turn3=0.0d0
3425       eello_turn4=0.0d0
3426       ind=0
3427       do i=1,nres
3428         num_cont_hb(i)=0
3429       enddo
3430 cd      print '(a)','Enter EELEC'
3431 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3432       do i=1,nres
3433         gel_loc_loc(i)=0.0d0
3434         gcorr_loc(i)=0.0d0
3435       enddo
3436 c
3437 c
3438 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3439 C
3440 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3441 C
3442 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3443       do i=iturn3_start,iturn3_end
3444 c        if (i.le.1) cycle
3445 C        write(iout,*) "tu jest i",i
3446         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3447 C changes suggested by Ana to avoid out of bounds
3448 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3449 c     & .or.((i+4).gt.nres)
3450 c     & .or.((i-1).le.0)
3451 C end of changes by Ana
3452      &  .or. itype(i+2).eq.ntyp1
3453      &  .or. itype(i+3).eq.ntyp1) cycle
3454 C Adam: Instructions below will switch off existing interactions
3455 c        if(i.gt.1)then
3456 c          if(itype(i-1).eq.ntyp1)cycle
3457 c        end if
3458 c        if(i.LT.nres-3)then
3459 c          if (itype(i+4).eq.ntyp1) cycle
3460 c        end if
3461         dxi=dc(1,i)
3462         dyi=dc(2,i)
3463         dzi=dc(3,i)
3464         dx_normi=dc_norm(1,i)
3465         dy_normi=dc_norm(2,i)
3466         dz_normi=dc_norm(3,i)
3467         xmedi=c(1,i)+0.5d0*dxi
3468         ymedi=c(2,i)+0.5d0*dyi
3469         zmedi=c(3,i)+0.5d0*dzi
3470           xmedi=mod(xmedi,boxxsize)
3471           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3472           ymedi=mod(ymedi,boxysize)
3473           if (ymedi.lt.0) ymedi=ymedi+boxysize
3474           zmedi=mod(zmedi,boxzsize)
3475           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3476         num_conti=0
3477         call eelecij(i,i+2,ees,evdw1,eel_loc)
3478         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3479         num_cont_hb(i)=num_conti
3480       enddo
3481       do i=iturn4_start,iturn4_end
3482         if (i.lt.1) cycle
3483         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3484 C changes suggested by Ana to avoid out of bounds
3485 c     & .or.((i+5).gt.nres)
3486 c     & .or.((i-1).le.0)
3487 C end of changes suggested by Ana
3488      &    .or. itype(i+3).eq.ntyp1
3489      &    .or. itype(i+4).eq.ntyp1
3490 c     &    .or. itype(i+5).eq.ntyp1
3491 c     &    .or. itype(i).eq.ntyp1
3492 c     &    .or. itype(i-1).eq.ntyp1
3493      &                             ) cycle
3494         dxi=dc(1,i)
3495         dyi=dc(2,i)
3496         dzi=dc(3,i)
3497         dx_normi=dc_norm(1,i)
3498         dy_normi=dc_norm(2,i)
3499         dz_normi=dc_norm(3,i)
3500         xmedi=c(1,i)+0.5d0*dxi
3501         ymedi=c(2,i)+0.5d0*dyi
3502         zmedi=c(3,i)+0.5d0*dzi
3503 C Return atom into box, boxxsize is size of box in x dimension
3504 c  194   continue
3505 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3506 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3507 C Condition for being inside the proper box
3508 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3509 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3510 c        go to 194
3511 c        endif
3512 c  195   continue
3513 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3514 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3515 C Condition for being inside the proper box
3516 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3517 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3518 c        go to 195
3519 c        endif
3520 c  196   continue
3521 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3522 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3523 C Condition for being inside the proper box
3524 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3525 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3526 c        go to 196
3527 c        endif
3528           xmedi=mod(xmedi,boxxsize)
3529           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3530           ymedi=mod(ymedi,boxysize)
3531           if (ymedi.lt.0) ymedi=ymedi+boxysize
3532           zmedi=mod(zmedi,boxzsize)
3533           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3534
3535         num_conti=num_cont_hb(i)
3536 c        write(iout,*) "JESTEM W PETLI"
3537         call eelecij(i,i+3,ees,evdw1,eel_loc)
3538         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3539      &   call eturn4(i,eello_turn4)
3540         num_cont_hb(i)=num_conti
3541       enddo   ! i
3542 C Loop over all neighbouring boxes
3543 C      do xshift=-1,1
3544 C      do yshift=-1,1
3545 C      do zshift=-1,1
3546 c
3547 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3548 c
3549 CTU KURWA
3550       do i=iatel_s,iatel_e
3551 C        do i=75,75
3552 c        if (i.le.1) cycle
3553         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3554 C changes suggested by Ana to avoid out of bounds
3555 c     & .or.((i+2).gt.nres)
3556 c     & .or.((i-1).le.0)
3557 C end of changes by Ana
3558 c     &  .or. itype(i+2).eq.ntyp1
3559 c     &  .or. itype(i-1).eq.ntyp1
3560      &                ) cycle
3561         dxi=dc(1,i)
3562         dyi=dc(2,i)
3563         dzi=dc(3,i)
3564         dx_normi=dc_norm(1,i)
3565         dy_normi=dc_norm(2,i)
3566         dz_normi=dc_norm(3,i)
3567         xmedi=c(1,i)+0.5d0*dxi
3568         ymedi=c(2,i)+0.5d0*dyi
3569         zmedi=c(3,i)+0.5d0*dzi
3570           xmedi=mod(xmedi,boxxsize)
3571           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3572           ymedi=mod(ymedi,boxysize)
3573           if (ymedi.lt.0) ymedi=ymedi+boxysize
3574           zmedi=mod(zmedi,boxzsize)
3575           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3576 C          xmedi=xmedi+xshift*boxxsize
3577 C          ymedi=ymedi+yshift*boxysize
3578 C          zmedi=zmedi+zshift*boxzsize
3579
3580 C Return tom into box, boxxsize is size of box in x dimension
3581 c  164   continue
3582 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3583 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3584 C Condition for being inside the proper box
3585 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3586 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3587 c        go to 164
3588 c        endif
3589 c  165   continue
3590 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3591 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3592 C Condition for being inside the proper box
3593 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3594 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3595 c        go to 165
3596 c        endif
3597 c  166   continue
3598 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3599 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3600 cC Condition for being inside the proper box
3601 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3602 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3603 c        go to 166
3604 c        endif
3605
3606 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3607         num_conti=num_cont_hb(i)
3608 C I TU KURWA
3609         do j=ielstart(i),ielend(i)
3610 C          do j=16,17
3611 C          write (iout,*) i,j
3612 C         if (j.le.1) cycle
3613           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3614 C changes suggested by Ana to avoid out of bounds
3615 c     & .or.((j+2).gt.nres)
3616 c     & .or.((j-1).le.0)
3617 C end of changes by Ana
3618 c     & .or.itype(j+2).eq.ntyp1
3619 c     & .or.itype(j-1).eq.ntyp1
3620      &) cycle
3621           call eelecij(i,j,ees,evdw1,eel_loc)
3622         enddo ! j
3623         num_cont_hb(i)=num_conti
3624       enddo   ! i
3625 C     enddo   ! zshift
3626 C      enddo   ! yshift
3627 C      enddo   ! xshift
3628
3629 c      write (iout,*) "Number of loop steps in EELEC:",ind
3630 cd      do i=1,nres
3631 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3632 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3633 cd      enddo
3634 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3635 ccc      eel_loc=eel_loc+eello_turn3
3636 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3637       return
3638       end
3639 C-------------------------------------------------------------------------------
3640       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3641       implicit real*8 (a-h,o-z)
3642       include 'DIMENSIONS'
3643 #ifdef MPI
3644       include "mpif.h"
3645 #endif
3646       include 'COMMON.CONTROL'
3647       include 'COMMON.IOUNITS'
3648       include 'COMMON.GEO'
3649       include 'COMMON.VAR'
3650       include 'COMMON.LOCAL'
3651       include 'COMMON.CHAIN'
3652       include 'COMMON.DERIV'
3653       include 'COMMON.INTERACT'
3654       include 'COMMON.CONTACTS'
3655       include 'COMMON.TORSION'
3656       include 'COMMON.VECTORS'
3657       include 'COMMON.FFIELD'
3658       include 'COMMON.TIME1'
3659       include 'COMMON.SPLITELE'
3660       include 'COMMON.SHIELD'
3661       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3662      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3663       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3664      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3665      &    gmuij2(4),gmuji2(4)
3666       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3667      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3668      &    num_conti,j1,j2
3669 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3670 #ifdef MOMENT
3671       double precision scal_el /1.0d0/
3672 #else
3673       double precision scal_el /0.5d0/
3674 #endif
3675 C 12/13/98
3676 C 13-go grudnia roku pamietnego...
3677       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3678      &                   0.0d0,1.0d0,0.0d0,
3679      &                   0.0d0,0.0d0,1.0d0/
3680        integer xshift,yshift,zshift
3681 c          time00=MPI_Wtime()
3682 cd      write (iout,*) "eelecij",i,j
3683 c          ind=ind+1
3684           iteli=itel(i)
3685           itelj=itel(j)
3686           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3687           aaa=app(iteli,itelj)
3688           bbb=bpp(iteli,itelj)
3689           ael6i=ael6(iteli,itelj)
3690           ael3i=ael3(iteli,itelj)
3691           dxj=dc(1,j)
3692           dyj=dc(2,j)
3693           dzj=dc(3,j)
3694           dx_normj=dc_norm(1,j)
3695           dy_normj=dc_norm(2,j)
3696           dz_normj=dc_norm(3,j)
3697 C          xj=c(1,j)+0.5D0*dxj-xmedi
3698 C          yj=c(2,j)+0.5D0*dyj-ymedi
3699 C          zj=c(3,j)+0.5D0*dzj-zmedi
3700           xj=c(1,j)+0.5D0*dxj
3701           yj=c(2,j)+0.5D0*dyj
3702           zj=c(3,j)+0.5D0*dzj
3703           xj=mod(xj,boxxsize)
3704           if (xj.lt.0) xj=xj+boxxsize
3705           yj=mod(yj,boxysize)
3706           if (yj.lt.0) yj=yj+boxysize
3707           zj=mod(zj,boxzsize)
3708           if (zj.lt.0) zj=zj+boxzsize
3709           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3710       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3711       xj_safe=xj
3712       yj_safe=yj
3713       zj_safe=zj
3714       isubchap=0
3715       do xshift=-1,1
3716       do yshift=-1,1
3717       do zshift=-1,1
3718           xj=xj_safe+xshift*boxxsize
3719           yj=yj_safe+yshift*boxysize
3720           zj=zj_safe+zshift*boxzsize
3721           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3722           if(dist_temp.lt.dist_init) then
3723             dist_init=dist_temp
3724             xj_temp=xj
3725             yj_temp=yj
3726             zj_temp=zj
3727             isubchap=1
3728           endif
3729        enddo
3730        enddo
3731        enddo
3732        if (isubchap.eq.1) then
3733           xj=xj_temp-xmedi
3734           yj=yj_temp-ymedi
3735           zj=zj_temp-zmedi
3736        else
3737           xj=xj_safe-xmedi
3738           yj=yj_safe-ymedi
3739           zj=zj_safe-zmedi
3740        endif
3741 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3742 c  174   continue
3743 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3744 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3745 C Condition for being inside the proper box
3746 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3747 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3748 c        go to 174
3749 c        endif
3750 c  175   continue
3751 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3752 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3753 C Condition for being inside the proper box
3754 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3755 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3756 c        go to 175
3757 c        endif
3758 c  176   continue
3759 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3760 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3761 C Condition for being inside the proper box
3762 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3763 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3764 c        go to 176
3765 c        endif
3766 C        endif !endPBC condintion
3767 C        xj=xj-xmedi
3768 C        yj=yj-ymedi
3769 C        zj=zj-zmedi
3770           rij=xj*xj+yj*yj+zj*zj
3771
3772             sss=sscale(sqrt(rij))
3773             sssgrad=sscagrad(sqrt(rij))
3774 c            if (sss.gt.0.0d0) then
3775           rrmij=1.0D0/rij
3776           rij=dsqrt(rij)
3777           rmij=1.0D0/rij
3778           r3ij=rrmij*rmij
3779           r6ij=r3ij*r3ij
3780           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3781           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3782           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3783           fac=cosa-3.0D0*cosb*cosg
3784           ev1=aaa*r6ij*r6ij
3785 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3786           if (j.eq.i+2) ev1=scal_el*ev1
3787           ev2=bbb*r6ij
3788           fac3=ael6i*r6ij
3789           fac4=ael3i*r3ij
3790           evdwij=(ev1+ev2)
3791           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3792           el2=fac4*fac
3793 C MARYSIA
3794 C          eesij=(el1+el2)
3795 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3796           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3797           if (shield_mode.gt.0) then
3798 C          fac_shield(i)=0.4
3799 C          fac_shield(j)=0.6
3800           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3801           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3802           eesij=(el1+el2)
3803           ees=ees+eesij
3804           else
3805           fac_shield(i)=1.0
3806           fac_shield(j)=1.0
3807           eesij=(el1+el2)
3808           ees=ees+eesij
3809           endif
3810           evdw1=evdw1+evdwij*sss
3811 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3812 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3813 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3814 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3815
3816           if (energy_dec) then
3817               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3818      &'evdw1',i,j,evdwij
3819      &,iteli,itelj,aaa,evdw1
3820               write (iout,*) sss
3821               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3822      &fac_shield(i),fac_shield(j)
3823           endif
3824
3825 C
3826 C Calculate contributions to the Cartesian gradient.
3827 C
3828 #ifdef SPLITELE
3829           facvdw=-6*rrmij*(ev1+evdwij)*sss
3830           facel=-3*rrmij*(el1+eesij)
3831           fac1=fac
3832           erij(1)=xj*rmij
3833           erij(2)=yj*rmij
3834           erij(3)=zj*rmij
3835
3836 *
3837 * Radial derivatives. First process both termini of the fragment (i,j)
3838 *
3839           ggg(1)=facel*xj
3840           ggg(2)=facel*yj
3841           ggg(3)=facel*zj
3842           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3843      &  (shield_mode.gt.0)) then
3844 C          print *,i,j
3845           do ilist=1,ishield_list(i)
3846            iresshield=shield_list(ilist,i)
3847            do k=1,3
3848            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3849      &      *2.0
3850            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3851      &              rlocshield
3852      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3853             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3854 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3855 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3856 C             if (iresshield.gt.i) then
3857 C               do ishi=i+1,iresshield-1
3858 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3859 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3860 C
3861 C              enddo
3862 C             else
3863 C               do ishi=iresshield,i
3864 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3865 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3866 C
3867 C               enddo
3868 C              endif
3869            enddo
3870           enddo
3871           do ilist=1,ishield_list(j)
3872            iresshield=shield_list(ilist,j)
3873            do k=1,3
3874            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3875      &     *2.0
3876            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3877      &              rlocshield
3878      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3879            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3880
3881 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3882 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3883 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3884 C             if (iresshield.gt.j) then
3885 C               do ishi=j+1,iresshield-1
3886 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3887 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3888 C
3889 C               enddo
3890 C            else
3891 C               do ishi=iresshield,j
3892 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3893 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3894 C               enddo
3895 C              endif
3896            enddo
3897           enddo
3898
3899           do k=1,3
3900             gshieldc(k,i)=gshieldc(k,i)+
3901      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3902             gshieldc(k,j)=gshieldc(k,j)+
3903      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3904             gshieldc(k,i-1)=gshieldc(k,i-1)+
3905      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3906             gshieldc(k,j-1)=gshieldc(k,j-1)+
3907      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3908
3909            enddo
3910            endif
3911 c          do k=1,3
3912 c            ghalf=0.5D0*ggg(k)
3913 c            gelc(k,i)=gelc(k,i)+ghalf
3914 c            gelc(k,j)=gelc(k,j)+ghalf
3915 c          enddo
3916 c 9/28/08 AL Gradient compotents will be summed only at the end
3917 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3918           do k=1,3
3919             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3920 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3921             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3922 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3923 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3924 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3925 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3926 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3927           enddo
3928 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3929
3930 *
3931 * Loop over residues i+1 thru j-1.
3932 *
3933 cgrad          do k=i+1,j-1
3934 cgrad            do l=1,3
3935 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3936 cgrad            enddo
3937 cgrad          enddo
3938           if (sss.gt.0.0) then
3939           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3940           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3941           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3942           else
3943           ggg(1)=0.0
3944           ggg(2)=0.0
3945           ggg(3)=0.0
3946           endif
3947 c          do k=1,3
3948 c            ghalf=0.5D0*ggg(k)
3949 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3950 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3951 c          enddo
3952 c 9/28/08 AL Gradient compotents will be summed only at the end
3953           do k=1,3
3954             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3955             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3956           enddo
3957 *
3958 * Loop over residues i+1 thru j-1.
3959 *
3960 cgrad          do k=i+1,j-1
3961 cgrad            do l=1,3
3962 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3963 cgrad            enddo
3964 cgrad          enddo
3965 #else
3966 C MARYSIA
3967           facvdw=(ev1+evdwij)*sss
3968           facel=(el1+eesij)
3969           fac1=fac
3970           fac=-3*rrmij*(facvdw+facvdw+facel)
3971           erij(1)=xj*rmij
3972           erij(2)=yj*rmij
3973           erij(3)=zj*rmij
3974 *
3975 * Radial derivatives. First process both termini of the fragment (i,j)
3976 *
3977           ggg(1)=fac*xj
3978 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3979           ggg(2)=fac*yj
3980 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3981           ggg(3)=fac*zj
3982 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3983 c          do k=1,3
3984 c            ghalf=0.5D0*ggg(k)
3985 c            gelc(k,i)=gelc(k,i)+ghalf
3986 c            gelc(k,j)=gelc(k,j)+ghalf
3987 c          enddo
3988 c 9/28/08 AL Gradient compotents will be summed only at the end
3989           do k=1,3
3990             gelc_long(k,j)=gelc(k,j)+ggg(k)
3991             gelc_long(k,i)=gelc(k,i)-ggg(k)
3992           enddo
3993 *
3994 * Loop over residues i+1 thru j-1.
3995 *
3996 cgrad          do k=i+1,j-1
3997 cgrad            do l=1,3
3998 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3999 cgrad            enddo
4000 cgrad          enddo
4001 c 9/28/08 AL Gradient compotents will be summed only at the end
4002           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4003           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4004           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4005           do k=1,3
4006             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4007             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4008           enddo
4009 #endif
4010 *
4011 * Angular part
4012 *
4013           ecosa=2.0D0*fac3*fac1+fac4
4014           fac4=-3.0D0*fac4
4015           fac3=-6.0D0*fac3
4016           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4017           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4018           do k=1,3
4019             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4020             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4021           enddo
4022 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4023 cd   &          (dcosg(k),k=1,3)
4024           do k=1,3
4025             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4026      &      fac_shield(i)**2*fac_shield(j)**2
4027           enddo
4028 c          do k=1,3
4029 c            ghalf=0.5D0*ggg(k)
4030 c            gelc(k,i)=gelc(k,i)+ghalf
4031 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4032 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4033 c            gelc(k,j)=gelc(k,j)+ghalf
4034 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4035 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4036 c          enddo
4037 cgrad          do k=i+1,j-1
4038 cgrad            do l=1,3
4039 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4040 cgrad            enddo
4041 cgrad          enddo
4042 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4043           do k=1,3
4044             gelc(k,i)=gelc(k,i)
4045      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4046      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4047      &           *fac_shield(i)**2*fac_shield(j)**2
4048             gelc(k,j)=gelc(k,j)
4049      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4050      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4051      &           *fac_shield(i)**2*fac_shield(j)**2
4052             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4053             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4054           enddo
4055 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4056
4057 C MARYSIA
4058 c          endif !sscale
4059           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4060      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4061      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4062 C
4063 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4064 C   energy of a peptide unit is assumed in the form of a second-order
4065 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4066 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4067 C   are computed for EVERY pair of non-contiguous peptide groups.
4068 C
4069
4070           if (j.lt.nres-1) then
4071             j1=j+1
4072             j2=j-1
4073           else
4074             j1=j-1
4075             j2=j-2
4076           endif
4077           kkk=0
4078           lll=0
4079           do k=1,2
4080             do l=1,2
4081               kkk=kkk+1
4082               muij(kkk)=mu(k,i)*mu(l,j)
4083 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4084 #ifdef NEWCORR
4085              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4086 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4087              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4088              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4089 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4090              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4091 #endif
4092             enddo
4093           enddo
4094 cd         write (iout,*) 'EELEC: i',i,' j',j
4095 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4096 cd          write(iout,*) 'muij',muij
4097           ury=scalar(uy(1,i),erij)
4098           urz=scalar(uz(1,i),erij)
4099           vry=scalar(uy(1,j),erij)
4100           vrz=scalar(uz(1,j),erij)
4101           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4102           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4103           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4104           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4105           fac=dsqrt(-ael6i)*r3ij
4106           a22=a22*fac
4107           a23=a23*fac
4108           a32=a32*fac
4109           a33=a33*fac
4110 cd          write (iout,'(4i5,4f10.5)')
4111 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4112 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4113 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4114 cd     &      uy(:,j),uz(:,j)
4115 cd          write (iout,'(4f10.5)')
4116 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4117 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4118 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4119 cd           write (iout,'(9f10.5/)')
4120 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4121 C Derivatives of the elements of A in virtual-bond vectors
4122           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4123           do k=1,3
4124             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4125             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4126             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4127             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4128             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4129             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4130             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4131             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4132             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4133             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4134             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4135             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4136           enddo
4137 C Compute radial contributions to the gradient
4138           facr=-3.0d0*rrmij
4139           a22der=a22*facr
4140           a23der=a23*facr
4141           a32der=a32*facr
4142           a33der=a33*facr
4143           agg(1,1)=a22der*xj
4144           agg(2,1)=a22der*yj
4145           agg(3,1)=a22der*zj
4146           agg(1,2)=a23der*xj
4147           agg(2,2)=a23der*yj
4148           agg(3,2)=a23der*zj
4149           agg(1,3)=a32der*xj
4150           agg(2,3)=a32der*yj
4151           agg(3,3)=a32der*zj
4152           agg(1,4)=a33der*xj
4153           agg(2,4)=a33der*yj
4154           agg(3,4)=a33der*zj
4155 C Add the contributions coming from er
4156           fac3=-3.0d0*fac
4157           do k=1,3
4158             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4159             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4160             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4161             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4162           enddo
4163           do k=1,3
4164 C Derivatives in DC(i)
4165 cgrad            ghalf1=0.5d0*agg(k,1)
4166 cgrad            ghalf2=0.5d0*agg(k,2)
4167 cgrad            ghalf3=0.5d0*agg(k,3)
4168 cgrad            ghalf4=0.5d0*agg(k,4)
4169             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4170      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4171             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4172      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4173             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4174      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4175             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4176      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4177 C Derivatives in DC(i+1)
4178             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4179      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4180             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4181      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4182             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4183      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4184             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4185      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4186 C Derivatives in DC(j)
4187             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4188      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4189             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4190      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4191             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4192      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4193             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4194      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4195 C Derivatives in DC(j+1) or DC(nres-1)
4196             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4197      &      -3.0d0*vryg(k,3)*ury)
4198             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4199      &      -3.0d0*vrzg(k,3)*ury)
4200             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4201      &      -3.0d0*vryg(k,3)*urz)
4202             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4203      &      -3.0d0*vrzg(k,3)*urz)
4204 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4205 cgrad              do l=1,4
4206 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4207 cgrad              enddo
4208 cgrad            endif
4209           enddo
4210           acipa(1,1)=a22
4211           acipa(1,2)=a23
4212           acipa(2,1)=a32
4213           acipa(2,2)=a33
4214           a22=-a22
4215           a23=-a23
4216           do l=1,2
4217             do k=1,3
4218               agg(k,l)=-agg(k,l)
4219               aggi(k,l)=-aggi(k,l)
4220               aggi1(k,l)=-aggi1(k,l)
4221               aggj(k,l)=-aggj(k,l)
4222               aggj1(k,l)=-aggj1(k,l)
4223             enddo
4224           enddo
4225           if (j.lt.nres-1) then
4226             a22=-a22
4227             a32=-a32
4228             do l=1,3,2
4229               do k=1,3
4230                 agg(k,l)=-agg(k,l)
4231                 aggi(k,l)=-aggi(k,l)
4232                 aggi1(k,l)=-aggi1(k,l)
4233                 aggj(k,l)=-aggj(k,l)
4234                 aggj1(k,l)=-aggj1(k,l)
4235               enddo
4236             enddo
4237           else
4238             a22=-a22
4239             a23=-a23
4240             a32=-a32
4241             a33=-a33
4242             do l=1,4
4243               do k=1,3
4244                 agg(k,l)=-agg(k,l)
4245                 aggi(k,l)=-aggi(k,l)
4246                 aggi1(k,l)=-aggi1(k,l)
4247                 aggj(k,l)=-aggj(k,l)
4248                 aggj1(k,l)=-aggj1(k,l)
4249               enddo
4250             enddo
4251           endif
4252           ENDIF ! WCORR
4253           IF (wel_loc.gt.0.0d0) THEN
4254 C Contribution to the local-electrostatic energy coming from the i-j pair
4255           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4256      &     +a33*muij(4)
4257           if (shield_mode.eq.0) then
4258            fac_shield(i)=1.0
4259            fac_shield(j)=1.0
4260 C          else
4261 C           fac_shield(i)=0.4
4262 C           fac_shield(j)=0.6
4263           endif
4264           eel_loc_ij=eel_loc_ij
4265      &    *fac_shield(i)*fac_shield(j)
4266 C Now derivative over eel_loc
4267           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4268      &  (shield_mode.gt.0)) then
4269 C          print *,i,j
4270
4271           do ilist=1,ishield_list(i)
4272            iresshield=shield_list(ilist,i)
4273            do k=1,3
4274            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4275      &                                          /fac_shield(i)
4276 C     &      *2.0
4277            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4278      &              rlocshield
4279      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4280             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4281      &      +rlocshield
4282            enddo
4283           enddo
4284           do ilist=1,ishield_list(j)
4285            iresshield=shield_list(ilist,j)
4286            do k=1,3
4287            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4288      &                                       /fac_shield(j)
4289 C     &     *2.0
4290            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4291      &              rlocshield
4292      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4293            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4294      &             +rlocshield
4295
4296            enddo
4297           enddo
4298
4299           do k=1,3
4300             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4301      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4302             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4303      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4304             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4305      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4306             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4307      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4308            enddo
4309            endif
4310
4311
4312 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4313 c     &                     ' eel_loc_ij',eel_loc_ij
4314 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4315 C Calculate patrial derivative for theta angle
4316 #ifdef NEWCORR
4317          geel_loc_ij=(a22*gmuij1(1)
4318      &     +a23*gmuij1(2)
4319      &     +a32*gmuij1(3)
4320      &     +a33*gmuij1(4))
4321      &    *fac_shield(i)*fac_shield(j)
4322 c         write(iout,*) "derivative over thatai"
4323 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4324 c     &   a33*gmuij1(4)
4325          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4326      &      geel_loc_ij*wel_loc
4327 c         write(iout,*) "derivative over thatai-1"
4328 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4329 c     &   a33*gmuij2(4)
4330          geel_loc_ij=
4331      &     a22*gmuij2(1)
4332      &     +a23*gmuij2(2)
4333      &     +a32*gmuij2(3)
4334      &     +a33*gmuij2(4)
4335          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4336      &      geel_loc_ij*wel_loc
4337      &    *fac_shield(i)*fac_shield(j)
4338
4339 c  Derivative over j residue
4340          geel_loc_ji=a22*gmuji1(1)
4341      &     +a23*gmuji1(2)
4342      &     +a32*gmuji1(3)
4343      &     +a33*gmuji1(4)
4344 c         write(iout,*) "derivative over thataj"
4345 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4346 c     &   a33*gmuji1(4)
4347
4348         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4349      &      geel_loc_ji*wel_loc
4350      &    *fac_shield(i)*fac_shield(j)
4351
4352          geel_loc_ji=
4353      &     +a22*gmuji2(1)
4354      &     +a23*gmuji2(2)
4355      &     +a32*gmuji2(3)
4356      &     +a33*gmuji2(4)
4357 c         write(iout,*) "derivative over thataj-1"
4358 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4359 c     &   a33*gmuji2(4)
4360          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4361      &      geel_loc_ji*wel_loc
4362      &    *fac_shield(i)*fac_shield(j)
4363 #endif
4364 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4365
4366           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4367      &            'eelloc',i,j,eel_loc_ij
4368 c           if (eel_loc_ij.ne.0)
4369 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4370 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4371
4372           eel_loc=eel_loc+eel_loc_ij
4373 C Partial derivatives in virtual-bond dihedral angles gamma
4374           if (i.gt.1)
4375      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4376      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4377      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4378      &    *fac_shield(i)*fac_shield(j)
4379
4380           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4381      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4382      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4383      &    *fac_shield(i)*fac_shield(j)
4384 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4385           do l=1,3
4386             ggg(l)=(agg(l,1)*muij(1)+
4387      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4388      &    *fac_shield(i)*fac_shield(j)
4389             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4390             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4391 cgrad            ghalf=0.5d0*ggg(l)
4392 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4393 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4394           enddo
4395 cgrad          do k=i+1,j2
4396 cgrad            do l=1,3
4397 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4398 cgrad            enddo
4399 cgrad          enddo
4400 C Remaining derivatives of eello
4401           do l=1,3
4402             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4403      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4404      &    *fac_shield(i)*fac_shield(j)
4405
4406             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4407      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4408      &    *fac_shield(i)*fac_shield(j)
4409
4410             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4411      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4412      &    *fac_shield(i)*fac_shield(j)
4413
4414             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4415      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4416      &    *fac_shield(i)*fac_shield(j)
4417
4418           enddo
4419           ENDIF
4420 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4421 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4422           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4423      &       .and. num_conti.le.maxconts) then
4424 c            write (iout,*) i,j," entered corr"
4425 C
4426 C Calculate the contact function. The ith column of the array JCONT will
4427 C contain the numbers of atoms that make contacts with the atom I (of numbers
4428 C greater than I). The arrays FACONT and GACONT will contain the values of
4429 C the contact function and its derivative.
4430 c           r0ij=1.02D0*rpp(iteli,itelj)
4431 c           r0ij=1.11D0*rpp(iteli,itelj)
4432             r0ij=2.20D0*rpp(iteli,itelj)
4433 c           r0ij=1.55D0*rpp(iteli,itelj)
4434             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4435             if (fcont.gt.0.0D0) then
4436               num_conti=num_conti+1
4437               if (num_conti.gt.maxconts) then
4438                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4439      &                         ' will skip next contacts for this conf.'
4440               else
4441                 jcont_hb(num_conti,i)=j
4442 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4443 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4444                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4445      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4446 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4447 C  terms.
4448                 d_cont(num_conti,i)=rij
4449 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4450 C     --- Electrostatic-interaction matrix ---
4451                 a_chuj(1,1,num_conti,i)=a22
4452                 a_chuj(1,2,num_conti,i)=a23
4453                 a_chuj(2,1,num_conti,i)=a32
4454                 a_chuj(2,2,num_conti,i)=a33
4455 C     --- Gradient of rij
4456                 do kkk=1,3
4457                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4458                 enddo
4459                 kkll=0
4460                 do k=1,2
4461                   do l=1,2
4462                     kkll=kkll+1
4463                     do m=1,3
4464                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4465                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4466                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4467                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4468                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4469                     enddo
4470                   enddo
4471                 enddo
4472                 ENDIF
4473                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4474 C Calculate contact energies
4475                 cosa4=4.0D0*cosa
4476                 wij=cosa-3.0D0*cosb*cosg
4477                 cosbg1=cosb+cosg
4478                 cosbg2=cosb-cosg
4479 c               fac3=dsqrt(-ael6i)/r0ij**3
4480                 fac3=dsqrt(-ael6i)*r3ij
4481 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4482                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4483                 if (ees0tmp.gt.0) then
4484                   ees0pij=dsqrt(ees0tmp)
4485                 else
4486                   ees0pij=0
4487                 endif
4488 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4489                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4490                 if (ees0tmp.gt.0) then
4491                   ees0mij=dsqrt(ees0tmp)
4492                 else
4493                   ees0mij=0
4494                 endif
4495 c               ees0mij=0.0D0
4496                 if (shield_mode.eq.0) then
4497                 fac_shield(i)=1.0d0
4498                 fac_shield(j)=1.0d0
4499                 else
4500                 ees0plist(num_conti,i)=j
4501 C                fac_shield(i)=0.4d0
4502 C                fac_shield(j)=0.6d0
4503                 endif
4504                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4505      &          *fac_shield(i)*fac_shield(j)
4506                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4507      &          *fac_shield(i)*fac_shield(j)
4508 C Diagnostics. Comment out or remove after debugging!
4509 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4510 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4511 c               ees0m(num_conti,i)=0.0D0
4512 C End diagnostics.
4513 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4514 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4515 C Angular derivatives of the contact function
4516                 ees0pij1=fac3/ees0pij
4517                 ees0mij1=fac3/ees0mij
4518                 fac3p=-3.0D0*fac3*rrmij
4519                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4520                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4521 c               ees0mij1=0.0D0
4522                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4523                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4524                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4525                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4526                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4527                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4528                 ecosap=ecosa1+ecosa2
4529                 ecosbp=ecosb1+ecosb2
4530                 ecosgp=ecosg1+ecosg2
4531                 ecosam=ecosa1-ecosa2
4532                 ecosbm=ecosb1-ecosb2
4533                 ecosgm=ecosg1-ecosg2
4534 C Diagnostics
4535 c               ecosap=ecosa1
4536 c               ecosbp=ecosb1
4537 c               ecosgp=ecosg1
4538 c               ecosam=0.0D0
4539 c               ecosbm=0.0D0
4540 c               ecosgm=0.0D0
4541 C End diagnostics
4542                 facont_hb(num_conti,i)=fcont
4543                 fprimcont=fprimcont/rij
4544 cd              facont_hb(num_conti,i)=1.0D0
4545 C Following line is for diagnostics.
4546 cd              fprimcont=0.0D0
4547                 do k=1,3
4548                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4549                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4550                 enddo
4551                 do k=1,3
4552                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4553                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4554                 enddo
4555                 gggp(1)=gggp(1)+ees0pijp*xj
4556                 gggp(2)=gggp(2)+ees0pijp*yj
4557                 gggp(3)=gggp(3)+ees0pijp*zj
4558                 gggm(1)=gggm(1)+ees0mijp*xj
4559                 gggm(2)=gggm(2)+ees0mijp*yj
4560                 gggm(3)=gggm(3)+ees0mijp*zj
4561 C Derivatives due to the contact function
4562                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4563                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4564                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4565                 do k=1,3
4566 c
4567 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4568 c          following the change of gradient-summation algorithm.
4569 c
4570 cgrad                  ghalfp=0.5D0*gggp(k)
4571 cgrad                  ghalfm=0.5D0*gggm(k)
4572                   gacontp_hb1(k,num_conti,i)=!ghalfp
4573      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4574      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4575      &          *fac_shield(i)*fac_shield(j)
4576
4577                   gacontp_hb2(k,num_conti,i)=!ghalfp
4578      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4579      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4580      &          *fac_shield(i)*fac_shield(j)
4581
4582                   gacontp_hb3(k,num_conti,i)=gggp(k)
4583      &          *fac_shield(i)*fac_shield(j)
4584
4585                   gacontm_hb1(k,num_conti,i)=!ghalfm
4586      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4587      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4588      &          *fac_shield(i)*fac_shield(j)
4589
4590                   gacontm_hb2(k,num_conti,i)=!ghalfm
4591      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4592      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4593      &          *fac_shield(i)*fac_shield(j)
4594
4595                   gacontm_hb3(k,num_conti,i)=gggm(k)
4596      &          *fac_shield(i)*fac_shield(j)
4597
4598                 enddo
4599 C Diagnostics. Comment out or remove after debugging!
4600 cdiag           do k=1,3
4601 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4602 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4603 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4604 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4605 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4606 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4607 cdiag           enddo
4608               ENDIF ! wcorr
4609               endif  ! num_conti.le.maxconts
4610             endif  ! fcont.gt.0
4611           endif    ! j.gt.i+1
4612           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4613             do k=1,4
4614               do l=1,3
4615                 ghalf=0.5d0*agg(l,k)
4616                 aggi(l,k)=aggi(l,k)+ghalf
4617                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4618                 aggj(l,k)=aggj(l,k)+ghalf
4619               enddo
4620             enddo
4621             if (j.eq.nres-1 .and. i.lt.j-2) then
4622               do k=1,4
4623                 do l=1,3
4624                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4625                 enddo
4626               enddo
4627             endif
4628           endif
4629 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4630       return
4631       end
4632 C-----------------------------------------------------------------------------
4633       subroutine eturn3(i,eello_turn3)
4634 C Third- and fourth-order contributions from turns
4635       implicit real*8 (a-h,o-z)
4636       include 'DIMENSIONS'
4637       include 'COMMON.IOUNITS'
4638       include 'COMMON.GEO'
4639       include 'COMMON.VAR'
4640       include 'COMMON.LOCAL'
4641       include 'COMMON.CHAIN'
4642       include 'COMMON.DERIV'
4643       include 'COMMON.INTERACT'
4644       include 'COMMON.CONTACTS'
4645       include 'COMMON.TORSION'
4646       include 'COMMON.VECTORS'
4647       include 'COMMON.FFIELD'
4648       include 'COMMON.CONTROL'
4649       include 'COMMON.SHIELD'
4650       dimension ggg(3)
4651       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4652      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4653      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4654      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4655      &  auxgmat2(2,2),auxgmatt2(2,2)
4656       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4657      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4658       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4659      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4660      &    num_conti,j1,j2
4661       j=i+2
4662 c      write (iout,*) "eturn3",i,j,j1,j2
4663       a_temp(1,1)=a22
4664       a_temp(1,2)=a23
4665       a_temp(2,1)=a32
4666       a_temp(2,2)=a33
4667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4668 C
4669 C               Third-order contributions
4670 C
4671 C                 (i+2)o----(i+3)
4672 C                      | |
4673 C                      | |
4674 C                 (i+1)o----i
4675 C
4676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4677 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4678         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4679 c auxalary matices for theta gradient
4680 c auxalary matrix for i+1 and constant i+2
4681         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4682 c auxalary matrix for i+2 and constant i+1
4683         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4684         call transpose2(auxmat(1,1),auxmat1(1,1))
4685         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4686         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4687         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4688         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4689         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4690         if (shield_mode.eq.0) then
4691         fac_shield(i)=1.0
4692         fac_shield(j)=1.0
4693 C        else
4694 C        fac_shield(i)=0.4
4695 C        fac_shield(j)=0.6
4696         endif
4697         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4698      &  *fac_shield(i)*fac_shield(j)
4699         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4700      &  *fac_shield(i)*fac_shield(j)
4701 C#ifdef NEWCORR
4702 C Derivatives in theta
4703         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4704      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4705      &   *fac_shield(i)*fac_shield(j)
4706         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4707      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4708      &   *fac_shield(i)*fac_shield(j)
4709 C#endif
4710
4711 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4712 C Derivatives in shield mode
4713           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4714      &  (shield_mode.gt.0)) then
4715 C          print *,i,j
4716
4717           do ilist=1,ishield_list(i)
4718            iresshield=shield_list(ilist,i)
4719            do k=1,3
4720            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4721 C     &      *2.0
4722            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4723      &              rlocshield
4724      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4725             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4726      &      +rlocshield
4727            enddo
4728           enddo
4729           do ilist=1,ishield_list(j)
4730            iresshield=shield_list(ilist,j)
4731            do k=1,3
4732            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4733 C     &     *2.0
4734            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4735      &              rlocshield
4736      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4737            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4738      &             +rlocshield
4739
4740            enddo
4741           enddo
4742
4743           do k=1,3
4744             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4745      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4746             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4747      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4748             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4749      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4750             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4751      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4752            enddo
4753            endif
4754
4755 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4756 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4757 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4758 cd     &    ' eello_turn3_num',4*eello_turn3_num
4759 C Derivatives in gamma(i)
4760         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4761         call transpose2(auxmat2(1,1),auxmat3(1,1))
4762         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4763         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4764      &   *fac_shield(i)*fac_shield(j)
4765 C Derivatives in gamma(i+1)
4766         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4767         call transpose2(auxmat2(1,1),auxmat3(1,1))
4768         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4769         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4770      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4771      &   *fac_shield(i)*fac_shield(j)
4772 C Cartesian derivatives
4773         do l=1,3
4774 c            ghalf1=0.5d0*agg(l,1)
4775 c            ghalf2=0.5d0*agg(l,2)
4776 c            ghalf3=0.5d0*agg(l,3)
4777 c            ghalf4=0.5d0*agg(l,4)
4778           a_temp(1,1)=aggi(l,1)!+ghalf1
4779           a_temp(1,2)=aggi(l,2)!+ghalf2
4780           a_temp(2,1)=aggi(l,3)!+ghalf3
4781           a_temp(2,2)=aggi(l,4)!+ghalf4
4782           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4783           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4784      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4785      &   *fac_shield(i)*fac_shield(j)
4786
4787           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4788           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4789           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4790           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4791           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4792           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4793      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4794      &   *fac_shield(i)*fac_shield(j)
4795           a_temp(1,1)=aggj(l,1)!+ghalf1
4796           a_temp(1,2)=aggj(l,2)!+ghalf2
4797           a_temp(2,1)=aggj(l,3)!+ghalf3
4798           a_temp(2,2)=aggj(l,4)!+ghalf4
4799           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4800           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4801      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4802      &   *fac_shield(i)*fac_shield(j)
4803           a_temp(1,1)=aggj1(l,1)
4804           a_temp(1,2)=aggj1(l,2)
4805           a_temp(2,1)=aggj1(l,3)
4806           a_temp(2,2)=aggj1(l,4)
4807           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4808           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4809      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4810      &   *fac_shield(i)*fac_shield(j)
4811         enddo
4812       return
4813       end
4814 C-------------------------------------------------------------------------------
4815       subroutine eturn4(i,eello_turn4)
4816 C Third- and fourth-order contributions from turns
4817       implicit real*8 (a-h,o-z)
4818       include 'DIMENSIONS'
4819       include 'COMMON.IOUNITS'
4820       include 'COMMON.GEO'
4821       include 'COMMON.VAR'
4822       include 'COMMON.LOCAL'
4823       include 'COMMON.CHAIN'
4824       include 'COMMON.DERIV'
4825       include 'COMMON.INTERACT'
4826       include 'COMMON.CONTACTS'
4827       include 'COMMON.TORSION'
4828       include 'COMMON.VECTORS'
4829       include 'COMMON.FFIELD'
4830       include 'COMMON.CONTROL'
4831       include 'COMMON.SHIELD'
4832       dimension ggg(3)
4833       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4834      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4835      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4836      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4837      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4838      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4839      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4840       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4841      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4842       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4843      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4844      &    num_conti,j1,j2
4845       j=i+3
4846 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4847 C
4848 C               Fourth-order contributions
4849 C
4850 C                 (i+3)o----(i+4)
4851 C                     /  |
4852 C               (i+2)o   |
4853 C                     \  |
4854 C                 (i+1)o----i
4855 C
4856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4857 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4858 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4859 c        write(iout,*)"WCHODZE W PROGRAM"
4860         a_temp(1,1)=a22
4861         a_temp(1,2)=a23
4862         a_temp(2,1)=a32
4863         a_temp(2,2)=a33
4864         iti1=itype2loc(itype(i+1))
4865         iti2=itype2loc(itype(i+2))
4866         iti3=itype2loc(itype(i+3))
4867 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4868         call transpose2(EUg(1,1,i+1),e1t(1,1))
4869         call transpose2(Eug(1,1,i+2),e2t(1,1))
4870         call transpose2(Eug(1,1,i+3),e3t(1,1))
4871 C Ematrix derivative in theta
4872         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4873         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4874         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4875         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4876 c       eta1 in derivative theta
4877         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4878         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4879 c       auxgvec is derivative of Ub2 so i+3 theta
4880         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4881 c       auxalary matrix of E i+1
4882         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4883 c        s1=0.0
4884 c        gs1=0.0
4885         s1=scalar2(b1(1,i+2),auxvec(1))
4886 c derivative of theta i+2 with constant i+3
4887         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4888 c derivative of theta i+2 with constant i+2
4889         gs32=scalar2(b1(1,i+2),auxgvec(1))
4890 c derivative of E matix in theta of i+1
4891         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4892
4893         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4894 c       ea31 in derivative theta
4895         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4896         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4897 c auxilary matrix auxgvec of Ub2 with constant E matirx
4898         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4899 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4900         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4901
4902 c        s2=0.0
4903 c        gs2=0.0
4904         s2=scalar2(b1(1,i+1),auxvec(1))
4905 c derivative of theta i+1 with constant i+3
4906         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4907 c derivative of theta i+2 with constant i+1
4908         gs21=scalar2(b1(1,i+1),auxgvec(1))
4909 c derivative of theta i+3 with constant i+1
4910         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4911 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4912 c     &  gtb1(1,i+1)
4913         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4914 c two derivatives over diffetent matrices
4915 c gtae3e2 is derivative over i+3
4916         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4917 c ae3gte2 is derivative over i+2
4918         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4919         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4920 c three possible derivative over theta E matices
4921 c i+1
4922         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4923 c i+2
4924         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4925 c i+3
4926         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4927         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4928
4929         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4930         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4931         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4932         if (shield_mode.eq.0) then
4933         fac_shield(i)=1.0
4934         fac_shield(j)=1.0
4935 C        else
4936 C        fac_shield(i)=0.6
4937 C        fac_shield(j)=0.4
4938         endif
4939         eello_turn4=eello_turn4-(s1+s2+s3)
4940      &  *fac_shield(i)*fac_shield(j)
4941         eello_t4=-(s1+s2+s3)
4942      &  *fac_shield(i)*fac_shield(j)
4943 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4944         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4945      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4946 C Now derivative over shield:
4947           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4948      &  (shield_mode.gt.0)) then
4949 C          print *,i,j
4950
4951           do ilist=1,ishield_list(i)
4952            iresshield=shield_list(ilist,i)
4953            do k=1,3
4954            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4955 C     &      *2.0
4956            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4957      &              rlocshield
4958      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4959             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4960      &      +rlocshield
4961            enddo
4962           enddo
4963           do ilist=1,ishield_list(j)
4964            iresshield=shield_list(ilist,j)
4965            do k=1,3
4966            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4967 C     &     *2.0
4968            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4969      &              rlocshield
4970      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4971            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4972      &             +rlocshield
4973
4974            enddo
4975           enddo
4976
4977           do k=1,3
4978             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4979      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4980             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4981      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4982             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4983      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4984             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4985      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4986            enddo
4987            endif
4988
4989
4990
4991
4992
4993
4994 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4995 cd     &    ' eello_turn4_num',8*eello_turn4_num
4996 #ifdef NEWCORR
4997         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4998      &                  -(gs13+gsE13+gsEE1)*wturn4
4999      &  *fac_shield(i)*fac_shield(j)
5000         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5001      &                    -(gs23+gs21+gsEE2)*wturn4
5002      &  *fac_shield(i)*fac_shield(j)
5003
5004         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5005      &                    -(gs32+gsE31+gsEE3)*wturn4
5006      &  *fac_shield(i)*fac_shield(j)
5007
5008 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5009 c     &   gs2
5010 #endif
5011         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5012      &      'eturn4',i,j,-(s1+s2+s3)
5013 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5014 c     &    ' eello_turn4_num',8*eello_turn4_num
5015 C Derivatives in gamma(i)
5016         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5017         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5018         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5019         s1=scalar2(b1(1,i+2),auxvec(1))
5020         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5021         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5022         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5023      &  *fac_shield(i)*fac_shield(j)
5024 C Derivatives in gamma(i+1)
5025         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5026         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5027         s2=scalar2(b1(1,i+1),auxvec(1))
5028         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5029         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5030         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5031         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5032      &  *fac_shield(i)*fac_shield(j)
5033 C Derivatives in gamma(i+2)
5034         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5035         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5036         s1=scalar2(b1(1,i+2),auxvec(1))
5037         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5038         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5039         s2=scalar2(b1(1,i+1),auxvec(1))
5040         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5041         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5042         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5043         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5044      &  *fac_shield(i)*fac_shield(j)
5045 C Cartesian derivatives
5046 C Derivatives of this turn contributions in DC(i+2)
5047         if (j.lt.nres-1) then
5048           do l=1,3
5049             a_temp(1,1)=agg(l,1)
5050             a_temp(1,2)=agg(l,2)
5051             a_temp(2,1)=agg(l,3)
5052             a_temp(2,2)=agg(l,4)
5053             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5054             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5055             s1=scalar2(b1(1,i+2),auxvec(1))
5056             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5057             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5058             s2=scalar2(b1(1,i+1),auxvec(1))
5059             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5060             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5061             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5062             ggg(l)=-(s1+s2+s3)
5063             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5064      &  *fac_shield(i)*fac_shield(j)
5065           enddo
5066         endif
5067 C Remaining derivatives of this turn contribution
5068         do l=1,3
5069           a_temp(1,1)=aggi(l,1)
5070           a_temp(1,2)=aggi(l,2)
5071           a_temp(2,1)=aggi(l,3)
5072           a_temp(2,2)=aggi(l,4)
5073           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5074           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5075           s1=scalar2(b1(1,i+2),auxvec(1))
5076           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5077           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5078           s2=scalar2(b1(1,i+1),auxvec(1))
5079           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5080           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5081           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5082           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5083      &  *fac_shield(i)*fac_shield(j)
5084           a_temp(1,1)=aggi1(l,1)
5085           a_temp(1,2)=aggi1(l,2)
5086           a_temp(2,1)=aggi1(l,3)
5087           a_temp(2,2)=aggi1(l,4)
5088           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5089           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5090           s1=scalar2(b1(1,i+2),auxvec(1))
5091           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5092           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5093           s2=scalar2(b1(1,i+1),auxvec(1))
5094           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5095           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5096           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5097           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5098      &  *fac_shield(i)*fac_shield(j)
5099           a_temp(1,1)=aggj(l,1)
5100           a_temp(1,2)=aggj(l,2)
5101           a_temp(2,1)=aggj(l,3)
5102           a_temp(2,2)=aggj(l,4)
5103           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5104           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5105           s1=scalar2(b1(1,i+2),auxvec(1))
5106           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5107           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5108           s2=scalar2(b1(1,i+1),auxvec(1))
5109           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5110           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5111           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5112           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5113      &  *fac_shield(i)*fac_shield(j)
5114           a_temp(1,1)=aggj1(l,1)
5115           a_temp(1,2)=aggj1(l,2)
5116           a_temp(2,1)=aggj1(l,3)
5117           a_temp(2,2)=aggj1(l,4)
5118           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5119           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5120           s1=scalar2(b1(1,i+2),auxvec(1))
5121           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5122           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5123           s2=scalar2(b1(1,i+1),auxvec(1))
5124           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5125           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5126           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5127 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5128           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5129      &  *fac_shield(i)*fac_shield(j)
5130         enddo
5131       return
5132       end
5133 C-----------------------------------------------------------------------------
5134       subroutine vecpr(u,v,w)
5135       implicit real*8(a-h,o-z)
5136       dimension u(3),v(3),w(3)
5137       w(1)=u(2)*v(3)-u(3)*v(2)
5138       w(2)=-u(1)*v(3)+u(3)*v(1)
5139       w(3)=u(1)*v(2)-u(2)*v(1)
5140       return
5141       end
5142 C-----------------------------------------------------------------------------
5143       subroutine unormderiv(u,ugrad,unorm,ungrad)
5144 C This subroutine computes the derivatives of a normalized vector u, given
5145 C the derivatives computed without normalization conditions, ugrad. Returns
5146 C ungrad.
5147       implicit none
5148       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5149       double precision vec(3)
5150       double precision scalar
5151       integer i,j
5152 c      write (2,*) 'ugrad',ugrad
5153 c      write (2,*) 'u',u
5154       do i=1,3
5155         vec(i)=scalar(ugrad(1,i),u(1))
5156       enddo
5157 c      write (2,*) 'vec',vec
5158       do i=1,3
5159         do j=1,3
5160           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5161         enddo
5162       enddo
5163 c      write (2,*) 'ungrad',ungrad
5164       return
5165       end
5166 C-----------------------------------------------------------------------------
5167       subroutine escp_soft_sphere(evdw2,evdw2_14)
5168 C
5169 C This subroutine calculates the excluded-volume interaction energy between
5170 C peptide-group centers and side chains and its gradient in virtual-bond and
5171 C side-chain vectors.
5172 C
5173       implicit real*8 (a-h,o-z)
5174       include 'DIMENSIONS'
5175       include 'COMMON.GEO'
5176       include 'COMMON.VAR'
5177       include 'COMMON.LOCAL'
5178       include 'COMMON.CHAIN'
5179       include 'COMMON.DERIV'
5180       include 'COMMON.INTERACT'
5181       include 'COMMON.FFIELD'
5182       include 'COMMON.IOUNITS'
5183       include 'COMMON.CONTROL'
5184       dimension ggg(3)
5185       evdw2=0.0D0
5186       evdw2_14=0.0d0
5187       r0_scp=4.5d0
5188 cd    print '(a)','Enter ESCP'
5189 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5190 C      do xshift=-1,1
5191 C      do yshift=-1,1
5192 C      do zshift=-1,1
5193       do i=iatscp_s,iatscp_e
5194         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5195         iteli=itel(i)
5196         xi=0.5D0*(c(1,i)+c(1,i+1))
5197         yi=0.5D0*(c(2,i)+c(2,i+1))
5198         zi=0.5D0*(c(3,i)+c(3,i+1))
5199 C Return atom into box, boxxsize is size of box in x dimension
5200 c  134   continue
5201 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5202 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5203 C Condition for being inside the proper box
5204 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5205 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5206 c        go to 134
5207 c        endif
5208 c  135   continue
5209 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5210 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5211 C Condition for being inside the proper box
5212 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5213 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5214 c        go to 135
5215 c c       endif
5216 c  136   continue
5217 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5218 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5219 cC Condition for being inside the proper box
5220 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5221 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5222 c        go to 136
5223 c        endif
5224           xi=mod(xi,boxxsize)
5225           if (xi.lt.0) xi=xi+boxxsize
5226           yi=mod(yi,boxysize)
5227           if (yi.lt.0) yi=yi+boxysize
5228           zi=mod(zi,boxzsize)
5229           if (zi.lt.0) zi=zi+boxzsize
5230 C          xi=xi+xshift*boxxsize
5231 C          yi=yi+yshift*boxysize
5232 C          zi=zi+zshift*boxzsize
5233         do iint=1,nscp_gr(i)
5234
5235         do j=iscpstart(i,iint),iscpend(i,iint)
5236           if (itype(j).eq.ntyp1) cycle
5237           itypj=iabs(itype(j))
5238 C Uncomment following three lines for SC-p interactions
5239 c         xj=c(1,nres+j)-xi
5240 c         yj=c(2,nres+j)-yi
5241 c         zj=c(3,nres+j)-zi
5242 C Uncomment following three lines for Ca-p interactions
5243           xj=c(1,j)
5244           yj=c(2,j)
5245           zj=c(3,j)
5246 c  174   continue
5247 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5248 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5249 C Condition for being inside the proper box
5250 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5251 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5252 c        go to 174
5253 c        endif
5254 c  175   continue
5255 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5256 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5257 cC Condition for being inside the proper box
5258 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5259 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5260 c        go to 175
5261 c        endif
5262 c  176   continue
5263 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5264 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5265 C Condition for being inside the proper box
5266 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5267 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5268 c        go to 176
5269           xj=mod(xj,boxxsize)
5270           if (xj.lt.0) xj=xj+boxxsize
5271           yj=mod(yj,boxysize)
5272           if (yj.lt.0) yj=yj+boxysize
5273           zj=mod(zj,boxzsize)
5274           if (zj.lt.0) zj=zj+boxzsize
5275       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5276       xj_safe=xj
5277       yj_safe=yj
5278       zj_safe=zj
5279       subchap=0
5280       do xshift=-1,1
5281       do yshift=-1,1
5282       do zshift=-1,1
5283           xj=xj_safe+xshift*boxxsize
5284           yj=yj_safe+yshift*boxysize
5285           zj=zj_safe+zshift*boxzsize
5286           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5287           if(dist_temp.lt.dist_init) then
5288             dist_init=dist_temp
5289             xj_temp=xj
5290             yj_temp=yj
5291             zj_temp=zj
5292             subchap=1
5293           endif
5294        enddo
5295        enddo
5296        enddo
5297        if (subchap.eq.1) then
5298           xj=xj_temp-xi
5299           yj=yj_temp-yi
5300           zj=zj_temp-zi
5301        else
5302           xj=xj_safe-xi
5303           yj=yj_safe-yi
5304           zj=zj_safe-zi
5305        endif
5306 c c       endif
5307 C          xj=xj-xi
5308 C          yj=yj-yi
5309 C          zj=zj-zi
5310           rij=xj*xj+yj*yj+zj*zj
5311
5312           r0ij=r0_scp
5313           r0ijsq=r0ij*r0ij
5314           if (rij.lt.r0ijsq) then
5315             evdwij=0.25d0*(rij-r0ijsq)**2
5316             fac=rij-r0ijsq
5317           else
5318             evdwij=0.0d0
5319             fac=0.0d0
5320           endif
5321           evdw2=evdw2+evdwij
5322 C
5323 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5324 C
5325           ggg(1)=xj*fac
5326           ggg(2)=yj*fac
5327           ggg(3)=zj*fac
5328 cgrad          if (j.lt.i) then
5329 cd          write (iout,*) 'j<i'
5330 C Uncomment following three lines for SC-p interactions
5331 c           do k=1,3
5332 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5333 c           enddo
5334 cgrad          else
5335 cd          write (iout,*) 'j>i'
5336 cgrad            do k=1,3
5337 cgrad              ggg(k)=-ggg(k)
5338 C Uncomment following line for SC-p interactions
5339 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5340 cgrad            enddo
5341 cgrad          endif
5342 cgrad          do k=1,3
5343 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5344 cgrad          enddo
5345 cgrad          kstart=min0(i+1,j)
5346 cgrad          kend=max0(i-1,j-1)
5347 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5348 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5349 cgrad          do k=kstart,kend
5350 cgrad            do l=1,3
5351 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5352 cgrad            enddo
5353 cgrad          enddo
5354           do k=1,3
5355             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5356             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5357           enddo
5358         enddo
5359
5360         enddo ! iint
5361       enddo ! i
5362 C      enddo !zshift
5363 C      enddo !yshift
5364 C      enddo !xshift
5365       return
5366       end
5367 C-----------------------------------------------------------------------------
5368       subroutine escp(evdw2,evdw2_14)
5369 C
5370 C This subroutine calculates the excluded-volume interaction energy between
5371 C peptide-group centers and side chains and its gradient in virtual-bond and
5372 C side-chain vectors.
5373 C
5374       implicit real*8 (a-h,o-z)
5375       include 'DIMENSIONS'
5376       include 'COMMON.GEO'
5377       include 'COMMON.VAR'
5378       include 'COMMON.LOCAL'
5379       include 'COMMON.CHAIN'
5380       include 'COMMON.DERIV'
5381       include 'COMMON.INTERACT'
5382       include 'COMMON.FFIELD'
5383       include 'COMMON.IOUNITS'
5384       include 'COMMON.CONTROL'
5385       include 'COMMON.SPLITELE'
5386       dimension ggg(3)
5387       evdw2=0.0D0
5388       evdw2_14=0.0d0
5389 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5390 cd    print '(a)','Enter ESCP'
5391 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5392 C      do xshift=-1,1
5393 C      do yshift=-1,1
5394 C      do zshift=-1,1
5395       do i=iatscp_s,iatscp_e
5396         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5397         iteli=itel(i)
5398         xi=0.5D0*(c(1,i)+c(1,i+1))
5399         yi=0.5D0*(c(2,i)+c(2,i+1))
5400         zi=0.5D0*(c(3,i)+c(3,i+1))
5401           xi=mod(xi,boxxsize)
5402           if (xi.lt.0) xi=xi+boxxsize
5403           yi=mod(yi,boxysize)
5404           if (yi.lt.0) yi=yi+boxysize
5405           zi=mod(zi,boxzsize)
5406           if (zi.lt.0) zi=zi+boxzsize
5407 c          xi=xi+xshift*boxxsize
5408 c          yi=yi+yshift*boxysize
5409 c          zi=zi+zshift*boxzsize
5410 c        print *,xi,yi,zi,'polozenie i'
5411 C Return atom into box, boxxsize is size of box in x dimension
5412 c  134   continue
5413 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5414 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5415 C Condition for being inside the proper box
5416 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5417 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5418 c        go to 134
5419 c        endif
5420 c  135   continue
5421 c          print *,xi,boxxsize,"pierwszy"
5422
5423 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5424 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5425 C Condition for being inside the proper box
5426 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5427 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5428 c        go to 135
5429 c        endif
5430 c  136   continue
5431 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5432 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5433 C Condition for being inside the proper box
5434 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5435 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5436 c        go to 136
5437 c        endif
5438         do iint=1,nscp_gr(i)
5439
5440         do j=iscpstart(i,iint),iscpend(i,iint)
5441           itypj=iabs(itype(j))
5442           if (itypj.eq.ntyp1) cycle
5443 C Uncomment following three lines for SC-p interactions
5444 c         xj=c(1,nres+j)-xi
5445 c         yj=c(2,nres+j)-yi
5446 c         zj=c(3,nres+j)-zi
5447 C Uncomment following three lines for Ca-p interactions
5448           xj=c(1,j)
5449           yj=c(2,j)
5450           zj=c(3,j)
5451           xj=mod(xj,boxxsize)
5452           if (xj.lt.0) xj=xj+boxxsize
5453           yj=mod(yj,boxysize)
5454           if (yj.lt.0) yj=yj+boxysize
5455           zj=mod(zj,boxzsize)
5456           if (zj.lt.0) zj=zj+boxzsize
5457 c  174   continue
5458 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5459 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5460 C Condition for being inside the proper box
5461 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5462 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5463 c        go to 174
5464 c        endif
5465 c  175   continue
5466 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5467 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5468 cC Condition for being inside the proper box
5469 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5470 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5471 c        go to 175
5472 c        endif
5473 c  176   continue
5474 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5475 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5476 C Condition for being inside the proper box
5477 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5478 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5479 c        go to 176
5480 c        endif
5481 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5482       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5483       xj_safe=xj
5484       yj_safe=yj
5485       zj_safe=zj
5486       subchap=0
5487       do xshift=-1,1
5488       do yshift=-1,1
5489       do zshift=-1,1
5490           xj=xj_safe+xshift*boxxsize
5491           yj=yj_safe+yshift*boxysize
5492           zj=zj_safe+zshift*boxzsize
5493           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5494           if(dist_temp.lt.dist_init) then
5495             dist_init=dist_temp
5496             xj_temp=xj
5497             yj_temp=yj
5498             zj_temp=zj
5499             subchap=1
5500           endif
5501        enddo
5502        enddo
5503        enddo
5504        if (subchap.eq.1) then
5505           xj=xj_temp-xi
5506           yj=yj_temp-yi
5507           zj=zj_temp-zi
5508        else
5509           xj=xj_safe-xi
5510           yj=yj_safe-yi
5511           zj=zj_safe-zi
5512        endif
5513 c          print *,xj,yj,zj,'polozenie j'
5514           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5515 c          print *,rrij
5516           sss=sscale(1.0d0/(dsqrt(rrij)))
5517 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5518 c          if (sss.eq.0) print *,'czasem jest OK'
5519           if (sss.le.0.0d0) cycle
5520           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5521           fac=rrij**expon2
5522           e1=fac*fac*aad(itypj,iteli)
5523           e2=fac*bad(itypj,iteli)
5524           if (iabs(j-i) .le. 2) then
5525             e1=scal14*e1
5526             e2=scal14*e2
5527             evdw2_14=evdw2_14+(e1+e2)*sss
5528           endif
5529           evdwij=e1+e2
5530           evdw2=evdw2+evdwij*sss
5531           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5532      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5533      &       bad(itypj,iteli)
5534 C
5535 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5536 C
5537           fac=-(evdwij+e1)*rrij*sss
5538           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5539           ggg(1)=xj*fac
5540           ggg(2)=yj*fac
5541           ggg(3)=zj*fac
5542 cgrad          if (j.lt.i) then
5543 cd          write (iout,*) 'j<i'
5544 C Uncomment following three lines for SC-p interactions
5545 c           do k=1,3
5546 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5547 c           enddo
5548 cgrad          else
5549 cd          write (iout,*) 'j>i'
5550 cgrad            do k=1,3
5551 cgrad              ggg(k)=-ggg(k)
5552 C Uncomment following line for SC-p interactions
5553 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5554 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5555 cgrad            enddo
5556 cgrad          endif
5557 cgrad          do k=1,3
5558 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5559 cgrad          enddo
5560 cgrad          kstart=min0(i+1,j)
5561 cgrad          kend=max0(i-1,j-1)
5562 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5563 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5564 cgrad          do k=kstart,kend
5565 cgrad            do l=1,3
5566 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5567 cgrad            enddo
5568 cgrad          enddo
5569           do k=1,3
5570             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5571             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5572           enddo
5573 c        endif !endif for sscale cutoff
5574         enddo ! j
5575
5576         enddo ! iint
5577       enddo ! i
5578 c      enddo !zshift
5579 c      enddo !yshift
5580 c      enddo !xshift
5581       do i=1,nct
5582         do j=1,3
5583           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5584           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5585           gradx_scp(j,i)=expon*gradx_scp(j,i)
5586         enddo
5587       enddo
5588 C******************************************************************************
5589 C
5590 C                              N O T E !!!
5591 C
5592 C To save time the factor EXPON has been extracted from ALL components
5593 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5594 C use!
5595 C
5596 C******************************************************************************
5597       return
5598       end
5599 C--------------------------------------------------------------------------
5600       subroutine edis(ehpb)
5601 C
5602 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5603 C
5604       implicit real*8 (a-h,o-z)
5605       include 'DIMENSIONS'
5606       include 'COMMON.SBRIDGE'
5607       include 'COMMON.CHAIN'
5608       include 'COMMON.DERIV'
5609       include 'COMMON.VAR'
5610       include 'COMMON.INTERACT'
5611       include 'COMMON.IOUNITS'
5612       include 'COMMON.CONTROL'
5613       dimension ggg(3)
5614       ehpb=0.0D0
5615       do i=1,3
5616        ggg(i)=0.0d0
5617       enddo
5618 C      write (iout,*) ,"link_end",link_end,constr_dist
5619 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5620 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5621       if (link_end.eq.0) return
5622       do i=link_start,link_end
5623 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5624 C CA-CA distance used in regularization of structure.
5625         ii=ihpb(i)
5626         jj=jhpb(i)
5627 C iii and jjj point to the residues for which the distance is assigned.
5628         if (ii.gt.nres) then
5629           iii=ii-nres
5630           jjj=jj-nres
5631         else
5632           iii=ii
5633           jjj=jj
5634         endif
5635 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5636 c     &    dhpb(i),dhpb1(i),forcon(i)
5637 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5638 C    distance and angle dependent SS bond potential.
5639 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5640 C     & iabs(itype(jjj)).eq.1) then
5641 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5642 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5643         if (.not.dyn_ss .and. i.le.nss) then
5644 C 15/02/13 CC dynamic SSbond - additional check
5645          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5646      & iabs(itype(jjj)).eq.1) then
5647           call ssbond_ene(iii,jjj,eij)
5648           ehpb=ehpb+2*eij
5649          endif
5650 cd          write (iout,*) "eij",eij
5651 cd   &   ' waga=',waga,' fac=',fac
5652         else if (ii.gt.nres .and. jj.gt.nres) then
5653 c Restraints from contact prediction
5654           dd=dist(ii,jj)
5655           if (constr_dist.eq.11) then
5656             ehpb=ehpb+fordepth(i)**4.0d0
5657      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5658             fac=fordepth(i)**4.0d0
5659      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5660           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5661      &    ehpb,fordepth(i),dd
5662            else
5663           if (dhpb1(i).gt.0.0d0) then
5664             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5665             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5666 c            write (iout,*) "beta nmr",
5667 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5668           else
5669             dd=dist(ii,jj)
5670             rdis=dd-dhpb(i)
5671 C Get the force constant corresponding to this distance.
5672             waga=forcon(i)
5673 C Calculate the contribution to energy.
5674             ehpb=ehpb+waga*rdis*rdis
5675 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5676 C
5677 C Evaluate gradient.
5678 C
5679             fac=waga*rdis/dd
5680           endif
5681           endif
5682           do j=1,3
5683             ggg(j)=fac*(c(j,jj)-c(j,ii))
5684           enddo
5685           do j=1,3
5686             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5687             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5688           enddo
5689           do k=1,3
5690             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5691             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5692           enddo
5693         else
5694 C Calculate the distance between the two points and its difference from the
5695 C target distance.
5696           dd=dist(ii,jj)
5697           if (constr_dist.eq.11) then
5698             ehpb=ehpb+fordepth(i)**4.0d0
5699      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5700             fac=fordepth(i)**4.0d0
5701      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5702           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5703      &    ehpb,fordepth(i),dd
5704            else
5705           if (dhpb1(i).gt.0.0d0) then
5706             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5707             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5708 c            write (iout,*) "alph nmr",
5709 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5710           else
5711             rdis=dd-dhpb(i)
5712 C Get the force constant corresponding to this distance.
5713             waga=forcon(i)
5714 C Calculate the contribution to energy.
5715             ehpb=ehpb+waga*rdis*rdis
5716 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5717 C
5718 C Evaluate gradient.
5719 C
5720             fac=waga*rdis/dd
5721           endif
5722           endif
5723             do j=1,3
5724               ggg(j)=fac*(c(j,jj)-c(j,ii))
5725             enddo
5726 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5727 C If this is a SC-SC distance, we need to calculate the contributions to the
5728 C Cartesian gradient in the SC vectors (ghpbx).
5729           if (iii.lt.ii) then
5730           do j=1,3
5731             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5732             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5733           enddo
5734           endif
5735 cgrad        do j=iii,jjj-1
5736 cgrad          do k=1,3
5737 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5738 cgrad          enddo
5739 cgrad        enddo
5740           do k=1,3
5741             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5742             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5743           enddo
5744         endif
5745       enddo
5746       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5747       return
5748       end
5749 C--------------------------------------------------------------------------
5750       subroutine ssbond_ene(i,j,eij)
5751 C
5752 C Calculate the distance and angle dependent SS-bond potential energy
5753 C using a free-energy function derived based on RHF/6-31G** ab initio
5754 C calculations of diethyl disulfide.
5755 C
5756 C A. Liwo and U. Kozlowska, 11/24/03
5757 C
5758       implicit real*8 (a-h,o-z)
5759       include 'DIMENSIONS'
5760       include 'COMMON.SBRIDGE'
5761       include 'COMMON.CHAIN'
5762       include 'COMMON.DERIV'
5763       include 'COMMON.LOCAL'
5764       include 'COMMON.INTERACT'
5765       include 'COMMON.VAR'
5766       include 'COMMON.IOUNITS'
5767       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5768       itypi=iabs(itype(i))
5769       xi=c(1,nres+i)
5770       yi=c(2,nres+i)
5771       zi=c(3,nres+i)
5772       dxi=dc_norm(1,nres+i)
5773       dyi=dc_norm(2,nres+i)
5774       dzi=dc_norm(3,nres+i)
5775 c      dsci_inv=dsc_inv(itypi)
5776       dsci_inv=vbld_inv(nres+i)
5777       itypj=iabs(itype(j))
5778 c      dscj_inv=dsc_inv(itypj)
5779       dscj_inv=vbld_inv(nres+j)
5780       xj=c(1,nres+j)-xi
5781       yj=c(2,nres+j)-yi
5782       zj=c(3,nres+j)-zi
5783       dxj=dc_norm(1,nres+j)
5784       dyj=dc_norm(2,nres+j)
5785       dzj=dc_norm(3,nres+j)
5786       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5787       rij=dsqrt(rrij)
5788       erij(1)=xj*rij
5789       erij(2)=yj*rij
5790       erij(3)=zj*rij
5791       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5792       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5793       om12=dxi*dxj+dyi*dyj+dzi*dzj
5794       do k=1,3
5795         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5796         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5797       enddo
5798       rij=1.0d0/rij
5799       deltad=rij-d0cm
5800       deltat1=1.0d0-om1
5801       deltat2=1.0d0+om2
5802       deltat12=om2-om1+2.0d0
5803       cosphi=om12-om1*om2
5804       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5805      &  +akct*deltad*deltat12
5806      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5807 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5808 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5809 c     &  " deltat12",deltat12," eij",eij
5810       ed=2*akcm*deltad+akct*deltat12
5811       pom1=akct*deltad
5812       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5813       eom1=-2*akth*deltat1-pom1-om2*pom2
5814       eom2= 2*akth*deltat2+pom1-om1*pom2
5815       eom12=pom2
5816       do k=1,3
5817         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5818         ghpbx(k,i)=ghpbx(k,i)-ggk
5819      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5820      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5821         ghpbx(k,j)=ghpbx(k,j)+ggk
5822      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5823      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5824         ghpbc(k,i)=ghpbc(k,i)-ggk
5825         ghpbc(k,j)=ghpbc(k,j)+ggk
5826       enddo
5827 C
5828 C Calculate the components of the gradient in DC and X
5829 C
5830 cgrad      do k=i,j-1
5831 cgrad        do l=1,3
5832 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5833 cgrad        enddo
5834 cgrad      enddo
5835       return
5836       end
5837 C--------------------------------------------------------------------------
5838       subroutine ebond(estr)
5839 c
5840 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5841 c
5842       implicit real*8 (a-h,o-z)
5843       include 'DIMENSIONS'
5844       include 'COMMON.LOCAL'
5845       include 'COMMON.GEO'
5846       include 'COMMON.INTERACT'
5847       include 'COMMON.DERIV'
5848       include 'COMMON.VAR'
5849       include 'COMMON.CHAIN'
5850       include 'COMMON.IOUNITS'
5851       include 'COMMON.NAMES'
5852       include 'COMMON.FFIELD'
5853       include 'COMMON.CONTROL'
5854       include 'COMMON.SETUP'
5855       double precision u(3),ud(3)
5856       estr=0.0d0
5857       estr1=0.0d0
5858       do i=ibondp_start,ibondp_end
5859         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5860 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5861 c          do j=1,3
5862 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5863 c     &      *dc(j,i-1)/vbld(i)
5864 c          enddo
5865 c          if (energy_dec) write(iout,*)
5866 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5867 c        else
5868 C       Checking if it involves dummy (NH3+ or COO-) group
5869          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5870 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5871         diff = vbld(i)-vbldpDUM
5872         if (energy_dec) write(iout,*) "dum_bond",i,diff
5873          else
5874 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5875         diff = vbld(i)-vbldp0
5876          endif
5877         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5878      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5879         estr=estr+diff*diff
5880         do j=1,3
5881           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5882         enddo
5883 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5884 c        endif
5885       enddo
5886
5887       estr=0.5d0*AKP*estr+estr1
5888 c
5889 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5890 c
5891       do i=ibond_start,ibond_end
5892         iti=iabs(itype(i))
5893         if (iti.ne.10 .and. iti.ne.ntyp1) then
5894           nbi=nbondterm(iti)
5895           if (nbi.eq.1) then
5896             diff=vbld(i+nres)-vbldsc0(1,iti)
5897             if (energy_dec)  write (iout,*)
5898      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5899      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5900             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5901             do j=1,3
5902               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5903             enddo
5904           else
5905             do j=1,nbi
5906               diff=vbld(i+nres)-vbldsc0(j,iti)
5907               ud(j)=aksc(j,iti)*diff
5908               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5909             enddo
5910             uprod=u(1)
5911             do j=2,nbi
5912               uprod=uprod*u(j)
5913             enddo
5914             usum=0.0d0
5915             usumsqder=0.0d0
5916             do j=1,nbi
5917               uprod1=1.0d0
5918               uprod2=1.0d0
5919               do k=1,nbi
5920                 if (k.ne.j) then
5921                   uprod1=uprod1*u(k)
5922                   uprod2=uprod2*u(k)*u(k)
5923                 endif
5924               enddo
5925               usum=usum+uprod1
5926               usumsqder=usumsqder+ud(j)*uprod2
5927             enddo
5928             estr=estr+uprod/usum
5929             do j=1,3
5930              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5931             enddo
5932           endif
5933         endif
5934       enddo
5935       return
5936       end
5937 #ifdef CRYST_THETA
5938 C--------------------------------------------------------------------------
5939       subroutine ebend(etheta,ethetacnstr)
5940 C
5941 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5942 C angles gamma and its derivatives in consecutive thetas and gammas.
5943 C
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'COMMON.LOCAL'
5947       include 'COMMON.GEO'
5948       include 'COMMON.INTERACT'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.VAR'
5951       include 'COMMON.CHAIN'
5952       include 'COMMON.IOUNITS'
5953       include 'COMMON.NAMES'
5954       include 'COMMON.FFIELD'
5955       include 'COMMON.CONTROL'
5956       include 'COMMON.TORCNSTR'
5957       common /calcthet/ term1,term2,termm,diffak,ratak,
5958      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5959      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5960       double precision y(2),z(2)
5961       delta=0.02d0*pi
5962 c      time11=dexp(-2*time)
5963 c      time12=1.0d0
5964       etheta=0.0D0
5965 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5966       do i=ithet_start,ithet_end
5967         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5968      &  .or.itype(i).eq.ntyp1) cycle
5969 C Zero the energy function and its derivative at 0 or pi.
5970         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5971         it=itype(i-1)
5972         ichir1=isign(1,itype(i-2))
5973         ichir2=isign(1,itype(i))
5974          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5975          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5976          if (itype(i-1).eq.10) then
5977           itype1=isign(10,itype(i-2))
5978           ichir11=isign(1,itype(i-2))
5979           ichir12=isign(1,itype(i-2))
5980           itype2=isign(10,itype(i))
5981           ichir21=isign(1,itype(i))
5982           ichir22=isign(1,itype(i))
5983          endif
5984
5985         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5986 #ifdef OSF
5987           phii=phi(i)
5988           if (phii.ne.phii) phii=150.0
5989 #else
5990           phii=phi(i)
5991 #endif
5992           y(1)=dcos(phii)
5993           y(2)=dsin(phii)
5994         else
5995           y(1)=0.0D0
5996           y(2)=0.0D0
5997         endif
5998         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5999 #ifdef OSF
6000           phii1=phi(i+1)
6001           if (phii1.ne.phii1) phii1=150.0
6002           phii1=pinorm(phii1)
6003           z(1)=cos(phii1)
6004 #else
6005           phii1=phi(i+1)
6006 #endif
6007           z(1)=dcos(phii1)
6008           z(2)=dsin(phii1)
6009         else
6010           z(1)=0.0D0
6011           z(2)=0.0D0
6012         endif
6013 C Calculate the "mean" value of theta from the part of the distribution
6014 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6015 C In following comments this theta will be referred to as t_c.
6016         thet_pred_mean=0.0d0
6017         do k=1,2
6018             athetk=athet(k,it,ichir1,ichir2)
6019             bthetk=bthet(k,it,ichir1,ichir2)
6020           if (it.eq.10) then
6021              athetk=athet(k,itype1,ichir11,ichir12)
6022              bthetk=bthet(k,itype2,ichir21,ichir22)
6023           endif
6024          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6025 c         write(iout,*) 'chuj tu', y(k),z(k)
6026         enddo
6027         dthett=thet_pred_mean*ssd
6028         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6029 C Derivatives of the "mean" values in gamma1 and gamma2.
6030         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6031      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6032          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6033      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6034          if (it.eq.10) then
6035       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6036      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6037         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6038      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6039          endif
6040         if (theta(i).gt.pi-delta) then
6041           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6042      &         E_tc0)
6043           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6044           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6045           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6046      &        E_theta)
6047           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6048      &        E_tc)
6049         else if (theta(i).lt.delta) then
6050           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6051           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6052           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6053      &        E_theta)
6054           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6055           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6056      &        E_tc)
6057         else
6058           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6059      &        E_theta,E_tc)
6060         endif
6061         etheta=etheta+ethetai
6062         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6063      &      'ebend',i,ethetai,theta(i),itype(i)
6064         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6065         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6066         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6067       enddo
6068       ethetacnstr=0.0d0
6069 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6070       do i=ithetaconstr_start,ithetaconstr_end
6071         itheta=itheta_constr(i)
6072         thetiii=theta(itheta)
6073         difi=pinorm(thetiii-theta_constr0(i))
6074         if (difi.gt.theta_drange(i)) then
6075           difi=difi-theta_drange(i)
6076           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6077           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6078      &    +for_thet_constr(i)*difi**3
6079         else if (difi.lt.-drange(i)) then
6080           difi=difi+drange(i)
6081           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6082           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6083      &    +for_thet_constr(i)*difi**3
6084         else
6085           difi=0.0
6086         endif
6087        if (energy_dec) then
6088         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6089      &    i,itheta,rad2deg*thetiii,
6090      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6091      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6092      &    gloc(itheta+nphi-2,icg)
6093         endif
6094       enddo
6095
6096 C Ufff.... We've done all this!!!
6097       return
6098       end
6099 C---------------------------------------------------------------------------
6100       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6101      &     E_tc)
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.LOCAL'
6105       include 'COMMON.IOUNITS'
6106       common /calcthet/ term1,term2,termm,diffak,ratak,
6107      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6108      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6109 C Calculate the contributions to both Gaussian lobes.
6110 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6111 C The "polynomial part" of the "standard deviation" of this part of
6112 C the distributioni.
6113 ccc        write (iout,*) thetai,thet_pred_mean
6114         sig=polthet(3,it)
6115         do j=2,0,-1
6116           sig=sig*thet_pred_mean+polthet(j,it)
6117         enddo
6118 C Derivative of the "interior part" of the "standard deviation of the"
6119 C gamma-dependent Gaussian lobe in t_c.
6120         sigtc=3*polthet(3,it)
6121         do j=2,1,-1
6122           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6123         enddo
6124         sigtc=sig*sigtc
6125 C Set the parameters of both Gaussian lobes of the distribution.
6126 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6127         fac=sig*sig+sigc0(it)
6128         sigcsq=fac+fac
6129         sigc=1.0D0/sigcsq
6130 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6131         sigsqtc=-4.0D0*sigcsq*sigtc
6132 c       print *,i,sig,sigtc,sigsqtc
6133 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6134         sigtc=-sigtc/(fac*fac)
6135 C Following variable is sigma(t_c)**(-2)
6136         sigcsq=sigcsq*sigcsq
6137         sig0i=sig0(it)
6138         sig0inv=1.0D0/sig0i**2
6139         delthec=thetai-thet_pred_mean
6140         delthe0=thetai-theta0i
6141         term1=-0.5D0*sigcsq*delthec*delthec
6142         term2=-0.5D0*sig0inv*delthe0*delthe0
6143 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6144 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6145 C NaNs in taking the logarithm. We extract the largest exponent which is added
6146 C to the energy (this being the log of the distribution) at the end of energy
6147 C term evaluation for this virtual-bond angle.
6148         if (term1.gt.term2) then
6149           termm=term1
6150           term2=dexp(term2-termm)
6151           term1=1.0d0
6152         else
6153           termm=term2
6154           term1=dexp(term1-termm)
6155           term2=1.0d0
6156         endif
6157 C The ratio between the gamma-independent and gamma-dependent lobes of
6158 C the distribution is a Gaussian function of thet_pred_mean too.
6159         diffak=gthet(2,it)-thet_pred_mean
6160         ratak=diffak/gthet(3,it)**2
6161         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6162 C Let's differentiate it in thet_pred_mean NOW.
6163         aktc=ak*ratak
6164 C Now put together the distribution terms to make complete distribution.
6165         termexp=term1+ak*term2
6166         termpre=sigc+ak*sig0i
6167 C Contribution of the bending energy from this theta is just the -log of
6168 C the sum of the contributions from the two lobes and the pre-exponential
6169 C factor. Simple enough, isn't it?
6170         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6171 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6172 C NOW the derivatives!!!
6173 C 6/6/97 Take into account the deformation.
6174         E_theta=(delthec*sigcsq*term1
6175      &       +ak*delthe0*sig0inv*term2)/termexp
6176         E_tc=((sigtc+aktc*sig0i)/termpre
6177      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6178      &       aktc*term2)/termexp)
6179       return
6180       end
6181 c-----------------------------------------------------------------------------
6182       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6183       implicit real*8 (a-h,o-z)
6184       include 'DIMENSIONS'
6185       include 'COMMON.LOCAL'
6186       include 'COMMON.IOUNITS'
6187       common /calcthet/ term1,term2,termm,diffak,ratak,
6188      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6189      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6190       delthec=thetai-thet_pred_mean
6191       delthe0=thetai-theta0i
6192 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6193       t3 = thetai-thet_pred_mean
6194       t6 = t3**2
6195       t9 = term1
6196       t12 = t3*sigcsq
6197       t14 = t12+t6*sigsqtc
6198       t16 = 1.0d0
6199       t21 = thetai-theta0i
6200       t23 = t21**2
6201       t26 = term2
6202       t27 = t21*t26
6203       t32 = termexp
6204       t40 = t32**2
6205       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6206      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6207      & *(-t12*t9-ak*sig0inv*t27)
6208       return
6209       end
6210 #else
6211 C--------------------------------------------------------------------------
6212       subroutine ebend(etheta,ethetacnstr)
6213 C
6214 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6215 C angles gamma and its derivatives in consecutive thetas and gammas.
6216 C ab initio-derived potentials from
6217 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6218 C
6219       implicit real*8 (a-h,o-z)
6220       include 'DIMENSIONS'
6221       include 'COMMON.LOCAL'
6222       include 'COMMON.GEO'
6223       include 'COMMON.INTERACT'
6224       include 'COMMON.DERIV'
6225       include 'COMMON.VAR'
6226       include 'COMMON.CHAIN'
6227       include 'COMMON.IOUNITS'
6228       include 'COMMON.NAMES'
6229       include 'COMMON.FFIELD'
6230       include 'COMMON.CONTROL'
6231       include 'COMMON.TORCNSTR'
6232       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6233      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6234      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6235      & sinph1ph2(maxdouble,maxdouble)
6236       logical lprn /.false./, lprn1 /.false./
6237       etheta=0.0D0
6238       do i=ithet_start,ithet_end
6239 c        print *,i,itype(i-1),itype(i),itype(i-2)
6240         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6241      &  .or.itype(i).eq.ntyp1) cycle
6242 C        print *,i,theta(i)
6243         if (iabs(itype(i+1)).eq.20) iblock=2
6244         if (iabs(itype(i+1)).ne.20) iblock=1
6245         dethetai=0.0d0
6246         dephii=0.0d0
6247         dephii1=0.0d0
6248         theti2=0.5d0*theta(i)
6249         ityp2=ithetyp((itype(i-1)))
6250         do k=1,nntheterm
6251           coskt(k)=dcos(k*theti2)
6252           sinkt(k)=dsin(k*theti2)
6253         enddo
6254 C        print *,ethetai
6255         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6256 #ifdef OSF
6257           phii=phi(i)
6258           if (phii.ne.phii) phii=150.0
6259 #else
6260           phii=phi(i)
6261 #endif
6262           ityp1=ithetyp((itype(i-2)))
6263 C propagation of chirality for glycine type
6264           do k=1,nsingle
6265             cosph1(k)=dcos(k*phii)
6266             sinph1(k)=dsin(k*phii)
6267           enddo
6268         else
6269           phii=0.0d0
6270           do k=1,nsingle
6271           ityp1=ithetyp((itype(i-2)))
6272             cosph1(k)=0.0d0
6273             sinph1(k)=0.0d0
6274           enddo
6275         endif
6276         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6277 #ifdef OSF
6278           phii1=phi(i+1)
6279           if (phii1.ne.phii1) phii1=150.0
6280           phii1=pinorm(phii1)
6281 #else
6282           phii1=phi(i+1)
6283 #endif
6284           ityp3=ithetyp((itype(i)))
6285           do k=1,nsingle
6286             cosph2(k)=dcos(k*phii1)
6287             sinph2(k)=dsin(k*phii1)
6288           enddo
6289         else
6290           phii1=0.0d0
6291           ityp3=ithetyp((itype(i)))
6292           do k=1,nsingle
6293             cosph2(k)=0.0d0
6294             sinph2(k)=0.0d0
6295           enddo
6296         endif
6297         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6298         do k=1,ndouble
6299           do l=1,k-1
6300             ccl=cosph1(l)*cosph2(k-l)
6301             ssl=sinph1(l)*sinph2(k-l)
6302             scl=sinph1(l)*cosph2(k-l)
6303             csl=cosph1(l)*sinph2(k-l)
6304             cosph1ph2(l,k)=ccl-ssl
6305             cosph1ph2(k,l)=ccl+ssl
6306             sinph1ph2(l,k)=scl+csl
6307             sinph1ph2(k,l)=scl-csl
6308           enddo
6309         enddo
6310         if (lprn) then
6311         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6312      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6313         write (iout,*) "coskt and sinkt"
6314         do k=1,nntheterm
6315           write (iout,*) k,coskt(k),sinkt(k)
6316         enddo
6317         endif
6318         do k=1,ntheterm
6319           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6320           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6321      &      *coskt(k)
6322           if (lprn)
6323      &    write (iout,*) "k",k,"
6324      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6325      &     " ethetai",ethetai
6326         enddo
6327         if (lprn) then
6328         write (iout,*) "cosph and sinph"
6329         do k=1,nsingle
6330           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6331         enddo
6332         write (iout,*) "cosph1ph2 and sinph2ph2"
6333         do k=2,ndouble
6334           do l=1,k-1
6335             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6336      &         sinph1ph2(l,k),sinph1ph2(k,l)
6337           enddo
6338         enddo
6339         write(iout,*) "ethetai",ethetai
6340         endif
6341 C       print *,ethetai
6342         do m=1,ntheterm2
6343           do k=1,nsingle
6344             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6345      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6346      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6347      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6348             ethetai=ethetai+sinkt(m)*aux
6349             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6350             dephii=dephii+k*sinkt(m)*(
6351      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6352      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6353             dephii1=dephii1+k*sinkt(m)*(
6354      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6355      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6356             if (lprn)
6357      &      write (iout,*) "m",m," k",k," bbthet",
6358      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6359      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6360      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6361      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6362 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6363           enddo
6364         enddo
6365 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6366 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6367 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6368 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6369         if (lprn)
6370      &  write(iout,*) "ethetai",ethetai
6371 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6372         do m=1,ntheterm3
6373           do k=2,ndouble
6374             do l=1,k-1
6375               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6376      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6377      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6378      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6379               ethetai=ethetai+sinkt(m)*aux
6380               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6381               dephii=dephii+l*sinkt(m)*(
6382      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6383      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6384      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6385      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6386               dephii1=dephii1+(k-l)*sinkt(m)*(
6387      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6388      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6389      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6390      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6391               if (lprn) then
6392               write (iout,*) "m",m," k",k," l",l," ffthet",
6393      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6394      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6395      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6396      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6397      &            " ethetai",ethetai
6398               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6399      &            cosph1ph2(k,l)*sinkt(m),
6400      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6401               endif
6402             enddo
6403           enddo
6404         enddo
6405 10      continue
6406 c        lprn1=.true.
6407 C        print *,ethetai
6408         if (lprn1)
6409      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6410      &   i,theta(i)*rad2deg,phii*rad2deg,
6411      &   phii1*rad2deg,ethetai
6412 c        lprn1=.false.
6413         etheta=etheta+ethetai
6414         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6415         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6416         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6417       enddo
6418 C now constrains
6419       ethetacnstr=0.0d0
6420 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6421       do i=ithetaconstr_start,ithetaconstr_end
6422         itheta=itheta_constr(i)
6423         thetiii=theta(itheta)
6424         difi=pinorm(thetiii-theta_constr0(i))
6425         if (difi.gt.theta_drange(i)) then
6426           difi=difi-theta_drange(i)
6427           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6428           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6429      &    +for_thet_constr(i)*difi**3
6430         else if (difi.lt.-drange(i)) then
6431           difi=difi+drange(i)
6432           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6433           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6434      &    +for_thet_constr(i)*difi**3
6435         else
6436           difi=0.0
6437         endif
6438        if (energy_dec) then
6439         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6440      &    i,itheta,rad2deg*thetiii,
6441      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6442      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6443      &    gloc(itheta+nphi-2,icg)
6444         endif
6445       enddo
6446
6447       return
6448       end
6449 #endif
6450 #ifdef CRYST_SC
6451 c-----------------------------------------------------------------------------
6452       subroutine esc(escloc)
6453 C Calculate the local energy of a side chain and its derivatives in the
6454 C corresponding virtual-bond valence angles THETA and the spherical angles
6455 C ALPHA and OMEGA.
6456       implicit real*8 (a-h,o-z)
6457       include 'DIMENSIONS'
6458       include 'COMMON.GEO'
6459       include 'COMMON.LOCAL'
6460       include 'COMMON.VAR'
6461       include 'COMMON.INTERACT'
6462       include 'COMMON.DERIV'
6463       include 'COMMON.CHAIN'
6464       include 'COMMON.IOUNITS'
6465       include 'COMMON.NAMES'
6466       include 'COMMON.FFIELD'
6467       include 'COMMON.CONTROL'
6468       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6469      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6470       common /sccalc/ time11,time12,time112,theti,it,nlobit
6471       delta=0.02d0*pi
6472       escloc=0.0D0
6473 c     write (iout,'(a)') 'ESC'
6474       do i=loc_start,loc_end
6475         it=itype(i)
6476         if (it.eq.ntyp1) cycle
6477         if (it.eq.10) goto 1
6478         nlobit=nlob(iabs(it))
6479 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6480 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6481         theti=theta(i+1)-pipol
6482         x(1)=dtan(theti)
6483         x(2)=alph(i)
6484         x(3)=omeg(i)
6485
6486         if (x(2).gt.pi-delta) then
6487           xtemp(1)=x(1)
6488           xtemp(2)=pi-delta
6489           xtemp(3)=x(3)
6490           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6491           xtemp(2)=pi
6492           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6493           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6494      &        escloci,dersc(2))
6495           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6496      &        ddersc0(1),dersc(1))
6497           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6498      &        ddersc0(3),dersc(3))
6499           xtemp(2)=pi-delta
6500           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6501           xtemp(2)=pi
6502           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6503           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6504      &            dersc0(2),esclocbi,dersc02)
6505           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6506      &            dersc12,dersc01)
6507           call splinthet(x(2),0.5d0*delta,ss,ssd)
6508           dersc0(1)=dersc01
6509           dersc0(2)=dersc02
6510           dersc0(3)=0.0d0
6511           do k=1,3
6512             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6513           enddo
6514           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6515 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6516 c    &             esclocbi,ss,ssd
6517           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6518 c         escloci=esclocbi
6519 c         write (iout,*) escloci
6520         else if (x(2).lt.delta) then
6521           xtemp(1)=x(1)
6522           xtemp(2)=delta
6523           xtemp(3)=x(3)
6524           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6525           xtemp(2)=0.0d0
6526           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6527           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6528      &        escloci,dersc(2))
6529           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6530      &        ddersc0(1),dersc(1))
6531           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6532      &        ddersc0(3),dersc(3))
6533           xtemp(2)=delta
6534           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6535           xtemp(2)=0.0d0
6536           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6537           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6538      &            dersc0(2),esclocbi,dersc02)
6539           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6540      &            dersc12,dersc01)
6541           dersc0(1)=dersc01
6542           dersc0(2)=dersc02
6543           dersc0(3)=0.0d0
6544           call splinthet(x(2),0.5d0*delta,ss,ssd)
6545           do k=1,3
6546             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6547           enddo
6548           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6549 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6550 c    &             esclocbi,ss,ssd
6551           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6552 c         write (iout,*) escloci
6553         else
6554           call enesc(x,escloci,dersc,ddummy,.false.)
6555         endif
6556
6557         escloc=escloc+escloci
6558         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6559      &     'escloc',i,escloci
6560 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6561
6562         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6563      &   wscloc*dersc(1)
6564         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6565         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6566     1   continue
6567       enddo
6568       return
6569       end
6570 C---------------------------------------------------------------------------
6571       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6572       implicit real*8 (a-h,o-z)
6573       include 'DIMENSIONS'
6574       include 'COMMON.GEO'
6575       include 'COMMON.LOCAL'
6576       include 'COMMON.IOUNITS'
6577       common /sccalc/ time11,time12,time112,theti,it,nlobit
6578       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6579       double precision contr(maxlob,-1:1)
6580       logical mixed
6581 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6582         escloc_i=0.0D0
6583         do j=1,3
6584           dersc(j)=0.0D0
6585           if (mixed) ddersc(j)=0.0d0
6586         enddo
6587         x3=x(3)
6588
6589 C Because of periodicity of the dependence of the SC energy in omega we have
6590 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6591 C To avoid underflows, first compute & store the exponents.
6592
6593         do iii=-1,1
6594
6595           x(3)=x3+iii*dwapi
6596
6597           do j=1,nlobit
6598             do k=1,3
6599               z(k)=x(k)-censc(k,j,it)
6600             enddo
6601             do k=1,3
6602               Axk=0.0D0
6603               do l=1,3
6604                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6605               enddo
6606               Ax(k,j,iii)=Axk
6607             enddo
6608             expfac=0.0D0
6609             do k=1,3
6610               expfac=expfac+Ax(k,j,iii)*z(k)
6611             enddo
6612             contr(j,iii)=expfac
6613           enddo ! j
6614
6615         enddo ! iii
6616
6617         x(3)=x3
6618 C As in the case of ebend, we want to avoid underflows in exponentiation and
6619 C subsequent NaNs and INFs in energy calculation.
6620 C Find the largest exponent
6621         emin=contr(1,-1)
6622         do iii=-1,1
6623           do j=1,nlobit
6624             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6625           enddo
6626         enddo
6627         emin=0.5D0*emin
6628 cd      print *,'it=',it,' emin=',emin
6629
6630 C Compute the contribution to SC energy and derivatives
6631         do iii=-1,1
6632
6633           do j=1,nlobit
6634 #ifdef OSF
6635             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6636             if(adexp.ne.adexp) adexp=1.0
6637             expfac=dexp(adexp)
6638 #else
6639             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6640 #endif
6641 cd          print *,'j=',j,' expfac=',expfac
6642             escloc_i=escloc_i+expfac
6643             do k=1,3
6644               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6645             enddo
6646             if (mixed) then
6647               do k=1,3,2
6648                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6649      &            +gaussc(k,2,j,it))*expfac
6650               enddo
6651             endif
6652           enddo
6653
6654         enddo ! iii
6655
6656         dersc(1)=dersc(1)/cos(theti)**2
6657         ddersc(1)=ddersc(1)/cos(theti)**2
6658         ddersc(3)=ddersc(3)
6659
6660         escloci=-(dlog(escloc_i)-emin)
6661         do j=1,3
6662           dersc(j)=dersc(j)/escloc_i
6663         enddo
6664         if (mixed) then
6665           do j=1,3,2
6666             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6667           enddo
6668         endif
6669       return
6670       end
6671 C------------------------------------------------------------------------------
6672       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6673       implicit real*8 (a-h,o-z)
6674       include 'DIMENSIONS'
6675       include 'COMMON.GEO'
6676       include 'COMMON.LOCAL'
6677       include 'COMMON.IOUNITS'
6678       common /sccalc/ time11,time12,time112,theti,it,nlobit
6679       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6680       double precision contr(maxlob)
6681       logical mixed
6682
6683       escloc_i=0.0D0
6684
6685       do j=1,3
6686         dersc(j)=0.0D0
6687       enddo
6688
6689       do j=1,nlobit
6690         do k=1,2
6691           z(k)=x(k)-censc(k,j,it)
6692         enddo
6693         z(3)=dwapi
6694         do k=1,3
6695           Axk=0.0D0
6696           do l=1,3
6697             Axk=Axk+gaussc(l,k,j,it)*z(l)
6698           enddo
6699           Ax(k,j)=Axk
6700         enddo
6701         expfac=0.0D0
6702         do k=1,3
6703           expfac=expfac+Ax(k,j)*z(k)
6704         enddo
6705         contr(j)=expfac
6706       enddo ! j
6707
6708 C As in the case of ebend, we want to avoid underflows in exponentiation and
6709 C subsequent NaNs and INFs in energy calculation.
6710 C Find the largest exponent
6711       emin=contr(1)
6712       do j=1,nlobit
6713         if (emin.gt.contr(j)) emin=contr(j)
6714       enddo
6715       emin=0.5D0*emin
6716
6717 C Compute the contribution to SC energy and derivatives
6718
6719       dersc12=0.0d0
6720       do j=1,nlobit
6721         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6722         escloc_i=escloc_i+expfac
6723         do k=1,2
6724           dersc(k)=dersc(k)+Ax(k,j)*expfac
6725         enddo
6726         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6727      &            +gaussc(1,2,j,it))*expfac
6728         dersc(3)=0.0d0
6729       enddo
6730
6731       dersc(1)=dersc(1)/cos(theti)**2
6732       dersc12=dersc12/cos(theti)**2
6733       escloci=-(dlog(escloc_i)-emin)
6734       do j=1,2
6735         dersc(j)=dersc(j)/escloc_i
6736       enddo
6737       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6738       return
6739       end
6740 #else
6741 c----------------------------------------------------------------------------------
6742       subroutine esc(escloc)
6743 C Calculate the local energy of a side chain and its derivatives in the
6744 C corresponding virtual-bond valence angles THETA and the spherical angles
6745 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6746 C added by Urszula Kozlowska. 07/11/2007
6747 C
6748       implicit real*8 (a-h,o-z)
6749       include 'DIMENSIONS'
6750       include 'COMMON.GEO'
6751       include 'COMMON.LOCAL'
6752       include 'COMMON.VAR'
6753       include 'COMMON.SCROT'
6754       include 'COMMON.INTERACT'
6755       include 'COMMON.DERIV'
6756       include 'COMMON.CHAIN'
6757       include 'COMMON.IOUNITS'
6758       include 'COMMON.NAMES'
6759       include 'COMMON.FFIELD'
6760       include 'COMMON.CONTROL'
6761       include 'COMMON.VECTORS'
6762       double precision x_prime(3),y_prime(3),z_prime(3)
6763      &    , sumene,dsc_i,dp2_i,x(65),
6764      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6765      &    de_dxx,de_dyy,de_dzz,de_dt
6766       double precision s1_t,s1_6_t,s2_t,s2_6_t
6767       double precision
6768      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6769      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6770      & dt_dCi(3),dt_dCi1(3)
6771       common /sccalc/ time11,time12,time112,theti,it,nlobit
6772       delta=0.02d0*pi
6773       escloc=0.0D0
6774       do i=loc_start,loc_end
6775         if (itype(i).eq.ntyp1) cycle
6776         costtab(i+1) =dcos(theta(i+1))
6777         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6778         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6779         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6780         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6781         cosfac=dsqrt(cosfac2)
6782         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6783         sinfac=dsqrt(sinfac2)
6784         it=iabs(itype(i))
6785         if (it.eq.10) goto 1
6786 c
6787 C  Compute the axes of tghe local cartesian coordinates system; store in
6788 c   x_prime, y_prime and z_prime
6789 c
6790         do j=1,3
6791           x_prime(j) = 0.00
6792           y_prime(j) = 0.00
6793           z_prime(j) = 0.00
6794         enddo
6795 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6796 C     &   dc_norm(3,i+nres)
6797         do j = 1,3
6798           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6799           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6800         enddo
6801         do j = 1,3
6802           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6803         enddo
6804 c       write (2,*) "i",i
6805 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6806 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6807 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6808 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6809 c      & " xy",scalar(x_prime(1),y_prime(1)),
6810 c      & " xz",scalar(x_prime(1),z_prime(1)),
6811 c      & " yy",scalar(y_prime(1),y_prime(1)),
6812 c      & " yz",scalar(y_prime(1),z_prime(1)),
6813 c      & " zz",scalar(z_prime(1),z_prime(1))
6814 c
6815 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6816 C to local coordinate system. Store in xx, yy, zz.
6817 c
6818         xx=0.0d0
6819         yy=0.0d0
6820         zz=0.0d0
6821         do j = 1,3
6822           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6823           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6824           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6825         enddo
6826
6827         xxtab(i)=xx
6828         yytab(i)=yy
6829         zztab(i)=zz
6830 C
6831 C Compute the energy of the ith side cbain
6832 C
6833 c        write (2,*) "xx",xx," yy",yy," zz",zz
6834         it=iabs(itype(i))
6835         do j = 1,65
6836           x(j) = sc_parmin(j,it)
6837         enddo
6838 #ifdef CHECK_COORD
6839 Cc diagnostics - remove later
6840         xx1 = dcos(alph(2))
6841         yy1 = dsin(alph(2))*dcos(omeg(2))
6842         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6843         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6844      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6845      &    xx1,yy1,zz1
6846 C,"  --- ", xx_w,yy_w,zz_w
6847 c end diagnostics
6848 #endif
6849         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6850      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6851      &   + x(10)*yy*zz
6852         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6853      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6854      & + x(20)*yy*zz
6855         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6856      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6857      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6858      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6859      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6860      &  +x(40)*xx*yy*zz
6861         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6862      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6863      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6864      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6865      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6866      &  +x(60)*xx*yy*zz
6867         dsc_i   = 0.743d0+x(61)
6868         dp2_i   = 1.9d0+x(62)
6869         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6870      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6871         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6872      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6873         s1=(1+x(63))/(0.1d0 + dscp1)
6874         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6875         s2=(1+x(65))/(0.1d0 + dscp2)
6876         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6877         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6878      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6879 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6880 c     &   sumene4,
6881 c     &   dscp1,dscp2,sumene
6882 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6883         escloc = escloc + sumene
6884 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6885 c     & ,zz,xx,yy
6886 c#define DEBUG
6887 #ifdef DEBUG
6888 C
6889 C This section to check the numerical derivatives of the energy of ith side
6890 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6891 C #define DEBUG in the code to turn it on.
6892 C
6893         write (2,*) "sumene               =",sumene
6894         aincr=1.0d-7
6895         xxsave=xx
6896         xx=xx+aincr
6897         write (2,*) xx,yy,zz
6898         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6899         de_dxx_num=(sumenep-sumene)/aincr
6900         xx=xxsave
6901         write (2,*) "xx+ sumene from enesc=",sumenep
6902         yysave=yy
6903         yy=yy+aincr
6904         write (2,*) xx,yy,zz
6905         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6906         de_dyy_num=(sumenep-sumene)/aincr
6907         yy=yysave
6908         write (2,*) "yy+ sumene from enesc=",sumenep
6909         zzsave=zz
6910         zz=zz+aincr
6911         write (2,*) xx,yy,zz
6912         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6913         de_dzz_num=(sumenep-sumene)/aincr
6914         zz=zzsave
6915         write (2,*) "zz+ sumene from enesc=",sumenep
6916         costsave=cost2tab(i+1)
6917         sintsave=sint2tab(i+1)
6918         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6919         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6920         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6921         de_dt_num=(sumenep-sumene)/aincr
6922         write (2,*) " t+ sumene from enesc=",sumenep
6923         cost2tab(i+1)=costsave
6924         sint2tab(i+1)=sintsave
6925 C End of diagnostics section.
6926 #endif
6927 C
6928 C Compute the gradient of esc
6929 C
6930 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6931         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6932         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6933         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6934         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6935         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6936         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6937         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6938         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6939         pom1=(sumene3*sint2tab(i+1)+sumene1)
6940      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6941         pom2=(sumene4*cost2tab(i+1)+sumene2)
6942      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6943         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6944         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6945      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6946      &  +x(40)*yy*zz
6947         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6948         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6949      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6950      &  +x(60)*yy*zz
6951         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6952      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6953      &        +(pom1+pom2)*pom_dx
6954 #ifdef DEBUG
6955         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6956 #endif
6957 C
6958         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6959         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6960      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6961      &  +x(40)*xx*zz
6962         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6963         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6964      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6965      &  +x(59)*zz**2 +x(60)*xx*zz
6966         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6967      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6968      &        +(pom1-pom2)*pom_dy
6969 #ifdef DEBUG
6970         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6971 #endif
6972 C
6973         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6974      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6975      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6976      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6977      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6978      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6979      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6980      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6981 #ifdef DEBUG
6982         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6983 #endif
6984 C
6985         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6986      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6987      &  +pom1*pom_dt1+pom2*pom_dt2
6988 #ifdef DEBUG
6989         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6990 #endif
6991 c#undef DEBUG
6992 c
6993 C
6994        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6995        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6996        cosfac2xx=cosfac2*xx
6997        sinfac2yy=sinfac2*yy
6998        do k = 1,3
6999          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7000      &      vbld_inv(i+1)
7001          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7002      &      vbld_inv(i)
7003          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7004          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7005 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7006 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7007 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7008 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7009          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7010          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7011          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7012          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7013          dZZ_Ci1(k)=0.0d0
7014          dZZ_Ci(k)=0.0d0
7015          do j=1,3
7016            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7017      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7018            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7019      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7020          enddo
7021
7022          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7023          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7024          dZZ_XYZ(k)=vbld_inv(i+nres)*
7025      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7026 c
7027          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7028          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7029        enddo
7030
7031        do k=1,3
7032          dXX_Ctab(k,i)=dXX_Ci(k)
7033          dXX_C1tab(k,i)=dXX_Ci1(k)
7034          dYY_Ctab(k,i)=dYY_Ci(k)
7035          dYY_C1tab(k,i)=dYY_Ci1(k)
7036          dZZ_Ctab(k,i)=dZZ_Ci(k)
7037          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7038          dXX_XYZtab(k,i)=dXX_XYZ(k)
7039          dYY_XYZtab(k,i)=dYY_XYZ(k)
7040          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7041        enddo
7042
7043        do k = 1,3
7044 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7045 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7046 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7047 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7048 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7049 c     &    dt_dci(k)
7050 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7051 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7052          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7053      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7054          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7055      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7056          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7057      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7058        enddo
7059 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7060 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7061
7062 C to check gradient call subroutine check_grad
7063
7064     1 continue
7065       enddo
7066       return
7067       end
7068 c------------------------------------------------------------------------------
7069       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7070       implicit none
7071       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7072      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7073       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7074      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7075      &   + x(10)*yy*zz
7076       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7077      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7078      & + x(20)*yy*zz
7079       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7080      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7081      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7082      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7083      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7084      &  +x(40)*xx*yy*zz
7085       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7086      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7087      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7088      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7089      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7090      &  +x(60)*xx*yy*zz
7091       dsc_i   = 0.743d0+x(61)
7092       dp2_i   = 1.9d0+x(62)
7093       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7094      &          *(xx*cost2+yy*sint2))
7095       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7096      &          *(xx*cost2-yy*sint2))
7097       s1=(1+x(63))/(0.1d0 + dscp1)
7098       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7099       s2=(1+x(65))/(0.1d0 + dscp2)
7100       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7101       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7102      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7103       enesc=sumene
7104       return
7105       end
7106 #endif
7107 c------------------------------------------------------------------------------
7108       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7109 C
7110 C This procedure calculates two-body contact function g(rij) and its derivative:
7111 C
7112 C           eps0ij                                     !       x < -1
7113 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7114 C            0                                         !       x > 1
7115 C
7116 C where x=(rij-r0ij)/delta
7117 C
7118 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7119 C
7120       implicit none
7121       double precision rij,r0ij,eps0ij,fcont,fprimcont
7122       double precision x,x2,x4,delta
7123 c     delta=0.02D0*r0ij
7124 c      delta=0.2D0*r0ij
7125       x=(rij-r0ij)/delta
7126       if (x.lt.-1.0D0) then
7127         fcont=eps0ij
7128         fprimcont=0.0D0
7129       else if (x.le.1.0D0) then
7130         x2=x*x
7131         x4=x2*x2
7132         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7133         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7134       else
7135         fcont=0.0D0
7136         fprimcont=0.0D0
7137       endif
7138       return
7139       end
7140 c------------------------------------------------------------------------------
7141       subroutine splinthet(theti,delta,ss,ssder)
7142       implicit real*8 (a-h,o-z)
7143       include 'DIMENSIONS'
7144       include 'COMMON.VAR'
7145       include 'COMMON.GEO'
7146       thetup=pi-delta
7147       thetlow=delta
7148       if (theti.gt.pipol) then
7149         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7150       else
7151         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7152         ssder=-ssder
7153       endif
7154       return
7155       end
7156 c------------------------------------------------------------------------------
7157       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7158       implicit none
7159       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7160       double precision ksi,ksi2,ksi3,a1,a2,a3
7161       a1=fprim0*delta/(f1-f0)
7162       a2=3.0d0-2.0d0*a1
7163       a3=a1-2.0d0
7164       ksi=(x-x0)/delta
7165       ksi2=ksi*ksi
7166       ksi3=ksi2*ksi
7167       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7168       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7169       return
7170       end
7171 c------------------------------------------------------------------------------
7172       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7173       implicit none
7174       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7175       double precision ksi,ksi2,ksi3,a1,a2,a3
7176       ksi=(x-x0)/delta
7177       ksi2=ksi*ksi
7178       ksi3=ksi2*ksi
7179       a1=fprim0x*delta
7180       a2=3*(f1x-f0x)-2*fprim0x*delta
7181       a3=fprim0x*delta-2*(f1x-f0x)
7182       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7183       return
7184       end
7185 C-----------------------------------------------------------------------------
7186 #ifdef CRYST_TOR
7187 C-----------------------------------------------------------------------------
7188       subroutine etor(etors,edihcnstr)
7189       implicit real*8 (a-h,o-z)
7190       include 'DIMENSIONS'
7191       include 'COMMON.VAR'
7192       include 'COMMON.GEO'
7193       include 'COMMON.LOCAL'
7194       include 'COMMON.TORSION'
7195       include 'COMMON.INTERACT'
7196       include 'COMMON.DERIV'
7197       include 'COMMON.CHAIN'
7198       include 'COMMON.NAMES'
7199       include 'COMMON.IOUNITS'
7200       include 'COMMON.FFIELD'
7201       include 'COMMON.TORCNSTR'
7202       include 'COMMON.CONTROL'
7203       logical lprn
7204 C Set lprn=.true. for debugging
7205       lprn=.false.
7206 c      lprn=.true.
7207       etors=0.0D0
7208       do i=iphi_start,iphi_end
7209       etors_ii=0.0D0
7210         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7211      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7212         itori=itortyp(itype(i-2))
7213         itori1=itortyp(itype(i-1))
7214         phii=phi(i)
7215         gloci=0.0D0
7216 C Proline-Proline pair is a special case...
7217         if (itori.eq.3 .and. itori1.eq.3) then
7218           if (phii.gt.-dwapi3) then
7219             cosphi=dcos(3*phii)
7220             fac=1.0D0/(1.0D0-cosphi)
7221             etorsi=v1(1,3,3)*fac
7222             etorsi=etorsi+etorsi
7223             etors=etors+etorsi-v1(1,3,3)
7224             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7225             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7226           endif
7227           do j=1,3
7228             v1ij=v1(j+1,itori,itori1)
7229             v2ij=v2(j+1,itori,itori1)
7230             cosphi=dcos(j*phii)
7231             sinphi=dsin(j*phii)
7232             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7233             if (energy_dec) etors_ii=etors_ii+
7234      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7235             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7236           enddo
7237         else
7238           do j=1,nterm_old
7239             v1ij=v1(j,itori,itori1)
7240             v2ij=v2(j,itori,itori1)
7241             cosphi=dcos(j*phii)
7242             sinphi=dsin(j*phii)
7243             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7244             if (energy_dec) etors_ii=etors_ii+
7245      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7246             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7247           enddo
7248         endif
7249         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7250              'etor',i,etors_ii
7251         if (lprn)
7252      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7253      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7254      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7255         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7256 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7257       enddo
7258 ! 6/20/98 - dihedral angle constraints
7259       edihcnstr=0.0d0
7260       do i=1,ndih_constr
7261         itori=idih_constr(i)
7262         phii=phi(itori)
7263         difi=phii-phi0(i)
7264         if (difi.gt.drange(i)) then
7265           difi=difi-drange(i)
7266           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7267           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7268         else if (difi.lt.-drange(i)) then
7269           difi=difi+drange(i)
7270           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7271           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7272         endif
7273 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7274 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7275       enddo
7276 !      write (iout,*) 'edihcnstr',edihcnstr
7277       return
7278       end
7279 c------------------------------------------------------------------------------
7280       subroutine etor_d(etors_d)
7281       etors_d=0.0d0
7282       return
7283       end
7284 c----------------------------------------------------------------------------
7285 #else
7286       subroutine etor(etors,edihcnstr)
7287       implicit real*8 (a-h,o-z)
7288       include 'DIMENSIONS'
7289       include 'COMMON.VAR'
7290       include 'COMMON.GEO'
7291       include 'COMMON.LOCAL'
7292       include 'COMMON.TORSION'
7293       include 'COMMON.INTERACT'
7294       include 'COMMON.DERIV'
7295       include 'COMMON.CHAIN'
7296       include 'COMMON.NAMES'
7297       include 'COMMON.IOUNITS'
7298       include 'COMMON.FFIELD'
7299       include 'COMMON.TORCNSTR'
7300       include 'COMMON.CONTROL'
7301       logical lprn
7302 C Set lprn=.true. for debugging
7303       lprn=.false.
7304 c     lprn=.true.
7305       etors=0.0D0
7306       do i=iphi_start,iphi_end
7307 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7308 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7309 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7310 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7311         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7312      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7313 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7314 C For introducing the NH3+ and COO- group please check the etor_d for reference
7315 C and guidance
7316         etors_ii=0.0D0
7317          if (iabs(itype(i)).eq.20) then
7318          iblock=2
7319          else
7320          iblock=1
7321          endif
7322         itori=itortyp(itype(i-2))
7323         itori1=itortyp(itype(i-1))
7324         phii=phi(i)
7325         gloci=0.0D0
7326 C Regular cosine and sine terms
7327         do j=1,nterm(itori,itori1,iblock)
7328           v1ij=v1(j,itori,itori1,iblock)
7329           v2ij=v2(j,itori,itori1,iblock)
7330           cosphi=dcos(j*phii)
7331           sinphi=dsin(j*phii)
7332           etors=etors+v1ij*cosphi+v2ij*sinphi
7333           if (energy_dec) etors_ii=etors_ii+
7334      &                v1ij*cosphi+v2ij*sinphi
7335           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7336         enddo
7337 C Lorentz terms
7338 C                         v1
7339 C  E = SUM ----------------------------------- - v1
7340 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7341 C
7342         cosphi=dcos(0.5d0*phii)
7343         sinphi=dsin(0.5d0*phii)
7344         do j=1,nlor(itori,itori1,iblock)
7345           vl1ij=vlor1(j,itori,itori1)
7346           vl2ij=vlor2(j,itori,itori1)
7347           vl3ij=vlor3(j,itori,itori1)
7348           pom=vl2ij*cosphi+vl3ij*sinphi
7349           pom1=1.0d0/(pom*pom+1.0d0)
7350           etors=etors+vl1ij*pom1
7351           if (energy_dec) etors_ii=etors_ii+
7352      &                vl1ij*pom1
7353           pom=-pom*pom1*pom1
7354           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7355         enddo
7356 C Subtract the constant term
7357         etors=etors-v0(itori,itori1,iblock)
7358           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7359      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7360         if (lprn)
7361      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7362      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7363      &  (v1(j,itori,itori1,iblock),j=1,6),
7364      &  (v2(j,itori,itori1,iblock),j=1,6)
7365         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7366 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7367       enddo
7368 ! 6/20/98 - dihedral angle constraints
7369       edihcnstr=0.0d0
7370 c      do i=1,ndih_constr
7371       do i=idihconstr_start,idihconstr_end
7372         itori=idih_constr(i)
7373         phii=phi(itori)
7374         difi=pinorm(phii-phi0(i))
7375         if (difi.gt.drange(i)) then
7376           difi=difi-drange(i)
7377           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7378           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7379         else if (difi.lt.-drange(i)) then
7380           difi=difi+drange(i)
7381           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7382           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7383         else
7384           difi=0.0
7385         endif
7386        if (energy_dec) then
7387         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7388      &    i,itori,rad2deg*phii,
7389      &    rad2deg*phi0(i),  rad2deg*drange(i),
7390      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7391         endif
7392       enddo
7393 cd       write (iout,*) 'edihcnstr',edihcnstr
7394       return
7395       end
7396 c----------------------------------------------------------------------------
7397       subroutine etor_d(etors_d)
7398 C 6/23/01 Compute double torsional energy
7399       implicit real*8 (a-h,o-z)
7400       include 'DIMENSIONS'
7401       include 'COMMON.VAR'
7402       include 'COMMON.GEO'
7403       include 'COMMON.LOCAL'
7404       include 'COMMON.TORSION'
7405       include 'COMMON.INTERACT'
7406       include 'COMMON.DERIV'
7407       include 'COMMON.CHAIN'
7408       include 'COMMON.NAMES'
7409       include 'COMMON.IOUNITS'
7410       include 'COMMON.FFIELD'
7411       include 'COMMON.TORCNSTR'
7412       logical lprn
7413 C Set lprn=.true. for debugging
7414       lprn=.false.
7415 c     lprn=.true.
7416       etors_d=0.0D0
7417 c      write(iout,*) "a tu??"
7418       do i=iphid_start,iphid_end
7419 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7420 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7421 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7422 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7423 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7424          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7425      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7426      &  (itype(i+1).eq.ntyp1)) cycle
7427 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7428         itori=itortyp(itype(i-2))
7429         itori1=itortyp(itype(i-1))
7430         itori2=itortyp(itype(i))
7431         phii=phi(i)
7432         phii1=phi(i+1)
7433         gloci1=0.0D0
7434         gloci2=0.0D0
7435         iblock=1
7436         if (iabs(itype(i+1)).eq.20) iblock=2
7437 C Iblock=2 Proline type
7438 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7439 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7440 C        if (itype(i+1).eq.ntyp1) iblock=3
7441 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7442 C IS or IS NOT need for this
7443 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7444 C        is (itype(i-3).eq.ntyp1) ntblock=2
7445 C        ntblock is N-terminal blocking group
7446
7447 C Regular cosine and sine terms
7448         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7449 C Example of changes for NH3+ blocking group
7450 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7451 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7452           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7453           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7454           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7455           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7456           cosphi1=dcos(j*phii)
7457           sinphi1=dsin(j*phii)
7458           cosphi2=dcos(j*phii1)
7459           sinphi2=dsin(j*phii1)
7460           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7461      &     v2cij*cosphi2+v2sij*sinphi2
7462           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7463           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7464         enddo
7465         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7466           do l=1,k-1
7467             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7468             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7469             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7470             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7471             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7472             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7473             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7474             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7475             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7476      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7477             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7478      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7479             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7480      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7481           enddo
7482         enddo
7483         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7484         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7485       enddo
7486       return
7487       end
7488 #endif
7489 C----------------------------------------------------------------------------------
7490 C The rigorous attempt to derive energy function
7491       subroutine etor_kcc(etors,edihcnstr)
7492       implicit real*8 (a-h,o-z)
7493       include 'DIMENSIONS'
7494       include 'COMMON.VAR'
7495       include 'COMMON.GEO'
7496       include 'COMMON.LOCAL'
7497       include 'COMMON.TORSION'
7498       include 'COMMON.INTERACT'
7499       include 'COMMON.DERIV'
7500       include 'COMMON.CHAIN'
7501       include 'COMMON.NAMES'
7502       include 'COMMON.IOUNITS'
7503       include 'COMMON.FFIELD'
7504       include 'COMMON.TORCNSTR'
7505       include 'COMMON.CONTROL'
7506       logical lprn
7507 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7508 C Set lprn=.true. for debugging
7509       lprn=.false.
7510 c     lprn=.true.
7511 C      print *,"wchodze kcc"
7512       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7513       if (tor_mode.ne.2) then
7514       etors=0.0D0
7515       endif
7516       do i=iphi_start,iphi_end
7517 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7518 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7519 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7520 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7521         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7522      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7523         itori=itortyp_kcc(itype(i-2))
7524         itori1=itortyp_kcc(itype(i-1))
7525         phii=phi(i)
7526         glocig=0.0D0
7527         glocit1=0.0d0
7528         glocit2=0.0d0
7529         sumnonchebyshev=0.0d0
7530         sumchebyshev=0.0d0
7531 C to avoid multiple devision by 2
7532 c        theti22=0.5d0*theta(i)
7533 C theta 12 is the theta_1 /2
7534 C theta 22 is theta_2 /2
7535 c        theti12=0.5d0*theta(i-1)
7536 C and appropriate sinus function
7537         sinthet1=dsin(theta(i-1))
7538         sinthet2=dsin(theta(i))
7539         costhet1=dcos(theta(i-1))
7540         costhet2=dcos(theta(i))
7541 c Cosines of halves thetas
7542         costheti12=0.5d0*(1.0d0+costhet1)
7543         costheti22=0.5d0*(1.0d0+costhet2)
7544 C to speed up lets store its mutliplication
7545         sint1t2=sinthet2*sinthet1
7546         sint1t2n=1.0d0
7547 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7548 C +d_n*sin(n*gamma)) *
7549 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7550 C we have two sum 1) Non-Chebyshev which is with n and gamma
7551         etori=0.0d0
7552         do j=1,nterm_kcc(itori,itori1)
7553
7554           nval=nterm_kcc_Tb(itori,itori1)
7555           v1ij=v1_kcc(j,itori,itori1)
7556           v2ij=v2_kcc(j,itori,itori1)
7557 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7558 C v1ij is c_n and d_n in euation above
7559           cosphi=dcos(j*phii)
7560           sinphi=dsin(j*phii)
7561           sint1t2n1=sint1t2n
7562           sint1t2n=sint1t2n*sint1t2
7563           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7564      &        costheti12)
7565           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7566      &        v11_chyb(1,j,itori,itori1),costheti12)
7567 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7568 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7569           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7570      &        costheti22)
7571           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7572      &        v21_chyb(1,j,itori,itori1),costheti22)
7573 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7574 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7575           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7576      &        costheti12)
7577           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7578      &        v12_chyb(1,j,itori,itori1),costheti12)
7579 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7580 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7581           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7582      &        costheti22)
7583           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7584      &        v22_chyb(1,j,itori,itori1),costheti22)
7585 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7586 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7587 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7588 C          if (energy_dec) etors_ii=etors_ii+
7589 C     &                v1ij*cosphi+v2ij*sinphi
7590 C glocig is the gradient local i site in gamma
7591           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7592           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7593           etori=etori+sint1t2n*(actval1+actval2)
7594           glocig=glocig+
7595      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7596      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7597 C now gradient over theta_1
7598           glocit1=glocit1+
7599      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7600      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7601           glocit2=glocit2+
7602      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7603      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7604
7605 C now the Czebyshev polinominal sum
7606 c        do k=1,nterm_kcc_Tb(itori,itori1)
7607 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7608 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7609 C         thybt1(k)=0.0
7610 C         thybt2(k)=0.0
7611 c        enddo
7612 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7613 C     &         gradtschebyshev
7614 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7615 C     &         dcos(theti22)**2),
7616 C     &         dsin(theti22)
7617
7618 C now overal sumation
7619 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7620         enddo ! j
7621         etors=etors+etori
7622 C derivative over gamma
7623         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7624 C derivative over theta1
7625         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7626 C now derivative over theta2
7627         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7628         if (lprn)
7629      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7630      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7631       enddo
7632 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7633 ! 6/20/98 - dihedral angle constraints
7634       if (tor_mode.ne.2) then
7635       edihcnstr=0.0d0
7636 c      do i=1,ndih_constr
7637       do i=idihconstr_start,idihconstr_end
7638         itori=idih_constr(i)
7639         phii=phi(itori)
7640         difi=pinorm(phii-phi0(i))
7641         if (difi.gt.drange(i)) then
7642           difi=difi-drange(i)
7643           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7644           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7645         else if (difi.lt.-drange(i)) then
7646           difi=difi+drange(i)
7647           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7648           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7649         else
7650           difi=0.0
7651         endif
7652        enddo
7653        endif
7654       return
7655       end
7656
7657 C The rigorous attempt to derive energy function
7658       subroutine ebend_kcc(etheta,ethetacnstr)
7659
7660       implicit real*8 (a-h,o-z)
7661       include 'DIMENSIONS'
7662       include 'COMMON.VAR'
7663       include 'COMMON.GEO'
7664       include 'COMMON.LOCAL'
7665       include 'COMMON.TORSION'
7666       include 'COMMON.INTERACT'
7667       include 'COMMON.DERIV'
7668       include 'COMMON.CHAIN'
7669       include 'COMMON.NAMES'
7670       include 'COMMON.IOUNITS'
7671       include 'COMMON.FFIELD'
7672       include 'COMMON.TORCNSTR'
7673       include 'COMMON.CONTROL'
7674       logical lprn
7675       double precision thybt1(maxtermkcc)
7676 C Set lprn=.true. for debugging
7677       lprn=.false.
7678 c     lprn=.true.
7679 C      print *,"wchodze kcc"
7680       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7681       if (tor_mode.ne.2) etheta=0.0D0
7682       do i=ithet_start,ithet_end
7683 c        print *,i,itype(i-1),itype(i),itype(i-2)
7684         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7685      &  .or.itype(i).eq.ntyp1) cycle
7686          iti=itortyp_kcc(itype(i-1))
7687         sinthet=dsin(theta(i)/2.0d0)
7688         costhet=dcos(theta(i)/2.0d0)
7689          do j=1,nbend_kcc_Tb(iti)
7690           thybt1(j)=v1bend_chyb(j,iti)
7691          enddo
7692          sumth1thyb=tschebyshev
7693      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7694         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7695      &    sumth1thyb
7696         ihelp=nbend_kcc_Tb(iti)-1
7697         gradthybt1=gradtschebyshev
7698      &         (0,ihelp,thybt1(1),costhet)
7699         etheta=etheta+sumth1thyb
7700 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7701         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7702      &   gradthybt1*sinthet*(-0.5d0)
7703       enddo
7704       if (tor_mode.ne.2) then
7705       ethetacnstr=0.0d0
7706 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7707       do i=ithetaconstr_start,ithetaconstr_end
7708         itheta=itheta_constr(i)
7709         thetiii=theta(itheta)
7710         difi=pinorm(thetiii-theta_constr0(i))
7711         if (difi.gt.theta_drange(i)) then
7712           difi=difi-theta_drange(i)
7713           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7714           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7715      &    +for_thet_constr(i)*difi**3
7716         else if (difi.lt.-drange(i)) then
7717           difi=difi+drange(i)
7718           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7719           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7720      &    +for_thet_constr(i)*difi**3
7721         else
7722           difi=0.0
7723         endif
7724        if (energy_dec) then
7725         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7726      &    i,itheta,rad2deg*thetiii,
7727      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7728      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7729      &    gloc(itheta+nphi-2,icg)
7730         endif
7731       enddo
7732       endif
7733       return
7734       end
7735 c------------------------------------------------------------------------------
7736       subroutine eback_sc_corr(esccor)
7737 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7738 c        conformational states; temporarily implemented as differences
7739 c        between UNRES torsional potentials (dependent on three types of
7740 c        residues) and the torsional potentials dependent on all 20 types
7741 c        of residues computed from AM1  energy surfaces of terminally-blocked
7742 c        amino-acid residues.
7743       implicit real*8 (a-h,o-z)
7744       include 'DIMENSIONS'
7745       include 'COMMON.VAR'
7746       include 'COMMON.GEO'
7747       include 'COMMON.LOCAL'
7748       include 'COMMON.TORSION'
7749       include 'COMMON.SCCOR'
7750       include 'COMMON.INTERACT'
7751       include 'COMMON.DERIV'
7752       include 'COMMON.CHAIN'
7753       include 'COMMON.NAMES'
7754       include 'COMMON.IOUNITS'
7755       include 'COMMON.FFIELD'
7756       include 'COMMON.CONTROL'
7757       logical lprn
7758 C Set lprn=.true. for debugging
7759       lprn=.false.
7760 c      lprn=.true.
7761 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7762       esccor=0.0D0
7763       do i=itau_start,itau_end
7764         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7765         esccor_ii=0.0D0
7766         isccori=isccortyp(itype(i-2))
7767         isccori1=isccortyp(itype(i-1))
7768 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7769         phii=phi(i)
7770         do intertyp=1,3 !intertyp
7771 cc Added 09 May 2012 (Adasko)
7772 cc  Intertyp means interaction type of backbone mainchain correlation:
7773 c   1 = SC...Ca...Ca...Ca
7774 c   2 = Ca...Ca...Ca...SC
7775 c   3 = SC...Ca...Ca...SCi
7776         gloci=0.0D0
7777         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7778      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7779      &      (itype(i-1).eq.ntyp1)))
7780      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7781      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7782      &     .or.(itype(i).eq.ntyp1)))
7783      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7784      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7785      &      (itype(i-3).eq.ntyp1)))) cycle
7786         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7787         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7788      & cycle
7789        do j=1,nterm_sccor(isccori,isccori1)
7790           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7791           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7792           cosphi=dcos(j*tauangle(intertyp,i))
7793           sinphi=dsin(j*tauangle(intertyp,i))
7794           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7795           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7796         enddo
7797 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7798         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7799         if (lprn)
7800      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7801      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7802      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7803      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7804         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7805        enddo !intertyp
7806       enddo
7807
7808       return
7809       end
7810 c----------------------------------------------------------------------------
7811       subroutine multibody(ecorr)
7812 C This subroutine calculates multi-body contributions to energy following
7813 C the idea of Skolnick et al. If side chains I and J make a contact and
7814 C at the same time side chains I+1 and J+1 make a contact, an extra
7815 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7816       implicit real*8 (a-h,o-z)
7817       include 'DIMENSIONS'
7818       include 'COMMON.IOUNITS'
7819       include 'COMMON.DERIV'
7820       include 'COMMON.INTERACT'
7821       include 'COMMON.CONTACTS'
7822       double precision gx(3),gx1(3)
7823       logical lprn
7824
7825 C Set lprn=.true. for debugging
7826       lprn=.false.
7827
7828       if (lprn) then
7829         write (iout,'(a)') 'Contact function values:'
7830         do i=nnt,nct-2
7831           write (iout,'(i2,20(1x,i2,f10.5))')
7832      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7833         enddo
7834       endif
7835       ecorr=0.0D0
7836       do i=nnt,nct
7837         do j=1,3
7838           gradcorr(j,i)=0.0D0
7839           gradxorr(j,i)=0.0D0
7840         enddo
7841       enddo
7842       do i=nnt,nct-2
7843
7844         DO ISHIFT = 3,4
7845
7846         i1=i+ishift
7847         num_conti=num_cont(i)
7848         num_conti1=num_cont(i1)
7849         do jj=1,num_conti
7850           j=jcont(jj,i)
7851           do kk=1,num_conti1
7852             j1=jcont(kk,i1)
7853             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7854 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7855 cd   &                   ' ishift=',ishift
7856 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7857 C The system gains extra energy.
7858               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7859             endif   ! j1==j+-ishift
7860           enddo     ! kk
7861         enddo       ! jj
7862
7863         ENDDO ! ISHIFT
7864
7865       enddo         ! i
7866       return
7867       end
7868 c------------------------------------------------------------------------------
7869       double precision function esccorr(i,j,k,l,jj,kk)
7870       implicit real*8 (a-h,o-z)
7871       include 'DIMENSIONS'
7872       include 'COMMON.IOUNITS'
7873       include 'COMMON.DERIV'
7874       include 'COMMON.INTERACT'
7875       include 'COMMON.CONTACTS'
7876       include 'COMMON.SHIELD'
7877       double precision gx(3),gx1(3)
7878       logical lprn
7879       lprn=.false.
7880       eij=facont(jj,i)
7881       ekl=facont(kk,k)
7882 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7883 C Calculate the multi-body contribution to energy.
7884 C Calculate multi-body contributions to the gradient.
7885 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7886 cd   & k,l,(gacont(m,kk,k),m=1,3)
7887       do m=1,3
7888         gx(m) =ekl*gacont(m,jj,i)
7889         gx1(m)=eij*gacont(m,kk,k)
7890         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7891         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7892         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7893         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7894       enddo
7895       do m=i,j-1
7896         do ll=1,3
7897           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7898         enddo
7899       enddo
7900       do m=k,l-1
7901         do ll=1,3
7902           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7903         enddo
7904       enddo
7905       esccorr=-eij*ekl
7906       return
7907       end
7908 c------------------------------------------------------------------------------
7909       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7910 C This subroutine calculates multi-body contributions to hydrogen-bonding
7911       implicit real*8 (a-h,o-z)
7912       include 'DIMENSIONS'
7913       include 'COMMON.IOUNITS'
7914 #ifdef MPI
7915       include "mpif.h"
7916       parameter (max_cont=maxconts)
7917       parameter (max_dim=26)
7918       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7919       double precision zapas(max_dim,maxconts,max_fg_procs),
7920      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7921       common /przechowalnia/ zapas
7922       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7923      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7924 #endif
7925       include 'COMMON.SETUP'
7926       include 'COMMON.FFIELD'
7927       include 'COMMON.DERIV'
7928       include 'COMMON.INTERACT'
7929       include 'COMMON.CONTACTS'
7930       include 'COMMON.CONTROL'
7931       include 'COMMON.LOCAL'
7932       double precision gx(3),gx1(3),time00
7933       logical lprn,ldone
7934
7935 C Set lprn=.true. for debugging
7936       lprn=.false.
7937 #ifdef MPI
7938       n_corr=0
7939       n_corr1=0
7940       if (nfgtasks.le.1) goto 30
7941       if (lprn) then
7942         write (iout,'(a)') 'Contact function values before RECEIVE:'
7943         do i=nnt,nct-2
7944           write (iout,'(2i3,50(1x,i2,f5.2))')
7945      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7946      &    j=1,num_cont_hb(i))
7947         enddo
7948       endif
7949       call flush(iout)
7950       do i=1,ntask_cont_from
7951         ncont_recv(i)=0
7952       enddo
7953       do i=1,ntask_cont_to
7954         ncont_sent(i)=0
7955       enddo
7956 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7957 c     & ntask_cont_to
7958 C Make the list of contacts to send to send to other procesors
7959 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7960 c      call flush(iout)
7961       do i=iturn3_start,iturn3_end
7962 c        write (iout,*) "make contact list turn3",i," num_cont",
7963 c     &    num_cont_hb(i)
7964         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7965       enddo
7966       do i=iturn4_start,iturn4_end
7967 c        write (iout,*) "make contact list turn4",i," num_cont",
7968 c     &   num_cont_hb(i)
7969         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7970       enddo
7971       do ii=1,nat_sent
7972         i=iat_sent(ii)
7973 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7974 c     &    num_cont_hb(i)
7975         do j=1,num_cont_hb(i)
7976         do k=1,4
7977           jjc=jcont_hb(j,i)
7978           iproc=iint_sent_local(k,jjc,ii)
7979 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7980           if (iproc.gt.0) then
7981             ncont_sent(iproc)=ncont_sent(iproc)+1
7982             nn=ncont_sent(iproc)
7983             zapas(1,nn,iproc)=i
7984             zapas(2,nn,iproc)=jjc
7985             zapas(3,nn,iproc)=facont_hb(j,i)
7986             zapas(4,nn,iproc)=ees0p(j,i)
7987             zapas(5,nn,iproc)=ees0m(j,i)
7988             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7989             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7990             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7991             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7992             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7993             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7994             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7995             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7996             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7997             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7998             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7999             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8000             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8001             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8002             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8003             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8004             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8005             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8006             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8007             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8008             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8009           endif
8010         enddo
8011         enddo
8012       enddo
8013       if (lprn) then
8014       write (iout,*)
8015      &  "Numbers of contacts to be sent to other processors",
8016      &  (ncont_sent(i),i=1,ntask_cont_to)
8017       write (iout,*) "Contacts sent"
8018       do ii=1,ntask_cont_to
8019         nn=ncont_sent(ii)
8020         iproc=itask_cont_to(ii)
8021         write (iout,*) nn," contacts to processor",iproc,
8022      &   " of CONT_TO_COMM group"
8023         do i=1,nn
8024           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8025         enddo
8026       enddo
8027       call flush(iout)
8028       endif
8029       CorrelType=477
8030       CorrelID=fg_rank+1
8031       CorrelType1=478
8032       CorrelID1=nfgtasks+fg_rank+1
8033       ireq=0
8034 C Receive the numbers of needed contacts from other processors
8035       do ii=1,ntask_cont_from
8036         iproc=itask_cont_from(ii)
8037         ireq=ireq+1
8038         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8039      &    FG_COMM,req(ireq),IERR)
8040       enddo
8041 c      write (iout,*) "IRECV ended"
8042 c      call flush(iout)
8043 C Send the number of contacts needed by other processors
8044       do ii=1,ntask_cont_to
8045         iproc=itask_cont_to(ii)
8046         ireq=ireq+1
8047         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8048      &    FG_COMM,req(ireq),IERR)
8049       enddo
8050 c      write (iout,*) "ISEND ended"
8051 c      write (iout,*) "number of requests (nn)",ireq
8052       call flush(iout)
8053       if (ireq.gt.0)
8054      &  call MPI_Waitall(ireq,req,status_array,ierr)
8055 c      write (iout,*)
8056 c     &  "Numbers of contacts to be received from other processors",
8057 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8058 c      call flush(iout)
8059 C Receive contacts
8060       ireq=0
8061       do ii=1,ntask_cont_from
8062         iproc=itask_cont_from(ii)
8063         nn=ncont_recv(ii)
8064 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8065 c     &   " of CONT_TO_COMM group"
8066         call flush(iout)
8067         if (nn.gt.0) then
8068           ireq=ireq+1
8069           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8070      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8071 c          write (iout,*) "ireq,req",ireq,req(ireq)
8072         endif
8073       enddo
8074 C Send the contacts to processors that need them
8075       do ii=1,ntask_cont_to
8076         iproc=itask_cont_to(ii)
8077         nn=ncont_sent(ii)
8078 c        write (iout,*) nn," contacts to processor",iproc,
8079 c     &   " of CONT_TO_COMM group"
8080         if (nn.gt.0) then
8081           ireq=ireq+1
8082           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8083      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8084 c          write (iout,*) "ireq,req",ireq,req(ireq)
8085 c          do i=1,nn
8086 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8087 c          enddo
8088         endif
8089       enddo
8090 c      write (iout,*) "number of requests (contacts)",ireq
8091 c      write (iout,*) "req",(req(i),i=1,4)
8092 c      call flush(iout)
8093       if (ireq.gt.0)
8094      & call MPI_Waitall(ireq,req,status_array,ierr)
8095       do iii=1,ntask_cont_from
8096         iproc=itask_cont_from(iii)
8097         nn=ncont_recv(iii)
8098         if (lprn) then
8099         write (iout,*) "Received",nn," contacts from processor",iproc,
8100      &   " of CONT_FROM_COMM group"
8101         call flush(iout)
8102         do i=1,nn
8103           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8104         enddo
8105         call flush(iout)
8106         endif
8107         do i=1,nn
8108           ii=zapas_recv(1,i,iii)
8109 c Flag the received contacts to prevent double-counting
8110           jj=-zapas_recv(2,i,iii)
8111 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8112 c          call flush(iout)
8113           nnn=num_cont_hb(ii)+1
8114           num_cont_hb(ii)=nnn
8115           jcont_hb(nnn,ii)=jj
8116           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8117           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8118           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8119           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8120           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8121           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8122           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8123           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8124           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8125           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8126           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8127           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8128           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8129           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8130           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8131           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8132           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8133           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8134           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8135           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8136           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8137           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8138           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8139           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8140         enddo
8141       enddo
8142       call flush(iout)
8143       if (lprn) then
8144         write (iout,'(a)') 'Contact function values after receive:'
8145         do i=nnt,nct-2
8146           write (iout,'(2i3,50(1x,i3,f5.2))')
8147      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8148      &    j=1,num_cont_hb(i))
8149         enddo
8150         call flush(iout)
8151       endif
8152    30 continue
8153 #endif
8154       if (lprn) then
8155         write (iout,'(a)') 'Contact function values:'
8156         do i=nnt,nct-2
8157           write (iout,'(2i3,50(1x,i3,f5.2))')
8158      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8159      &    j=1,num_cont_hb(i))
8160         enddo
8161       endif
8162       ecorr=0.0D0
8163 C Remove the loop below after debugging !!!
8164       do i=nnt,nct
8165         do j=1,3
8166           gradcorr(j,i)=0.0D0
8167           gradxorr(j,i)=0.0D0
8168         enddo
8169       enddo
8170 C Calculate the local-electrostatic correlation terms
8171       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8172         i1=i+1
8173         num_conti=num_cont_hb(i)
8174         num_conti1=num_cont_hb(i+1)
8175         do jj=1,num_conti
8176           j=jcont_hb(jj,i)
8177           jp=iabs(j)
8178           do kk=1,num_conti1
8179             j1=jcont_hb(kk,i1)
8180             jp1=iabs(j1)
8181 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8182 c     &         ' jj=',jj,' kk=',kk
8183             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8184      &          .or. j.lt.0 .and. j1.gt.0) .and.
8185      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8186 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8187 C The system gains extra energy.
8188               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8189               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8190      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8191               n_corr=n_corr+1
8192             else if (j1.eq.j) then
8193 C Contacts I-J and I-(J+1) occur simultaneously.
8194 C The system loses extra energy.
8195 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8196             endif
8197           enddo ! kk
8198           do kk=1,num_conti
8199             j1=jcont_hb(kk,i)
8200 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8201 c    &         ' jj=',jj,' kk=',kk
8202             if (j1.eq.j+1) then
8203 C Contacts I-J and (I+1)-J occur simultaneously.
8204 C The system loses extra energy.
8205 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8206             endif ! j1==j+1
8207           enddo ! kk
8208         enddo ! jj
8209       enddo ! i
8210       return
8211       end
8212 c------------------------------------------------------------------------------
8213       subroutine add_hb_contact(ii,jj,itask)
8214       implicit real*8 (a-h,o-z)
8215       include "DIMENSIONS"
8216       include "COMMON.IOUNITS"
8217       integer max_cont
8218       integer max_dim
8219       parameter (max_cont=maxconts)
8220       parameter (max_dim=26)
8221       include "COMMON.CONTACTS"
8222       double precision zapas(max_dim,maxconts,max_fg_procs),
8223      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8224       common /przechowalnia/ zapas
8225       integer i,j,ii,jj,iproc,itask(4),nn
8226 c      write (iout,*) "itask",itask
8227       do i=1,2
8228         iproc=itask(i)
8229         if (iproc.gt.0) then
8230           do j=1,num_cont_hb(ii)
8231             jjc=jcont_hb(j,ii)
8232 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8233             if (jjc.eq.jj) then
8234               ncont_sent(iproc)=ncont_sent(iproc)+1
8235               nn=ncont_sent(iproc)
8236               zapas(1,nn,iproc)=ii
8237               zapas(2,nn,iproc)=jjc
8238               zapas(3,nn,iproc)=facont_hb(j,ii)
8239               zapas(4,nn,iproc)=ees0p(j,ii)
8240               zapas(5,nn,iproc)=ees0m(j,ii)
8241               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8242               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8243               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8244               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8245               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8246               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8247               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8248               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8249               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8250               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8251               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8252               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8253               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8254               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8255               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8256               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8257               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8258               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8259               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8260               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8261               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8262               exit
8263             endif
8264           enddo
8265         endif
8266       enddo
8267       return
8268       end
8269 c------------------------------------------------------------------------------
8270       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8271      &  n_corr1)
8272 C This subroutine calculates multi-body contributions to hydrogen-bonding
8273       implicit real*8 (a-h,o-z)
8274       include 'DIMENSIONS'
8275       include 'COMMON.IOUNITS'
8276 #ifdef MPI
8277       include "mpif.h"
8278       parameter (max_cont=maxconts)
8279       parameter (max_dim=70)
8280       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8281       double precision zapas(max_dim,maxconts,max_fg_procs),
8282      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8283       common /przechowalnia/ zapas
8284       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8285      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8286 #endif
8287       include 'COMMON.SETUP'
8288       include 'COMMON.FFIELD'
8289       include 'COMMON.DERIV'
8290       include 'COMMON.LOCAL'
8291       include 'COMMON.INTERACT'
8292       include 'COMMON.CONTACTS'
8293       include 'COMMON.CHAIN'
8294       include 'COMMON.CONTROL'
8295       include 'COMMON.SHIELD'
8296       double precision gx(3),gx1(3)
8297       integer num_cont_hb_old(maxres)
8298       logical lprn,ldone
8299       double precision eello4,eello5,eelo6,eello_turn6
8300       external eello4,eello5,eello6,eello_turn6
8301 C Set lprn=.true. for debugging
8302       lprn=.false.
8303       eturn6=0.0d0
8304 #ifdef MPI
8305       do i=1,nres
8306         num_cont_hb_old(i)=num_cont_hb(i)
8307       enddo
8308       n_corr=0
8309       n_corr1=0
8310       if (nfgtasks.le.1) goto 30
8311       if (lprn) then
8312         write (iout,'(a)') 'Contact function values before RECEIVE:'
8313         do i=nnt,nct-2
8314           write (iout,'(2i3,50(1x,i2,f5.2))')
8315      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8316      &    j=1,num_cont_hb(i))
8317         enddo
8318       endif
8319       call flush(iout)
8320       do i=1,ntask_cont_from
8321         ncont_recv(i)=0
8322       enddo
8323       do i=1,ntask_cont_to
8324         ncont_sent(i)=0
8325       enddo
8326 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8327 c     & ntask_cont_to
8328 C Make the list of contacts to send to send to other procesors
8329       do i=iturn3_start,iturn3_end
8330 c        write (iout,*) "make contact list turn3",i," num_cont",
8331 c     &    num_cont_hb(i)
8332         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8333       enddo
8334       do i=iturn4_start,iturn4_end
8335 c        write (iout,*) "make contact list turn4",i," num_cont",
8336 c     &   num_cont_hb(i)
8337         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8338       enddo
8339       do ii=1,nat_sent
8340         i=iat_sent(ii)
8341 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8342 c     &    num_cont_hb(i)
8343         do j=1,num_cont_hb(i)
8344         do k=1,4
8345           jjc=jcont_hb(j,i)
8346           iproc=iint_sent_local(k,jjc,ii)
8347 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8348           if (iproc.ne.0) then
8349             ncont_sent(iproc)=ncont_sent(iproc)+1
8350             nn=ncont_sent(iproc)
8351             zapas(1,nn,iproc)=i
8352             zapas(2,nn,iproc)=jjc
8353             zapas(3,nn,iproc)=d_cont(j,i)
8354             ind=3
8355             do kk=1,3
8356               ind=ind+1
8357               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8358             enddo
8359             do kk=1,2
8360               do ll=1,2
8361                 ind=ind+1
8362                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8363               enddo
8364             enddo
8365             do jj=1,5
8366               do kk=1,3
8367                 do ll=1,2
8368                   do mm=1,2
8369                     ind=ind+1
8370                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8371                   enddo
8372                 enddo
8373               enddo
8374             enddo
8375           endif
8376         enddo
8377         enddo
8378       enddo
8379       if (lprn) then
8380       write (iout,*)
8381      &  "Numbers of contacts to be sent to other processors",
8382      &  (ncont_sent(i),i=1,ntask_cont_to)
8383       write (iout,*) "Contacts sent"
8384       do ii=1,ntask_cont_to
8385         nn=ncont_sent(ii)
8386         iproc=itask_cont_to(ii)
8387         write (iout,*) nn," contacts to processor",iproc,
8388      &   " of CONT_TO_COMM group"
8389         do i=1,nn
8390           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8391         enddo
8392       enddo
8393       call flush(iout)
8394       endif
8395       CorrelType=477
8396       CorrelID=fg_rank+1
8397       CorrelType1=478
8398       CorrelID1=nfgtasks+fg_rank+1
8399       ireq=0
8400 C Receive the numbers of needed contacts from other processors
8401       do ii=1,ntask_cont_from
8402         iproc=itask_cont_from(ii)
8403         ireq=ireq+1
8404         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8405      &    FG_COMM,req(ireq),IERR)
8406       enddo
8407 c      write (iout,*) "IRECV ended"
8408 c      call flush(iout)
8409 C Send the number of contacts needed by other processors
8410       do ii=1,ntask_cont_to
8411         iproc=itask_cont_to(ii)
8412         ireq=ireq+1
8413         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8414      &    FG_COMM,req(ireq),IERR)
8415       enddo
8416 c      write (iout,*) "ISEND ended"
8417 c      write (iout,*) "number of requests (nn)",ireq
8418       call flush(iout)
8419       if (ireq.gt.0)
8420      &  call MPI_Waitall(ireq,req,status_array,ierr)
8421 c      write (iout,*)
8422 c     &  "Numbers of contacts to be received from other processors",
8423 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8424 c      call flush(iout)
8425 C Receive contacts
8426       ireq=0
8427       do ii=1,ntask_cont_from
8428         iproc=itask_cont_from(ii)
8429         nn=ncont_recv(ii)
8430 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8431 c     &   " of CONT_TO_COMM group"
8432         call flush(iout)
8433         if (nn.gt.0) then
8434           ireq=ireq+1
8435           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8436      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8437 c          write (iout,*) "ireq,req",ireq,req(ireq)
8438         endif
8439       enddo
8440 C Send the contacts to processors that need them
8441       do ii=1,ntask_cont_to
8442         iproc=itask_cont_to(ii)
8443         nn=ncont_sent(ii)
8444 c        write (iout,*) nn," contacts to processor",iproc,
8445 c     &   " of CONT_TO_COMM group"
8446         if (nn.gt.0) then
8447           ireq=ireq+1
8448           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8449      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8450 c          write (iout,*) "ireq,req",ireq,req(ireq)
8451 c          do i=1,nn
8452 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8453 c          enddo
8454         endif
8455       enddo
8456 c      write (iout,*) "number of requests (contacts)",ireq
8457 c      write (iout,*) "req",(req(i),i=1,4)
8458 c      call flush(iout)
8459       if (ireq.gt.0)
8460      & call MPI_Waitall(ireq,req,status_array,ierr)
8461       do iii=1,ntask_cont_from
8462         iproc=itask_cont_from(iii)
8463         nn=ncont_recv(iii)
8464         if (lprn) then
8465         write (iout,*) "Received",nn," contacts from processor",iproc,
8466      &   " of CONT_FROM_COMM group"
8467         call flush(iout)
8468         do i=1,nn
8469           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8470         enddo
8471         call flush(iout)
8472         endif
8473         do i=1,nn
8474           ii=zapas_recv(1,i,iii)
8475 c Flag the received contacts to prevent double-counting
8476           jj=-zapas_recv(2,i,iii)
8477 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8478 c          call flush(iout)
8479           nnn=num_cont_hb(ii)+1
8480           num_cont_hb(ii)=nnn
8481           jcont_hb(nnn,ii)=jj
8482           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8483           ind=3
8484           do kk=1,3
8485             ind=ind+1
8486             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8487           enddo
8488           do kk=1,2
8489             do ll=1,2
8490               ind=ind+1
8491               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8492             enddo
8493           enddo
8494           do jj=1,5
8495             do kk=1,3
8496               do ll=1,2
8497                 do mm=1,2
8498                   ind=ind+1
8499                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8500                 enddo
8501               enddo
8502             enddo
8503           enddo
8504         enddo
8505       enddo
8506       call flush(iout)
8507       if (lprn) then
8508         write (iout,'(a)') 'Contact function values after receive:'
8509         do i=nnt,nct-2
8510           write (iout,'(2i3,50(1x,i3,5f6.3))')
8511      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8512      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8513         enddo
8514         call flush(iout)
8515       endif
8516    30 continue
8517 #endif
8518       if (lprn) then
8519         write (iout,'(a)') 'Contact function values:'
8520         do i=nnt,nct-2
8521           write (iout,'(2i3,50(1x,i2,5f6.3))')
8522      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8523      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8524         enddo
8525       endif
8526       ecorr=0.0D0
8527       ecorr5=0.0d0
8528       ecorr6=0.0d0
8529 C Remove the loop below after debugging !!!
8530       do i=nnt,nct
8531         do j=1,3
8532           gradcorr(j,i)=0.0D0
8533           gradxorr(j,i)=0.0D0
8534         enddo
8535       enddo
8536 C Calculate the dipole-dipole interaction energies
8537       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8538       do i=iatel_s,iatel_e+1
8539         num_conti=num_cont_hb(i)
8540         do jj=1,num_conti
8541           j=jcont_hb(jj,i)
8542 #ifdef MOMENT
8543           call dipole(i,j,jj)
8544 #endif
8545         enddo
8546       enddo
8547       endif
8548 C Calculate the local-electrostatic correlation terms
8549 c                write (iout,*) "gradcorr5 in eello5 before loop"
8550 c                do iii=1,nres
8551 c                  write (iout,'(i5,3f10.5)')
8552 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8553 c                enddo
8554       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8555 c        write (iout,*) "corr loop i",i
8556         i1=i+1
8557         num_conti=num_cont_hb(i)
8558         num_conti1=num_cont_hb(i+1)
8559         do jj=1,num_conti
8560           j=jcont_hb(jj,i)
8561           jp=iabs(j)
8562           do kk=1,num_conti1
8563             j1=jcont_hb(kk,i1)
8564             jp1=iabs(j1)
8565 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8566 c     &         ' jj=',jj,' kk=',kk
8567 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8568             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8569      &          .or. j.lt.0 .and. j1.gt.0) .and.
8570      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8571 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8572 C The system gains extra energy.
8573               n_corr=n_corr+1
8574               sqd1=dsqrt(d_cont(jj,i))
8575               sqd2=dsqrt(d_cont(kk,i1))
8576               sred_geom = sqd1*sqd2
8577               IF (sred_geom.lt.cutoff_corr) THEN
8578                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8579      &            ekont,fprimcont)
8580 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8581 cd     &         ' jj=',jj,' kk=',kk
8582                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8583                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8584                 do l=1,3
8585                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8586                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8587                 enddo
8588                 n_corr1=n_corr1+1
8589 cd               write (iout,*) 'sred_geom=',sred_geom,
8590 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8591 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8592 cd               write (iout,*) "g_contij",g_contij
8593 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8594 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8595                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8596                 if (wcorr4.gt.0.0d0)
8597      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8598 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8599                   if (energy_dec.and.wcorr4.gt.0.0d0)
8600      1                 write (iout,'(a6,4i5,0pf7.3)')
8601      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8602 c                write (iout,*) "gradcorr5 before eello5"
8603 c                do iii=1,nres
8604 c                  write (iout,'(i5,3f10.5)')
8605 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8606 c                enddo
8607                 if (wcorr5.gt.0.0d0)
8608      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8609 c                write (iout,*) "gradcorr5 after eello5"
8610 c                do iii=1,nres
8611 c                  write (iout,'(i5,3f10.5)')
8612 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8613 c                enddo
8614                   if (energy_dec.and.wcorr5.gt.0.0d0)
8615      1                 write (iout,'(a6,4i5,0pf7.3)')
8616      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8617 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8618 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8619                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8620      &               .or. wturn6.eq.0.0d0))then
8621 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8622                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8623                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8624      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8625 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8626 cd     &            'ecorr6=',ecorr6
8627 cd                write (iout,'(4e15.5)') sred_geom,
8628 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8629 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8630 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8631                 else if (wturn6.gt.0.0d0
8632      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8633 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8634                   eturn6=eturn6+eello_turn6(i,jj,kk)
8635                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8636      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8637 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8638                 endif
8639               ENDIF
8640 1111          continue
8641             endif
8642           enddo ! kk
8643         enddo ! jj
8644       enddo ! i
8645       do i=1,nres
8646         num_cont_hb(i)=num_cont_hb_old(i)
8647       enddo
8648 c                write (iout,*) "gradcorr5 in eello5"
8649 c                do iii=1,nres
8650 c                  write (iout,'(i5,3f10.5)')
8651 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8652 c                enddo
8653       return
8654       end
8655 c------------------------------------------------------------------------------
8656       subroutine add_hb_contact_eello(ii,jj,itask)
8657       implicit real*8 (a-h,o-z)
8658       include "DIMENSIONS"
8659       include "COMMON.IOUNITS"
8660       integer max_cont
8661       integer max_dim
8662       parameter (max_cont=maxconts)
8663       parameter (max_dim=70)
8664       include "COMMON.CONTACTS"
8665       double precision zapas(max_dim,maxconts,max_fg_procs),
8666      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8667       common /przechowalnia/ zapas
8668       integer i,j,ii,jj,iproc,itask(4),nn
8669 c      write (iout,*) "itask",itask
8670       do i=1,2
8671         iproc=itask(i)
8672         if (iproc.gt.0) then
8673           do j=1,num_cont_hb(ii)
8674             jjc=jcont_hb(j,ii)
8675 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8676             if (jjc.eq.jj) then
8677               ncont_sent(iproc)=ncont_sent(iproc)+1
8678               nn=ncont_sent(iproc)
8679               zapas(1,nn,iproc)=ii
8680               zapas(2,nn,iproc)=jjc
8681               zapas(3,nn,iproc)=d_cont(j,ii)
8682               ind=3
8683               do kk=1,3
8684                 ind=ind+1
8685                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8686               enddo
8687               do kk=1,2
8688                 do ll=1,2
8689                   ind=ind+1
8690                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8691                 enddo
8692               enddo
8693               do jj=1,5
8694                 do kk=1,3
8695                   do ll=1,2
8696                     do mm=1,2
8697                       ind=ind+1
8698                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8699                     enddo
8700                   enddo
8701                 enddo
8702               enddo
8703               exit
8704             endif
8705           enddo
8706         endif
8707       enddo
8708       return
8709       end
8710 c------------------------------------------------------------------------------
8711       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8712       implicit real*8 (a-h,o-z)
8713       include 'DIMENSIONS'
8714       include 'COMMON.IOUNITS'
8715       include 'COMMON.DERIV'
8716       include 'COMMON.INTERACT'
8717       include 'COMMON.CONTACTS'
8718       include 'COMMON.SHIELD'
8719       include 'COMMON.CONTROL'
8720       double precision gx(3),gx1(3)
8721       logical lprn
8722       lprn=.false.
8723 C      print *,"wchodze",fac_shield(i),shield_mode
8724       eij=facont_hb(jj,i)
8725       ekl=facont_hb(kk,k)
8726       ees0pij=ees0p(jj,i)
8727       ees0pkl=ees0p(kk,k)
8728       ees0mij=ees0m(jj,i)
8729       ees0mkl=ees0m(kk,k)
8730       ekont=eij*ekl
8731       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8732 C*
8733 C     & fac_shield(i)**2*fac_shield(j)**2
8734 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8735 C Following 4 lines for diagnostics.
8736 cd    ees0pkl=0.0D0
8737 cd    ees0pij=1.0D0
8738 cd    ees0mkl=0.0D0
8739 cd    ees0mij=1.0D0
8740 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8741 c     & 'Contacts ',i,j,
8742 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8743 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8744 c     & 'gradcorr_long'
8745 C Calculate the multi-body contribution to energy.
8746 C      ecorr=ecorr+ekont*ees
8747 C Calculate multi-body contributions to the gradient.
8748       coeffpees0pij=coeffp*ees0pij
8749       coeffmees0mij=coeffm*ees0mij
8750       coeffpees0pkl=coeffp*ees0pkl
8751       coeffmees0mkl=coeffm*ees0mkl
8752       do ll=1,3
8753 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8754         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8755      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8756      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8757         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8758      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8759      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8760 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8761         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8762      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8763      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8764         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8765      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8766      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8767         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8768      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8769      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8770         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8771         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8772         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8773      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8774      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8775         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8776         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8777 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8778       enddo
8779 c      write (iout,*)
8780 cgrad      do m=i+1,j-1
8781 cgrad        do ll=1,3
8782 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8783 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8784 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8785 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8786 cgrad        enddo
8787 cgrad      enddo
8788 cgrad      do m=k+1,l-1
8789 cgrad        do ll=1,3
8790 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8791 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8792 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8793 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8794 cgrad        enddo
8795 cgrad      enddo
8796 c      write (iout,*) "ehbcorr",ekont*ees
8797 C      print *,ekont,ees,i,k
8798       ehbcorr=ekont*ees
8799 C now gradient over shielding
8800 C      return
8801       if (shield_mode.gt.0) then
8802        j=ees0plist(jj,i)
8803        l=ees0plist(kk,k)
8804 C        print *,i,j,fac_shield(i),fac_shield(j),
8805 C     &fac_shield(k),fac_shield(l)
8806         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8807      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8808           do ilist=1,ishield_list(i)
8809            iresshield=shield_list(ilist,i)
8810            do m=1,3
8811            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8812 C     &      *2.0
8813            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8814      &              rlocshield
8815      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8816             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8817      &+rlocshield
8818            enddo
8819           enddo
8820           do ilist=1,ishield_list(j)
8821            iresshield=shield_list(ilist,j)
8822            do m=1,3
8823            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8824 C     &     *2.0
8825            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8826      &              rlocshield
8827      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8828            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8829      &     +rlocshield
8830            enddo
8831           enddo
8832
8833           do ilist=1,ishield_list(k)
8834            iresshield=shield_list(ilist,k)
8835            do m=1,3
8836            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8837 C     &     *2.0
8838            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8839      &              rlocshield
8840      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8841            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8842      &     +rlocshield
8843            enddo
8844           enddo
8845           do ilist=1,ishield_list(l)
8846            iresshield=shield_list(ilist,l)
8847            do m=1,3
8848            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8849 C     &     *2.0
8850            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8851      &              rlocshield
8852      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8853            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8854      &     +rlocshield
8855            enddo
8856           enddo
8857 C          print *,gshieldx(m,iresshield)
8858           do m=1,3
8859             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8860      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8861             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8862      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8863             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8864      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8865             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8866      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8867
8868             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8869      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8870             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8871      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8872             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8873      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8874             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8875      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8876
8877            enddo
8878       endif
8879       endif
8880       return
8881       end
8882 #ifdef MOMENT
8883 C---------------------------------------------------------------------------
8884       subroutine dipole(i,j,jj)
8885       implicit real*8 (a-h,o-z)
8886       include 'DIMENSIONS'
8887       include 'COMMON.IOUNITS'
8888       include 'COMMON.CHAIN'
8889       include 'COMMON.FFIELD'
8890       include 'COMMON.DERIV'
8891       include 'COMMON.INTERACT'
8892       include 'COMMON.CONTACTS'
8893       include 'COMMON.TORSION'
8894       include 'COMMON.VAR'
8895       include 'COMMON.GEO'
8896       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8897      &  auxmat(2,2)
8898       iti1 = itortyp(itype(i+1))
8899       if (j.lt.nres-1) then
8900         itj1 = itype2loc(itype(j+1))
8901       else
8902         itj1=nloctyp
8903       endif
8904       do iii=1,2
8905         dipi(iii,1)=Ub2(iii,i)
8906         dipderi(iii)=Ub2der(iii,i)
8907         dipi(iii,2)=b1(iii,i+1)
8908         dipj(iii,1)=Ub2(iii,j)
8909         dipderj(iii)=Ub2der(iii,j)
8910         dipj(iii,2)=b1(iii,j+1)
8911       enddo
8912       kkk=0
8913       do iii=1,2
8914         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8915         do jjj=1,2
8916           kkk=kkk+1
8917           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8918         enddo
8919       enddo
8920       do kkk=1,5
8921         do lll=1,3
8922           mmm=0
8923           do iii=1,2
8924             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8925      &        auxvec(1))
8926             do jjj=1,2
8927               mmm=mmm+1
8928               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8929             enddo
8930           enddo
8931         enddo
8932       enddo
8933       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8934       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8935       do iii=1,2
8936         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8937       enddo
8938       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8939       do iii=1,2
8940         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8941       enddo
8942       return
8943       end
8944 #endif
8945 C---------------------------------------------------------------------------
8946       subroutine calc_eello(i,j,k,l,jj,kk)
8947 C
8948 C This subroutine computes matrices and vectors needed to calculate
8949 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8950 C
8951       implicit real*8 (a-h,o-z)
8952       include 'DIMENSIONS'
8953       include 'COMMON.IOUNITS'
8954       include 'COMMON.CHAIN'
8955       include 'COMMON.DERIV'
8956       include 'COMMON.INTERACT'
8957       include 'COMMON.CONTACTS'
8958       include 'COMMON.TORSION'
8959       include 'COMMON.VAR'
8960       include 'COMMON.GEO'
8961       include 'COMMON.FFIELD'
8962       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8963      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8964       logical lprn
8965       common /kutas/ lprn
8966 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8967 cd     & ' jj=',jj,' kk=',kk
8968 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8969 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8970 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8971       do iii=1,2
8972         do jjj=1,2
8973           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8974           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8975         enddo
8976       enddo
8977       call transpose2(aa1(1,1),aa1t(1,1))
8978       call transpose2(aa2(1,1),aa2t(1,1))
8979       do kkk=1,5
8980         do lll=1,3
8981           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8982      &      aa1tder(1,1,lll,kkk))
8983           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8984      &      aa2tder(1,1,lll,kkk))
8985         enddo
8986       enddo
8987       if (l.eq.j+1) then
8988 C parallel orientation of the two CA-CA-CA frames.
8989         if (i.gt.1) then
8990           iti=itype2loc(itype(i))
8991         else
8992           iti=nloctyp
8993         endif
8994         itk1=itype2loc(itype(k+1))
8995         itj=itype2loc(itype(j))
8996         if (l.lt.nres-1) then
8997           itl1=itype2loc(itype(l+1))
8998         else
8999           itl1=nloctyp
9000         endif
9001 C A1 kernel(j+1) A2T
9002 cd        do iii=1,2
9003 cd          write (iout,'(3f10.5,5x,3f10.5)')
9004 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9005 cd        enddo
9006         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9007      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9008      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9009 C Following matrices are needed only for 6-th order cumulants
9010         IF (wcorr6.gt.0.0d0) THEN
9011         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9012      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9013      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9014         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9015      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9016      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9017      &   ADtEAderx(1,1,1,1,1,1))
9018         lprn=.false.
9019         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9020      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9021      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9022      &   ADtEA1derx(1,1,1,1,1,1))
9023         ENDIF
9024 C End 6-th order cumulants
9025 cd        lprn=.false.
9026 cd        if (lprn) then
9027 cd        write (2,*) 'In calc_eello6'
9028 cd        do iii=1,2
9029 cd          write (2,*) 'iii=',iii
9030 cd          do kkk=1,5
9031 cd            write (2,*) 'kkk=',kkk
9032 cd            do jjj=1,2
9033 cd              write (2,'(3(2f10.5),5x)')
9034 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9035 cd            enddo
9036 cd          enddo
9037 cd        enddo
9038 cd        endif
9039         call transpose2(EUgder(1,1,k),auxmat(1,1))
9040         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9041         call transpose2(EUg(1,1,k),auxmat(1,1))
9042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9043         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9044         do iii=1,2
9045           do kkk=1,5
9046             do lll=1,3
9047               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9048      &          EAEAderx(1,1,lll,kkk,iii,1))
9049             enddo
9050           enddo
9051         enddo
9052 C A1T kernel(i+1) A2
9053         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9054      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9055      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9056 C Following matrices are needed only for 6-th order cumulants
9057         IF (wcorr6.gt.0.0d0) THEN
9058         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9059      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9060      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9061         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9062      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9063      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9064      &   ADtEAderx(1,1,1,1,1,2))
9065         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9066      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9067      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9068      &   ADtEA1derx(1,1,1,1,1,2))
9069         ENDIF
9070 C End 6-th order cumulants
9071         call transpose2(EUgder(1,1,l),auxmat(1,1))
9072         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9073         call transpose2(EUg(1,1,l),auxmat(1,1))
9074         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9075         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9076         do iii=1,2
9077           do kkk=1,5
9078             do lll=1,3
9079               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9080      &          EAEAderx(1,1,lll,kkk,iii,2))
9081             enddo
9082           enddo
9083         enddo
9084 C AEAb1 and AEAb2
9085 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9086 C They are needed only when the fifth- or the sixth-order cumulants are
9087 C indluded.
9088         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9089         call transpose2(AEA(1,1,1),auxmat(1,1))
9090         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9091         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9092         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9093         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9094         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9095         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9096         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9097         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9098         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9099         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9100         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9101         call transpose2(AEA(1,1,2),auxmat(1,1))
9102         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9103         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9104         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9105         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9106         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9107         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9108         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9109         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9110         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9111         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9112         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9113 C Calculate the Cartesian derivatives of the vectors.
9114         do iii=1,2
9115           do kkk=1,5
9116             do lll=1,3
9117               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9118               call matvec2(auxmat(1,1),b1(1,i),
9119      &          AEAb1derx(1,lll,kkk,iii,1,1))
9120               call matvec2(auxmat(1,1),Ub2(1,i),
9121      &          AEAb2derx(1,lll,kkk,iii,1,1))
9122               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9123      &          AEAb1derx(1,lll,kkk,iii,2,1))
9124               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9125      &          AEAb2derx(1,lll,kkk,iii,2,1))
9126               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9127               call matvec2(auxmat(1,1),b1(1,j),
9128      &          AEAb1derx(1,lll,kkk,iii,1,2))
9129               call matvec2(auxmat(1,1),Ub2(1,j),
9130      &          AEAb2derx(1,lll,kkk,iii,1,2))
9131               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9132      &          AEAb1derx(1,lll,kkk,iii,2,2))
9133               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9134      &          AEAb2derx(1,lll,kkk,iii,2,2))
9135             enddo
9136           enddo
9137         enddo
9138         ENDIF
9139 C End vectors
9140       else
9141 C Antiparallel orientation of the two CA-CA-CA frames.
9142         if (i.gt.1) then
9143           iti=itype2loc(itype(i))
9144         else
9145           iti=nloctyp
9146         endif
9147         itk1=itype2loc(itype(k+1))
9148         itl=itype2loc(itype(l))
9149         itj=itype2loc(itype(j))
9150         if (j.lt.nres-1) then
9151           itj1=itype2loc(itype(j+1))
9152         else
9153           itj1=nloctyp
9154         endif
9155 C A2 kernel(j-1)T A1T
9156         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9157      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9158      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9159 C Following matrices are needed only for 6-th order cumulants
9160         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9161      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9162         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9163      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9164      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9165         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9166      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9167      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9168      &   ADtEAderx(1,1,1,1,1,1))
9169         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9170      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9171      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9172      &   ADtEA1derx(1,1,1,1,1,1))
9173         ENDIF
9174 C End 6-th order cumulants
9175         call transpose2(EUgder(1,1,k),auxmat(1,1))
9176         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9177         call transpose2(EUg(1,1,k),auxmat(1,1))
9178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9179         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9180         do iii=1,2
9181           do kkk=1,5
9182             do lll=1,3
9183               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9184      &          EAEAderx(1,1,lll,kkk,iii,1))
9185             enddo
9186           enddo
9187         enddo
9188 C A2T kernel(i+1)T A1
9189         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9190      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9191      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9192 C Following matrices are needed only for 6-th order cumulants
9193         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9194      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9195         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9196      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9197      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9198         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9199      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9200      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9201      &   ADtEAderx(1,1,1,1,1,2))
9202         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9203      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9204      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9205      &   ADtEA1derx(1,1,1,1,1,2))
9206         ENDIF
9207 C End 6-th order cumulants
9208         call transpose2(EUgder(1,1,j),auxmat(1,1))
9209         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9210         call transpose2(EUg(1,1,j),auxmat(1,1))
9211         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9212         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9213         do iii=1,2
9214           do kkk=1,5
9215             do lll=1,3
9216               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9217      &          EAEAderx(1,1,lll,kkk,iii,2))
9218             enddo
9219           enddo
9220         enddo
9221 C AEAb1 and AEAb2
9222 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9223 C They are needed only when the fifth- or the sixth-order cumulants are
9224 C indluded.
9225         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9226      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9227         call transpose2(AEA(1,1,1),auxmat(1,1))
9228         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9229         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9230         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9231         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9232         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9233         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9234         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9235         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9236         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9237         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9238         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9239         call transpose2(AEA(1,1,2),auxmat(1,1))
9240         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9241         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9242         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9243         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9244         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9245         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9246         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9247         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9248         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9249         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9250         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9251 C Calculate the Cartesian derivatives of the vectors.
9252         do iii=1,2
9253           do kkk=1,5
9254             do lll=1,3
9255               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9256               call matvec2(auxmat(1,1),b1(1,i),
9257      &          AEAb1derx(1,lll,kkk,iii,1,1))
9258               call matvec2(auxmat(1,1),Ub2(1,i),
9259      &          AEAb2derx(1,lll,kkk,iii,1,1))
9260               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9261      &          AEAb1derx(1,lll,kkk,iii,2,1))
9262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9263      &          AEAb2derx(1,lll,kkk,iii,2,1))
9264               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9265               call matvec2(auxmat(1,1),b1(1,l),
9266      &          AEAb1derx(1,lll,kkk,iii,1,2))
9267               call matvec2(auxmat(1,1),Ub2(1,l),
9268      &          AEAb2derx(1,lll,kkk,iii,1,2))
9269               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9270      &          AEAb1derx(1,lll,kkk,iii,2,2))
9271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9272      &          AEAb2derx(1,lll,kkk,iii,2,2))
9273             enddo
9274           enddo
9275         enddo
9276         ENDIF
9277 C End vectors
9278       endif
9279       return
9280       end
9281 C---------------------------------------------------------------------------
9282       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9283      &  KK,KKderg,AKA,AKAderg,AKAderx)
9284       implicit none
9285       integer nderg
9286       logical transp
9287       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9288      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9289      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9290       integer iii,kkk,lll
9291       integer jjj,mmm
9292       logical lprn
9293       common /kutas/ lprn
9294       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9295       do iii=1,nderg
9296         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9297      &    AKAderg(1,1,iii))
9298       enddo
9299 cd      if (lprn) write (2,*) 'In kernel'
9300       do kkk=1,5
9301 cd        if (lprn) write (2,*) 'kkk=',kkk
9302         do lll=1,3
9303           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9304      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9305 cd          if (lprn) then
9306 cd            write (2,*) 'lll=',lll
9307 cd            write (2,*) 'iii=1'
9308 cd            do jjj=1,2
9309 cd              write (2,'(3(2f10.5),5x)')
9310 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9311 cd            enddo
9312 cd          endif
9313           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9314      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9315 cd          if (lprn) then
9316 cd            write (2,*) 'lll=',lll
9317 cd            write (2,*) 'iii=2'
9318 cd            do jjj=1,2
9319 cd              write (2,'(3(2f10.5),5x)')
9320 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9321 cd            enddo
9322 cd          endif
9323         enddo
9324       enddo
9325       return
9326       end
9327 C---------------------------------------------------------------------------
9328       double precision function eello4(i,j,k,l,jj,kk)
9329       implicit real*8 (a-h,o-z)
9330       include 'DIMENSIONS'
9331       include 'COMMON.IOUNITS'
9332       include 'COMMON.CHAIN'
9333       include 'COMMON.DERIV'
9334       include 'COMMON.INTERACT'
9335       include 'COMMON.CONTACTS'
9336       include 'COMMON.TORSION'
9337       include 'COMMON.VAR'
9338       include 'COMMON.GEO'
9339       double precision pizda(2,2),ggg1(3),ggg2(3)
9340 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9341 cd        eello4=0.0d0
9342 cd        return
9343 cd      endif
9344 cd      print *,'eello4:',i,j,k,l,jj,kk
9345 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9346 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9347 cold      eij=facont_hb(jj,i)
9348 cold      ekl=facont_hb(kk,k)
9349 cold      ekont=eij*ekl
9350       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9351 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9352       gcorr_loc(k-1)=gcorr_loc(k-1)
9353      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9354       if (l.eq.j+1) then
9355         gcorr_loc(l-1)=gcorr_loc(l-1)
9356      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9357       else
9358         gcorr_loc(j-1)=gcorr_loc(j-1)
9359      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9360       endif
9361       do iii=1,2
9362         do kkk=1,5
9363           do lll=1,3
9364             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9365      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9366 cd            derx(lll,kkk,iii)=0.0d0
9367           enddo
9368         enddo
9369       enddo
9370 cd      gcorr_loc(l-1)=0.0d0
9371 cd      gcorr_loc(j-1)=0.0d0
9372 cd      gcorr_loc(k-1)=0.0d0
9373 cd      eel4=1.0d0
9374 cd      write (iout,*)'Contacts have occurred for peptide groups',
9375 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9376 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9377       if (j.lt.nres-1) then
9378         j1=j+1
9379         j2=j-1
9380       else
9381         j1=j-1
9382         j2=j-2
9383       endif
9384       if (l.lt.nres-1) then
9385         l1=l+1
9386         l2=l-1
9387       else
9388         l1=l-1
9389         l2=l-2
9390       endif
9391       do ll=1,3
9392 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9393 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9394         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9395         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9396 cgrad        ghalf=0.5d0*ggg1(ll)
9397         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9398         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9399         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9400         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9401         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9402         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9403 cgrad        ghalf=0.5d0*ggg2(ll)
9404         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9405         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9406         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9407         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9408         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9409         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9410       enddo
9411 cgrad      do m=i+1,j-1
9412 cgrad        do ll=1,3
9413 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9414 cgrad        enddo
9415 cgrad      enddo
9416 cgrad      do m=k+1,l-1
9417 cgrad        do ll=1,3
9418 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9419 cgrad        enddo
9420 cgrad      enddo
9421 cgrad      do m=i+2,j2
9422 cgrad        do ll=1,3
9423 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9424 cgrad        enddo
9425 cgrad      enddo
9426 cgrad      do m=k+2,l2
9427 cgrad        do ll=1,3
9428 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9429 cgrad        enddo
9430 cgrad      enddo
9431 cd      do iii=1,nres-3
9432 cd        write (2,*) iii,gcorr_loc(iii)
9433 cd      enddo
9434       eello4=ekont*eel4
9435 cd      write (2,*) 'ekont',ekont
9436 cd      write (iout,*) 'eello4',ekont*eel4
9437       return
9438       end
9439 C---------------------------------------------------------------------------
9440       double precision function eello5(i,j,k,l,jj,kk)
9441       implicit real*8 (a-h,o-z)
9442       include 'DIMENSIONS'
9443       include 'COMMON.IOUNITS'
9444       include 'COMMON.CHAIN'
9445       include 'COMMON.DERIV'
9446       include 'COMMON.INTERACT'
9447       include 'COMMON.CONTACTS'
9448       include 'COMMON.TORSION'
9449       include 'COMMON.VAR'
9450       include 'COMMON.GEO'
9451       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9452       double precision ggg1(3),ggg2(3)
9453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9454 C                                                                              C
9455 C                            Parallel chains                                   C
9456 C                                                                              C
9457 C          o             o                   o             o                   C
9458 C         /l\           / \             \   / \           / \   /              C
9459 C        /   \         /   \             \ /   \         /   \ /               C
9460 C       j| o |l1       | o |              o| o |         | o |o                C
9461 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9462 C      \i/   \         /   \ /             /   \         /   \                 C
9463 C       o    k1             o                                                  C
9464 C         (I)          (II)                (III)          (IV)                 C
9465 C                                                                              C
9466 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9467 C                                                                              C
9468 C                            Antiparallel chains                               C
9469 C                                                                              C
9470 C          o             o                   o             o                   C
9471 C         /j\           / \             \   / \           / \   /              C
9472 C        /   \         /   \             \ /   \         /   \ /               C
9473 C      j1| o |l        | o |              o| o |         | o |o                C
9474 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9475 C      \i/   \         /   \ /             /   \         /   \                 C
9476 C       o     k1            o                                                  C
9477 C         (I)          (II)                (III)          (IV)                 C
9478 C                                                                              C
9479 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9480 C                                                                              C
9481 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9482 C                                                                              C
9483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9484 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9485 cd        eello5=0.0d0
9486 cd        return
9487 cd      endif
9488 cd      write (iout,*)
9489 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9490 cd     &   ' and',k,l
9491       itk=itype2loc(itype(k))
9492       itl=itype2loc(itype(l))
9493       itj=itype2loc(itype(j))
9494       eello5_1=0.0d0
9495       eello5_2=0.0d0
9496       eello5_3=0.0d0
9497       eello5_4=0.0d0
9498 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9499 cd     &   eel5_3_num,eel5_4_num)
9500       do iii=1,2
9501         do kkk=1,5
9502           do lll=1,3
9503             derx(lll,kkk,iii)=0.0d0
9504           enddo
9505         enddo
9506       enddo
9507 cd      eij=facont_hb(jj,i)
9508 cd      ekl=facont_hb(kk,k)
9509 cd      ekont=eij*ekl
9510 cd      write (iout,*)'Contacts have occurred for peptide groups',
9511 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9512 cd      goto 1111
9513 C Contribution from the graph I.
9514 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9515 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9516       call transpose2(EUg(1,1,k),auxmat(1,1))
9517       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9518       vv(1)=pizda(1,1)-pizda(2,2)
9519       vv(2)=pizda(1,2)+pizda(2,1)
9520       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9521      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9522 C Explicit gradient in virtual-dihedral angles.
9523       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9524      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9525      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9526       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9527       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9528       vv(1)=pizda(1,1)-pizda(2,2)
9529       vv(2)=pizda(1,2)+pizda(2,1)
9530       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9531      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9532      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9533       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9534       vv(1)=pizda(1,1)-pizda(2,2)
9535       vv(2)=pizda(1,2)+pizda(2,1)
9536       if (l.eq.j+1) then
9537         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9538      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9539      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9540       else
9541         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9542      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9544       endif
9545 C Cartesian gradient
9546       do iii=1,2
9547         do kkk=1,5
9548           do lll=1,3
9549             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9550      &        pizda(1,1))
9551             vv(1)=pizda(1,1)-pizda(2,2)
9552             vv(2)=pizda(1,2)+pizda(2,1)
9553             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9554      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9555      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9556           enddo
9557         enddo
9558       enddo
9559 c      goto 1112
9560 c1111  continue
9561 C Contribution from graph II
9562       call transpose2(EE(1,1,k),auxmat(1,1))
9563       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9564       vv(1)=pizda(1,1)+pizda(2,2)
9565       vv(2)=pizda(2,1)-pizda(1,2)
9566       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9567      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9568 C Explicit gradient in virtual-dihedral angles.
9569       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9570      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9571       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9572       vv(1)=pizda(1,1)+pizda(2,2)
9573       vv(2)=pizda(2,1)-pizda(1,2)
9574       if (l.eq.j+1) then
9575         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9576      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9577      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9578       else
9579         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9580      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9581      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9582       endif
9583 C Cartesian gradient
9584       do iii=1,2
9585         do kkk=1,5
9586           do lll=1,3
9587             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9588      &        pizda(1,1))
9589             vv(1)=pizda(1,1)+pizda(2,2)
9590             vv(2)=pizda(2,1)-pizda(1,2)
9591             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9592      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9593      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9594           enddo
9595         enddo
9596       enddo
9597 cd      goto 1112
9598 cd1111  continue
9599       if (l.eq.j+1) then
9600 cd        goto 1110
9601 C Parallel orientation
9602 C Contribution from graph III
9603         call transpose2(EUg(1,1,l),auxmat(1,1))
9604         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9605         vv(1)=pizda(1,1)-pizda(2,2)
9606         vv(2)=pizda(1,2)+pizda(2,1)
9607         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9608      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9609 C Explicit gradient in virtual-dihedral angles.
9610         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9611      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9612      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9613         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9614         vv(1)=pizda(1,1)-pizda(2,2)
9615         vv(2)=pizda(1,2)+pizda(2,1)
9616         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9617      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9618      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9619         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9620         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9621         vv(1)=pizda(1,1)-pizda(2,2)
9622         vv(2)=pizda(1,2)+pizda(2,1)
9623         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9624      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9625      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9626 C Cartesian gradient
9627         do iii=1,2
9628           do kkk=1,5
9629             do lll=1,3
9630               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9631      &          pizda(1,1))
9632               vv(1)=pizda(1,1)-pizda(2,2)
9633               vv(2)=pizda(1,2)+pizda(2,1)
9634               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9635      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9636      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9637             enddo
9638           enddo
9639         enddo
9640 cd        goto 1112
9641 C Contribution from graph IV
9642 cd1110    continue
9643         call transpose2(EE(1,1,l),auxmat(1,1))
9644         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9645         vv(1)=pizda(1,1)+pizda(2,2)
9646         vv(2)=pizda(2,1)-pizda(1,2)
9647         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9648      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9649 C Explicit gradient in virtual-dihedral angles.
9650         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9651      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9652         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9653         vv(1)=pizda(1,1)+pizda(2,2)
9654         vv(2)=pizda(2,1)-pizda(1,2)
9655         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9656      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9657      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9658 C Cartesian gradient
9659         do iii=1,2
9660           do kkk=1,5
9661             do lll=1,3
9662               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9663      &          pizda(1,1))
9664               vv(1)=pizda(1,1)+pizda(2,2)
9665               vv(2)=pizda(2,1)-pizda(1,2)
9666               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9667      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9668      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9669             enddo
9670           enddo
9671         enddo
9672       else
9673 C Antiparallel orientation
9674 C Contribution from graph III
9675 c        goto 1110
9676         call transpose2(EUg(1,1,j),auxmat(1,1))
9677         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9678         vv(1)=pizda(1,1)-pizda(2,2)
9679         vv(2)=pizda(1,2)+pizda(2,1)
9680         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9682 C Explicit gradient in virtual-dihedral angles.
9683         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9684      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9685      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9686         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9687         vv(1)=pizda(1,1)-pizda(2,2)
9688         vv(2)=pizda(1,2)+pizda(2,1)
9689         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9690      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9692         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9693         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9694         vv(1)=pizda(1,1)-pizda(2,2)
9695         vv(2)=pizda(1,2)+pizda(2,1)
9696         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9697      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9698      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9699 C Cartesian gradient
9700         do iii=1,2
9701           do kkk=1,5
9702             do lll=1,3
9703               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9704      &          pizda(1,1))
9705               vv(1)=pizda(1,1)-pizda(2,2)
9706               vv(2)=pizda(1,2)+pizda(2,1)
9707               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9708      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9709      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9710             enddo
9711           enddo
9712         enddo
9713 cd        goto 1112
9714 C Contribution from graph IV
9715 1110    continue
9716         call transpose2(EE(1,1,j),auxmat(1,1))
9717         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9718         vv(1)=pizda(1,1)+pizda(2,2)
9719         vv(2)=pizda(2,1)-pizda(1,2)
9720         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9721      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9722 C Explicit gradient in virtual-dihedral angles.
9723         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9724      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9725         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9726         vv(1)=pizda(1,1)+pizda(2,2)
9727         vv(2)=pizda(2,1)-pizda(1,2)
9728         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9729      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9730      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9731 C Cartesian gradient
9732         do iii=1,2
9733           do kkk=1,5
9734             do lll=1,3
9735               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9736      &          pizda(1,1))
9737               vv(1)=pizda(1,1)+pizda(2,2)
9738               vv(2)=pizda(2,1)-pizda(1,2)
9739               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9740      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9741      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9742             enddo
9743           enddo
9744         enddo
9745       endif
9746 1112  continue
9747       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9748 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9749 cd        write (2,*) 'ijkl',i,j,k,l
9750 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9751 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9752 cd      endif
9753 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9754 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9755 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9756 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9757       if (j.lt.nres-1) then
9758         j1=j+1
9759         j2=j-1
9760       else
9761         j1=j-1
9762         j2=j-2
9763       endif
9764       if (l.lt.nres-1) then
9765         l1=l+1
9766         l2=l-1
9767       else
9768         l1=l-1
9769         l2=l-2
9770       endif
9771 cd      eij=1.0d0
9772 cd      ekl=1.0d0
9773 cd      ekont=1.0d0
9774 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9775 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9776 C        summed up outside the subrouine as for the other subroutines
9777 C        handling long-range interactions. The old code is commented out
9778 C        with "cgrad" to keep track of changes.
9779       do ll=1,3
9780 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9781 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9782         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9783         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9784 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9785 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9786 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9787 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9788 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9789 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9790 c     &   gradcorr5ij,
9791 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9792 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9793 cgrad        ghalf=0.5d0*ggg1(ll)
9794 cd        ghalf=0.0d0
9795         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9796         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9797         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9798         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9799         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9800         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9801 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9802 cgrad        ghalf=0.5d0*ggg2(ll)
9803 cd        ghalf=0.0d0
9804         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9805         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9806         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9807         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9808         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9809         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9810       enddo
9811 cd      goto 1112
9812 cgrad      do m=i+1,j-1
9813 cgrad        do ll=1,3
9814 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9815 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9816 cgrad        enddo
9817 cgrad      enddo
9818 cgrad      do m=k+1,l-1
9819 cgrad        do ll=1,3
9820 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9821 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9822 cgrad        enddo
9823 cgrad      enddo
9824 c1112  continue
9825 cgrad      do m=i+2,j2
9826 cgrad        do ll=1,3
9827 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9828 cgrad        enddo
9829 cgrad      enddo
9830 cgrad      do m=k+2,l2
9831 cgrad        do ll=1,3
9832 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9833 cgrad        enddo
9834 cgrad      enddo
9835 cd      do iii=1,nres-3
9836 cd        write (2,*) iii,g_corr5_loc(iii)
9837 cd      enddo
9838       eello5=ekont*eel5
9839 cd      write (2,*) 'ekont',ekont
9840 cd      write (iout,*) 'eello5',ekont*eel5
9841       return
9842       end
9843 c--------------------------------------------------------------------------
9844       double precision function eello6(i,j,k,l,jj,kk)
9845       implicit real*8 (a-h,o-z)
9846       include 'DIMENSIONS'
9847       include 'COMMON.IOUNITS'
9848       include 'COMMON.CHAIN'
9849       include 'COMMON.DERIV'
9850       include 'COMMON.INTERACT'
9851       include 'COMMON.CONTACTS'
9852       include 'COMMON.TORSION'
9853       include 'COMMON.VAR'
9854       include 'COMMON.GEO'
9855       include 'COMMON.FFIELD'
9856       double precision ggg1(3),ggg2(3)
9857 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9858 cd        eello6=0.0d0
9859 cd        return
9860 cd      endif
9861 cd      write (iout,*)
9862 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9863 cd     &   ' and',k,l
9864       eello6_1=0.0d0
9865       eello6_2=0.0d0
9866       eello6_3=0.0d0
9867       eello6_4=0.0d0
9868       eello6_5=0.0d0
9869       eello6_6=0.0d0
9870 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9871 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9872       do iii=1,2
9873         do kkk=1,5
9874           do lll=1,3
9875             derx(lll,kkk,iii)=0.0d0
9876           enddo
9877         enddo
9878       enddo
9879 cd      eij=facont_hb(jj,i)
9880 cd      ekl=facont_hb(kk,k)
9881 cd      ekont=eij*ekl
9882 cd      eij=1.0d0
9883 cd      ekl=1.0d0
9884 cd      ekont=1.0d0
9885       if (l.eq.j+1) then
9886         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9887         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9888         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9889         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9890         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9891         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9892       else
9893         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9894         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9895         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9896         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9897         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9898           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9899         else
9900           eello6_5=0.0d0
9901         endif
9902         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9903       endif
9904 C If turn contributions are considered, they will be handled separately.
9905       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9906 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9907 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9908 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9909 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9910 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9911 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9912 cd      goto 1112
9913       if (j.lt.nres-1) then
9914         j1=j+1
9915         j2=j-1
9916       else
9917         j1=j-1
9918         j2=j-2
9919       endif
9920       if (l.lt.nres-1) then
9921         l1=l+1
9922         l2=l-1
9923       else
9924         l1=l-1
9925         l2=l-2
9926       endif
9927       do ll=1,3
9928 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9929 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9930 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9931 cgrad        ghalf=0.5d0*ggg1(ll)
9932 cd        ghalf=0.0d0
9933         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9934         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9935         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9936         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9937         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9938         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9939         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9940         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9941 cgrad        ghalf=0.5d0*ggg2(ll)
9942 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9943 cd        ghalf=0.0d0
9944         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9945         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9946         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9947         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9948         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9949         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9950       enddo
9951 cd      goto 1112
9952 cgrad      do m=i+1,j-1
9953 cgrad        do ll=1,3
9954 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9955 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9956 cgrad        enddo
9957 cgrad      enddo
9958 cgrad      do m=k+1,l-1
9959 cgrad        do ll=1,3
9960 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9961 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9962 cgrad        enddo
9963 cgrad      enddo
9964 cgrad1112  continue
9965 cgrad      do m=i+2,j2
9966 cgrad        do ll=1,3
9967 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9968 cgrad        enddo
9969 cgrad      enddo
9970 cgrad      do m=k+2,l2
9971 cgrad        do ll=1,3
9972 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9973 cgrad        enddo
9974 cgrad      enddo
9975 cd      do iii=1,nres-3
9976 cd        write (2,*) iii,g_corr6_loc(iii)
9977 cd      enddo
9978       eello6=ekont*eel6
9979 cd      write (2,*) 'ekont',ekont
9980 cd      write (iout,*) 'eello6',ekont*eel6
9981       return
9982       end
9983 c--------------------------------------------------------------------------
9984       double precision function eello6_graph1(i,j,k,l,imat,swap)
9985       implicit real*8 (a-h,o-z)
9986       include 'DIMENSIONS'
9987       include 'COMMON.IOUNITS'
9988       include 'COMMON.CHAIN'
9989       include 'COMMON.DERIV'
9990       include 'COMMON.INTERACT'
9991       include 'COMMON.CONTACTS'
9992       include 'COMMON.TORSION'
9993       include 'COMMON.VAR'
9994       include 'COMMON.GEO'
9995       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9996       logical swap
9997       logical lprn
9998       common /kutas/ lprn
9999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10000 C                                                                              C
10001 C      Parallel       Antiparallel                                             C
10002 C                                                                              C
10003 C          o             o                                                     C
10004 C         /l\           /j\                                                    C
10005 C        /   \         /   \                                                   C
10006 C       /| o |         | o |\                                                  C
10007 C     \ j|/k\|  /   \  |/k\|l /                                                C
10008 C      \ /   \ /     \ /   \ /                                                 C
10009 C       o     o       o     o                                                  C
10010 C       i             i                                                        C
10011 C                                                                              C
10012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10013       itk=itype2loc(itype(k))
10014       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10015       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10016       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10017       call transpose2(EUgC(1,1,k),auxmat(1,1))
10018       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10019       vv1(1)=pizda1(1,1)-pizda1(2,2)
10020       vv1(2)=pizda1(1,2)+pizda1(2,1)
10021       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10022       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10023       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10024       s5=scalar2(vv(1),Dtobr2(1,i))
10025 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10026       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10027       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10028      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10029      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10030      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10031      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10032      & +scalar2(vv(1),Dtobr2der(1,i)))
10033       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10034       vv1(1)=pizda1(1,1)-pizda1(2,2)
10035       vv1(2)=pizda1(1,2)+pizda1(2,1)
10036       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10037       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10038       if (l.eq.j+1) then
10039         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10040      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10041      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10042      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10043      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10044       else
10045         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10046      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10047      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10048      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10049      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10050       endif
10051       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10052       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10053       vv1(1)=pizda1(1,1)-pizda1(2,2)
10054       vv1(2)=pizda1(1,2)+pizda1(2,1)
10055       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10056      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10057      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10058      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10059       do iii=1,2
10060         if (swap) then
10061           ind=3-iii
10062         else
10063           ind=iii
10064         endif
10065         do kkk=1,5
10066           do lll=1,3
10067             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10068             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10069             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10070             call transpose2(EUgC(1,1,k),auxmat(1,1))
10071             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10072      &        pizda1(1,1))
10073             vv1(1)=pizda1(1,1)-pizda1(2,2)
10074             vv1(2)=pizda1(1,2)+pizda1(2,1)
10075             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10076             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10077      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10078             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10079      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10080             s5=scalar2(vv(1),Dtobr2(1,i))
10081             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10082           enddo
10083         enddo
10084       enddo
10085       return
10086       end
10087 c----------------------------------------------------------------------------
10088       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10089       implicit real*8 (a-h,o-z)
10090       include 'DIMENSIONS'
10091       include 'COMMON.IOUNITS'
10092       include 'COMMON.CHAIN'
10093       include 'COMMON.DERIV'
10094       include 'COMMON.INTERACT'
10095       include 'COMMON.CONTACTS'
10096       include 'COMMON.TORSION'
10097       include 'COMMON.VAR'
10098       include 'COMMON.GEO'
10099       logical swap
10100       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10101      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10102       logical lprn
10103       common /kutas/ lprn
10104 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10105 C                                                                              C
10106 C      Parallel       Antiparallel                                             C
10107 C                                                                              C
10108 C          o             o                                                     C
10109 C     \   /l\           /j\   /                                                C
10110 C      \ /   \         /   \ /                                                 C
10111 C       o| o |         | o |o                                                  C
10112 C     \ j|/k\|      \  |/k\|l                                                  C
10113 C      \ /   \       \ /   \                                                   C
10114 C       o             o                                                        C
10115 C       i             i                                                        C
10116 C                                                                              C
10117 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10118 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10119 C AL 7/4/01 s1 would occur in the sixth-order moment,
10120 C           but not in a cluster cumulant
10121 #ifdef MOMENT
10122       s1=dip(1,jj,i)*dip(1,kk,k)
10123 #endif
10124       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10125       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10126       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10127       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10128       call transpose2(EUg(1,1,k),auxmat(1,1))
10129       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10130       vv(1)=pizda(1,1)-pizda(2,2)
10131       vv(2)=pizda(1,2)+pizda(2,1)
10132       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10133 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10134 #ifdef MOMENT
10135       eello6_graph2=-(s1+s2+s3+s4)
10136 #else
10137       eello6_graph2=-(s2+s3+s4)
10138 #endif
10139 c      eello6_graph2=-s3
10140 C Derivatives in gamma(i-1)
10141       if (i.gt.1) then
10142 #ifdef MOMENT
10143         s1=dipderg(1,jj,i)*dip(1,kk,k)
10144 #endif
10145         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10146         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10147         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10148         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10149 #ifdef MOMENT
10150         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10151 #else
10152         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10153 #endif
10154 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10155       endif
10156 C Derivatives in gamma(k-1)
10157 #ifdef MOMENT
10158       s1=dip(1,jj,i)*dipderg(1,kk,k)
10159 #endif
10160       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10161       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10162       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10163       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10164       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10165       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10166       vv(1)=pizda(1,1)-pizda(2,2)
10167       vv(2)=pizda(1,2)+pizda(2,1)
10168       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10169 #ifdef MOMENT
10170       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10171 #else
10172       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10173 #endif
10174 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10175 C Derivatives in gamma(j-1) or gamma(l-1)
10176       if (j.gt.1) then
10177 #ifdef MOMENT
10178         s1=dipderg(3,jj,i)*dip(1,kk,k)
10179 #endif
10180         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10181         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10182         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10183         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10184         vv(1)=pizda(1,1)-pizda(2,2)
10185         vv(2)=pizda(1,2)+pizda(2,1)
10186         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10187 #ifdef MOMENT
10188         if (swap) then
10189           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10190         else
10191           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10192         endif
10193 #endif
10194         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10195 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10196       endif
10197 C Derivatives in gamma(l-1) or gamma(j-1)
10198       if (l.gt.1) then
10199 #ifdef MOMENT
10200         s1=dip(1,jj,i)*dipderg(3,kk,k)
10201 #endif
10202         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10203         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10204         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10205         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10206         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10207         vv(1)=pizda(1,1)-pizda(2,2)
10208         vv(2)=pizda(1,2)+pizda(2,1)
10209         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10210 #ifdef MOMENT
10211         if (swap) then
10212           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10213         else
10214           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10215         endif
10216 #endif
10217         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10218 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10219       endif
10220 C Cartesian derivatives.
10221       if (lprn) then
10222         write (2,*) 'In eello6_graph2'
10223         do iii=1,2
10224           write (2,*) 'iii=',iii
10225           do kkk=1,5
10226             write (2,*) 'kkk=',kkk
10227             do jjj=1,2
10228               write (2,'(3(2f10.5),5x)')
10229      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10230             enddo
10231           enddo
10232         enddo
10233       endif
10234       do iii=1,2
10235         do kkk=1,5
10236           do lll=1,3
10237 #ifdef MOMENT
10238             if (iii.eq.1) then
10239               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10240             else
10241               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10242             endif
10243 #endif
10244             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10245      &        auxvec(1))
10246             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10247             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10248      &        auxvec(1))
10249             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10250             call transpose2(EUg(1,1,k),auxmat(1,1))
10251             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10252      &        pizda(1,1))
10253             vv(1)=pizda(1,1)-pizda(2,2)
10254             vv(2)=pizda(1,2)+pizda(2,1)
10255             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10256 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10257 #ifdef MOMENT
10258             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10259 #else
10260             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10261 #endif
10262             if (swap) then
10263               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10264             else
10265               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10266             endif
10267           enddo
10268         enddo
10269       enddo
10270       return
10271       end
10272 c----------------------------------------------------------------------------
10273       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10274       implicit real*8 (a-h,o-z)
10275       include 'DIMENSIONS'
10276       include 'COMMON.IOUNITS'
10277       include 'COMMON.CHAIN'
10278       include 'COMMON.DERIV'
10279       include 'COMMON.INTERACT'
10280       include 'COMMON.CONTACTS'
10281       include 'COMMON.TORSION'
10282       include 'COMMON.VAR'
10283       include 'COMMON.GEO'
10284       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10285       logical swap
10286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10287 C                                                                              C
10288 C      Parallel       Antiparallel                                             C
10289 C                                                                              C
10290 C          o             o                                                     C
10291 C         /l\   /   \   /j\                                                    C
10292 C        /   \ /     \ /   \                                                   C
10293 C       /| o |o       o| o |\                                                  C
10294 C       j|/k\|  /      |/k\|l /                                                C
10295 C        /   \ /       /   \ /                                                 C
10296 C       /     o       /     o                                                  C
10297 C       i             i                                                        C
10298 C                                                                              C
10299 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10300 C
10301 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10302 C           energy moment and not to the cluster cumulant.
10303       iti=itortyp(itype(i))
10304       if (j.lt.nres-1) then
10305         itj1=itype2loc(itype(j+1))
10306       else
10307         itj1=nloctyp
10308       endif
10309       itk=itype2loc(itype(k))
10310       itk1=itype2loc(itype(k+1))
10311       if (l.lt.nres-1) then
10312         itl1=itype2loc(itype(l+1))
10313       else
10314         itl1=nloctyp
10315       endif
10316 #ifdef MOMENT
10317       s1=dip(4,jj,i)*dip(4,kk,k)
10318 #endif
10319       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10320       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10321       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10322       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10323       call transpose2(EE(1,1,k),auxmat(1,1))
10324       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10325       vv(1)=pizda(1,1)+pizda(2,2)
10326       vv(2)=pizda(2,1)-pizda(1,2)
10327       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10328 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10329 cd     & "sum",-(s2+s3+s4)
10330 #ifdef MOMENT
10331       eello6_graph3=-(s1+s2+s3+s4)
10332 #else
10333       eello6_graph3=-(s2+s3+s4)
10334 #endif
10335 c      eello6_graph3=-s4
10336 C Derivatives in gamma(k-1)
10337       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10338       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10339       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10340       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10341 C Derivatives in gamma(l-1)
10342       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10343       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10344       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10345       vv(1)=pizda(1,1)+pizda(2,2)
10346       vv(2)=pizda(2,1)-pizda(1,2)
10347       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10348       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10349 C Cartesian derivatives.
10350       do iii=1,2
10351         do kkk=1,5
10352           do lll=1,3
10353 #ifdef MOMENT
10354             if (iii.eq.1) then
10355               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10356             else
10357               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10358             endif
10359 #endif
10360             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10361      &        auxvec(1))
10362             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10363             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10364      &        auxvec(1))
10365             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10366             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10367      &        pizda(1,1))
10368             vv(1)=pizda(1,1)+pizda(2,2)
10369             vv(2)=pizda(2,1)-pizda(1,2)
10370             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10371 #ifdef MOMENT
10372             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10373 #else
10374             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10375 #endif
10376             if (swap) then
10377               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10378             else
10379               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10380             endif
10381 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10382           enddo
10383         enddo
10384       enddo
10385       return
10386       end
10387 c----------------------------------------------------------------------------
10388       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10389       implicit real*8 (a-h,o-z)
10390       include 'DIMENSIONS'
10391       include 'COMMON.IOUNITS'
10392       include 'COMMON.CHAIN'
10393       include 'COMMON.DERIV'
10394       include 'COMMON.INTERACT'
10395       include 'COMMON.CONTACTS'
10396       include 'COMMON.TORSION'
10397       include 'COMMON.VAR'
10398       include 'COMMON.GEO'
10399       include 'COMMON.FFIELD'
10400       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10401      & auxvec1(2),auxmat1(2,2)
10402       logical swap
10403 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10404 C                                                                              C
10405 C      Parallel       Antiparallel                                             C
10406 C                                                                              C
10407 C          o             o                                                     C
10408 C         /l\   /   \   /j\                                                    C
10409 C        /   \ /     \ /   \                                                   C
10410 C       /| o |o       o| o |\                                                  C
10411 C     \ j|/k\|      \  |/k\|l                                                  C
10412 C      \ /   \       \ /   \                                                   C
10413 C       o     \       o     \                                                  C
10414 C       i             i                                                        C
10415 C                                                                              C
10416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10417 C
10418 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10419 C           energy moment and not to the cluster cumulant.
10420 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10421       iti=itype2loc(itype(i))
10422       itj=itype2loc(itype(j))
10423       if (j.lt.nres-1) then
10424         itj1=itype2loc(itype(j+1))
10425       else
10426         itj1=nloctyp
10427       endif
10428       itk=itype2loc(itype(k))
10429       if (k.lt.nres-1) then
10430         itk1=itype2loc(itype(k+1))
10431       else
10432         itk1=nloctyp
10433       endif
10434       itl=itype2loc(itype(l))
10435       if (l.lt.nres-1) then
10436         itl1=itype2loc(itype(l+1))
10437       else
10438         itl1=nloctyp
10439       endif
10440 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10441 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10442 cd     & ' itl',itl,' itl1',itl1
10443 #ifdef MOMENT
10444       if (imat.eq.1) then
10445         s1=dip(3,jj,i)*dip(3,kk,k)
10446       else
10447         s1=dip(2,jj,j)*dip(2,kk,l)
10448       endif
10449 #endif
10450       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10451       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10452       if (j.eq.l+1) then
10453         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10454         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10455       else
10456         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10457         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10458       endif
10459       call transpose2(EUg(1,1,k),auxmat(1,1))
10460       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10461       vv(1)=pizda(1,1)-pizda(2,2)
10462       vv(2)=pizda(2,1)+pizda(1,2)
10463       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10464 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10465 #ifdef MOMENT
10466       eello6_graph4=-(s1+s2+s3+s4)
10467 #else
10468       eello6_graph4=-(s2+s3+s4)
10469 #endif
10470 C Derivatives in gamma(i-1)
10471       if (i.gt.1) then
10472 #ifdef MOMENT
10473         if (imat.eq.1) then
10474           s1=dipderg(2,jj,i)*dip(3,kk,k)
10475         else
10476           s1=dipderg(4,jj,j)*dip(2,kk,l)
10477         endif
10478 #endif
10479         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10480         if (j.eq.l+1) then
10481           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10482           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10483         else
10484           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10485           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10486         endif
10487         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10488         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10489 cd          write (2,*) 'turn6 derivatives'
10490 #ifdef MOMENT
10491           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10492 #else
10493           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10494 #endif
10495         else
10496 #ifdef MOMENT
10497           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10498 #else
10499           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10500 #endif
10501         endif
10502       endif
10503 C Derivatives in gamma(k-1)
10504 #ifdef MOMENT
10505       if (imat.eq.1) then
10506         s1=dip(3,jj,i)*dipderg(2,kk,k)
10507       else
10508         s1=dip(2,jj,j)*dipderg(4,kk,l)
10509       endif
10510 #endif
10511       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10512       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10513       if (j.eq.l+1) then
10514         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10515         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10516       else
10517         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10518         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10519       endif
10520       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10521       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10522       vv(1)=pizda(1,1)-pizda(2,2)
10523       vv(2)=pizda(2,1)+pizda(1,2)
10524       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10525       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10526 #ifdef MOMENT
10527         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10528 #else
10529         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10530 #endif
10531       else
10532 #ifdef MOMENT
10533         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10534 #else
10535         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10536 #endif
10537       endif
10538 C Derivatives in gamma(j-1) or gamma(l-1)
10539       if (l.eq.j+1 .and. l.gt.1) then
10540         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10541         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10542         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10543         vv(1)=pizda(1,1)-pizda(2,2)
10544         vv(2)=pizda(2,1)+pizda(1,2)
10545         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10546         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10547       else if (j.gt.1) then
10548         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10549         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10550         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10551         vv(1)=pizda(1,1)-pizda(2,2)
10552         vv(2)=pizda(2,1)+pizda(1,2)
10553         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10554         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10555           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10556         else
10557           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10558         endif
10559       endif
10560 C Cartesian derivatives.
10561       do iii=1,2
10562         do kkk=1,5
10563           do lll=1,3
10564 #ifdef MOMENT
10565             if (iii.eq.1) then
10566               if (imat.eq.1) then
10567                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10568               else
10569                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10570               endif
10571             else
10572               if (imat.eq.1) then
10573                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10574               else
10575                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10576               endif
10577             endif
10578 #endif
10579             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10580      &        auxvec(1))
10581             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10582             if (j.eq.l+1) then
10583               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10584      &          b1(1,j+1),auxvec(1))
10585               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10586             else
10587               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10588      &          b1(1,l+1),auxvec(1))
10589               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10590             endif
10591             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10592      &        pizda(1,1))
10593             vv(1)=pizda(1,1)-pizda(2,2)
10594             vv(2)=pizda(2,1)+pizda(1,2)
10595             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10596             if (swap) then
10597               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10598 #ifdef MOMENT
10599                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10600      &             -(s1+s2+s4)
10601 #else
10602                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10603      &             -(s2+s4)
10604 #endif
10605                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10606               else
10607 #ifdef MOMENT
10608                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10609 #else
10610                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10611 #endif
10612                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10613               endif
10614             else
10615 #ifdef MOMENT
10616               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10617 #else
10618               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10619 #endif
10620               if (l.eq.j+1) then
10621                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10622               else
10623                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10624               endif
10625             endif
10626           enddo
10627         enddo
10628       enddo
10629       return
10630       end
10631 c----------------------------------------------------------------------------
10632       double precision function eello_turn6(i,jj,kk)
10633       implicit real*8 (a-h,o-z)
10634       include 'DIMENSIONS'
10635       include 'COMMON.IOUNITS'
10636       include 'COMMON.CHAIN'
10637       include 'COMMON.DERIV'
10638       include 'COMMON.INTERACT'
10639       include 'COMMON.CONTACTS'
10640       include 'COMMON.TORSION'
10641       include 'COMMON.VAR'
10642       include 'COMMON.GEO'
10643       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10644      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10645      &  ggg1(3),ggg2(3)
10646       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10647      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10648 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10649 C           the respective energy moment and not to the cluster cumulant.
10650       s1=0.0d0
10651       s8=0.0d0
10652       s13=0.0d0
10653 c
10654       eello_turn6=0.0d0
10655       j=i+4
10656       k=i+1
10657       l=i+3
10658       iti=itype2loc(itype(i))
10659       itk=itype2loc(itype(k))
10660       itk1=itype2loc(itype(k+1))
10661       itl=itype2loc(itype(l))
10662       itj=itype2loc(itype(j))
10663 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10664 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10665 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10666 cd        eello6=0.0d0
10667 cd        return
10668 cd      endif
10669 cd      write (iout,*)
10670 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10671 cd     &   ' and',k,l
10672 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10673       do iii=1,2
10674         do kkk=1,5
10675           do lll=1,3
10676             derx_turn(lll,kkk,iii)=0.0d0
10677           enddo
10678         enddo
10679       enddo
10680 cd      eij=1.0d0
10681 cd      ekl=1.0d0
10682 cd      ekont=1.0d0
10683       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10684 cd      eello6_5=0.0d0
10685 cd      write (2,*) 'eello6_5',eello6_5
10686 #ifdef MOMENT
10687       call transpose2(AEA(1,1,1),auxmat(1,1))
10688       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10689       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10690       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10691 #endif
10692       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10693       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10694       s2 = scalar2(b1(1,k),vtemp1(1))
10695 #ifdef MOMENT
10696       call transpose2(AEA(1,1,2),atemp(1,1))
10697       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10698       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10699       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10700 #endif
10701       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10702       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10703       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10704 #ifdef MOMENT
10705       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10706       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10707       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10708       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10709       ss13 = scalar2(b1(1,k),vtemp4(1))
10710       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10711 #endif
10712 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10713 c      s1=0.0d0
10714 c      s2=0.0d0
10715 c      s8=0.0d0
10716 c      s12=0.0d0
10717 c      s13=0.0d0
10718       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10719 C Derivatives in gamma(i+2)
10720       s1d =0.0d0
10721       s8d =0.0d0
10722 #ifdef MOMENT
10723       call transpose2(AEA(1,1,1),auxmatd(1,1))
10724       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10725       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10726       call transpose2(AEAderg(1,1,2),atempd(1,1))
10727       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10728       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10729 #endif
10730       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10731       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10732       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10733 c      s1d=0.0d0
10734 c      s2d=0.0d0
10735 c      s8d=0.0d0
10736 c      s12d=0.0d0
10737 c      s13d=0.0d0
10738       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10739 C Derivatives in gamma(i+3)
10740 #ifdef MOMENT
10741       call transpose2(AEA(1,1,1),auxmatd(1,1))
10742       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10743       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10744       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10745 #endif
10746       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10747       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10748       s2d = scalar2(b1(1,k),vtemp1d(1))
10749 #ifdef MOMENT
10750       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10751       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10752 #endif
10753       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10754 #ifdef MOMENT
10755       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10756       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10757       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10758 #endif
10759 c      s1d=0.0d0
10760 c      s2d=0.0d0
10761 c      s8d=0.0d0
10762 c      s12d=0.0d0
10763 c      s13d=0.0d0
10764 #ifdef MOMENT
10765       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10766      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10767 #else
10768       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10769      &               -0.5d0*ekont*(s2d+s12d)
10770 #endif
10771 C Derivatives in gamma(i+4)
10772       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10773       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10774       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10775 #ifdef MOMENT
10776       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10777       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10778       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10779 #endif
10780 c      s1d=0.0d0
10781 c      s2d=0.0d0
10782 c      s8d=0.0d0
10783 C      s12d=0.0d0
10784 c      s13d=0.0d0
10785 #ifdef MOMENT
10786       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10787 #else
10788       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10789 #endif
10790 C Derivatives in gamma(i+5)
10791 #ifdef MOMENT
10792       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10793       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10794       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10795 #endif
10796       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10797       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10798       s2d = scalar2(b1(1,k),vtemp1d(1))
10799 #ifdef MOMENT
10800       call transpose2(AEA(1,1,2),atempd(1,1))
10801       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10802       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10803 #endif
10804       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10805       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10806 #ifdef MOMENT
10807       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10808       ss13d = scalar2(b1(1,k),vtemp4d(1))
10809       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10810 #endif
10811 c      s1d=0.0d0
10812 c      s2d=0.0d0
10813 c      s8d=0.0d0
10814 c      s12d=0.0d0
10815 c      s13d=0.0d0
10816 #ifdef MOMENT
10817       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10818      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10819 #else
10820       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10821      &               -0.5d0*ekont*(s2d+s12d)
10822 #endif
10823 C Cartesian derivatives
10824       do iii=1,2
10825         do kkk=1,5
10826           do lll=1,3
10827 #ifdef MOMENT
10828             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10829             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10830             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10831 #endif
10832             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10833             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10834      &          vtemp1d(1))
10835             s2d = scalar2(b1(1,k),vtemp1d(1))
10836 #ifdef MOMENT
10837             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10838             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10839             s8d = -(atempd(1,1)+atempd(2,2))*
10840      &           scalar2(cc(1,1,itl),vtemp2(1))
10841 #endif
10842             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10843      &           auxmatd(1,1))
10844             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10845             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10846 c      s1d=0.0d0
10847 c      s2d=0.0d0
10848 c      s8d=0.0d0
10849 c      s12d=0.0d0
10850 c      s13d=0.0d0
10851 #ifdef MOMENT
10852             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10853      &        - 0.5d0*(s1d+s2d)
10854 #else
10855             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10856      &        - 0.5d0*s2d
10857 #endif
10858 #ifdef MOMENT
10859             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10860      &        - 0.5d0*(s8d+s12d)
10861 #else
10862             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10863      &        - 0.5d0*s12d
10864 #endif
10865           enddo
10866         enddo
10867       enddo
10868 #ifdef MOMENT
10869       do kkk=1,5
10870         do lll=1,3
10871           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10872      &      achuj_tempd(1,1))
10873           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10874           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10875           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10876           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10877           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10878      &      vtemp4d(1))
10879           ss13d = scalar2(b1(1,k),vtemp4d(1))
10880           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10881           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10882         enddo
10883       enddo
10884 #endif
10885 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10886 cd     &  16*eel_turn6_num
10887 cd      goto 1112
10888       if (j.lt.nres-1) then
10889         j1=j+1
10890         j2=j-1
10891       else
10892         j1=j-1
10893         j2=j-2
10894       endif
10895       if (l.lt.nres-1) then
10896         l1=l+1
10897         l2=l-1
10898       else
10899         l1=l-1
10900         l2=l-2
10901       endif
10902       do ll=1,3
10903 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10904 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10905 cgrad        ghalf=0.5d0*ggg1(ll)
10906 cd        ghalf=0.0d0
10907         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10908         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10909         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10910      &    +ekont*derx_turn(ll,2,1)
10911         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10912         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10913      &    +ekont*derx_turn(ll,4,1)
10914         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10915         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10916         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10917 cgrad        ghalf=0.5d0*ggg2(ll)
10918 cd        ghalf=0.0d0
10919         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10920      &    +ekont*derx_turn(ll,2,2)
10921         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10922         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10923      &    +ekont*derx_turn(ll,4,2)
10924         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10925         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10926         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10927       enddo
10928 cd      goto 1112
10929 cgrad      do m=i+1,j-1
10930 cgrad        do ll=1,3
10931 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10932 cgrad        enddo
10933 cgrad      enddo
10934 cgrad      do m=k+1,l-1
10935 cgrad        do ll=1,3
10936 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10937 cgrad        enddo
10938 cgrad      enddo
10939 cgrad1112  continue
10940 cgrad      do m=i+2,j2
10941 cgrad        do ll=1,3
10942 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10943 cgrad        enddo
10944 cgrad      enddo
10945 cgrad      do m=k+2,l2
10946 cgrad        do ll=1,3
10947 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10948 cgrad        enddo
10949 cgrad      enddo
10950 cd      do iii=1,nres-3
10951 cd        write (2,*) iii,g_corr6_loc(iii)
10952 cd      enddo
10953       eello_turn6=ekont*eel_turn6
10954 cd      write (2,*) 'ekont',ekont
10955 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10956       return
10957       end
10958
10959 C-----------------------------------------------------------------------------
10960       double precision function scalar(u,v)
10961 !DIR$ INLINEALWAYS scalar
10962 #ifndef OSF
10963 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10964 #endif
10965       implicit none
10966       double precision u(3),v(3)
10967 cd      double precision sc
10968 cd      integer i
10969 cd      sc=0.0d0
10970 cd      do i=1,3
10971 cd        sc=sc+u(i)*v(i)
10972 cd      enddo
10973 cd      scalar=sc
10974
10975       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10976       return
10977       end
10978 crc-------------------------------------------------
10979       SUBROUTINE MATVEC2(A1,V1,V2)
10980 !DIR$ INLINEALWAYS MATVEC2
10981 #ifndef OSF
10982 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10983 #endif
10984       implicit real*8 (a-h,o-z)
10985       include 'DIMENSIONS'
10986       DIMENSION A1(2,2),V1(2),V2(2)
10987 c      DO 1 I=1,2
10988 c        VI=0.0
10989 c        DO 3 K=1,2
10990 c    3     VI=VI+A1(I,K)*V1(K)
10991 c        Vaux(I)=VI
10992 c    1 CONTINUE
10993
10994       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10995       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10996
10997       v2(1)=vaux1
10998       v2(2)=vaux2
10999       END
11000 C---------------------------------------
11001       SUBROUTINE MATMAT2(A1,A2,A3)
11002 #ifndef OSF
11003 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11004 #endif
11005       implicit real*8 (a-h,o-z)
11006       include 'DIMENSIONS'
11007       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11008 c      DIMENSION AI3(2,2)
11009 c        DO  J=1,2
11010 c          A3IJ=0.0
11011 c          DO K=1,2
11012 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11013 c          enddo
11014 c          A3(I,J)=A3IJ
11015 c       enddo
11016 c      enddo
11017
11018       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11019       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11020       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11021       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11022
11023       A3(1,1)=AI3_11
11024       A3(2,1)=AI3_21
11025       A3(1,2)=AI3_12
11026       A3(2,2)=AI3_22
11027       END
11028
11029 c-------------------------------------------------------------------------
11030       double precision function scalar2(u,v)
11031 !DIR$ INLINEALWAYS scalar2
11032       implicit none
11033       double precision u(2),v(2)
11034       double precision sc
11035       integer i
11036       scalar2=u(1)*v(1)+u(2)*v(2)
11037       return
11038       end
11039
11040 C-----------------------------------------------------------------------------
11041
11042       subroutine transpose2(a,at)
11043 !DIR$ INLINEALWAYS transpose2
11044 #ifndef OSF
11045 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11046 #endif
11047       implicit none
11048       double precision a(2,2),at(2,2)
11049       at(1,1)=a(1,1)
11050       at(1,2)=a(2,1)
11051       at(2,1)=a(1,2)
11052       at(2,2)=a(2,2)
11053       return
11054       end
11055 c--------------------------------------------------------------------------
11056       subroutine transpose(n,a,at)
11057       implicit none
11058       integer n,i,j
11059       double precision a(n,n),at(n,n)
11060       do i=1,n
11061         do j=1,n
11062           at(j,i)=a(i,j)
11063         enddo
11064       enddo
11065       return
11066       end
11067 C---------------------------------------------------------------------------
11068       subroutine prodmat3(a1,a2,kk,transp,prod)
11069 !DIR$ INLINEALWAYS prodmat3
11070 #ifndef OSF
11071 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11072 #endif
11073       implicit none
11074       integer i,j
11075       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11076       logical transp
11077 crc      double precision auxmat(2,2),prod_(2,2)
11078
11079       if (transp) then
11080 crc        call transpose2(kk(1,1),auxmat(1,1))
11081 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11082 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11083
11084            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11085      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11086            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11087      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11088            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11089      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11090            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11091      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11092
11093       else
11094 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11095 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11096
11097            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11098      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11099            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11100      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11101            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11102      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11103            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11104      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11105
11106       endif
11107 c      call transpose2(a2(1,1),a2t(1,1))
11108
11109 crc      print *,transp
11110 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11111 crc      print *,((prod(i,j),i=1,2),j=1,2)
11112
11113       return
11114       end
11115 CCC----------------------------------------------
11116       subroutine Eliptransfer(eliptran)
11117       implicit real*8 (a-h,o-z)
11118       include 'DIMENSIONS'
11119       include 'COMMON.GEO'
11120       include 'COMMON.VAR'
11121       include 'COMMON.LOCAL'
11122       include 'COMMON.CHAIN'
11123       include 'COMMON.DERIV'
11124       include 'COMMON.NAMES'
11125       include 'COMMON.INTERACT'
11126       include 'COMMON.IOUNITS'
11127       include 'COMMON.CALC'
11128       include 'COMMON.CONTROL'
11129       include 'COMMON.SPLITELE'
11130       include 'COMMON.SBRIDGE'
11131 C this is done by Adasko
11132 C      print *,"wchodze"
11133 C structure of box:
11134 C      water
11135 C--bordliptop-- buffore starts
11136 C--bufliptop--- here true lipid starts
11137 C      lipid
11138 C--buflipbot--- lipid ends buffore starts
11139 C--bordlipbot--buffore ends
11140       eliptran=0.0
11141       do i=ilip_start,ilip_end
11142 C       do i=1,1
11143         if (itype(i).eq.ntyp1) cycle
11144
11145         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11146         if (positi.le.0.0) positi=positi+boxzsize
11147 C        print *,i
11148 C first for peptide groups
11149 c for each residue check if it is in lipid or lipid water border area
11150        if ((positi.gt.bordlipbot)
11151      &.and.(positi.lt.bordliptop)) then
11152 C the energy transfer exist
11153         if (positi.lt.buflipbot) then
11154 C what fraction I am in
11155          fracinbuf=1.0d0-
11156      &        ((positi-bordlipbot)/lipbufthick)
11157 C lipbufthick is thickenes of lipid buffore
11158          sslip=sscalelip(fracinbuf)
11159          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11160          eliptran=eliptran+sslip*pepliptran
11161          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11162          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11163 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11164
11165 C        print *,"doing sccale for lower part"
11166 C         print *,i,sslip,fracinbuf,ssgradlip
11167         elseif (positi.gt.bufliptop) then
11168          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11169          sslip=sscalelip(fracinbuf)
11170          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11171          eliptran=eliptran+sslip*pepliptran
11172          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11173          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11174 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11175 C          print *, "doing sscalefor top part"
11176 C         print *,i,sslip,fracinbuf,ssgradlip
11177         else
11178          eliptran=eliptran+pepliptran
11179 C         print *,"I am in true lipid"
11180         endif
11181 C       else
11182 C       eliptran=elpitran+0.0 ! I am in water
11183        endif
11184        enddo
11185 C       print *, "nic nie bylo w lipidzie?"
11186 C now multiply all by the peptide group transfer factor
11187 C       eliptran=eliptran*pepliptran
11188 C now the same for side chains
11189 CV       do i=1,1
11190        do i=ilip_start,ilip_end
11191         if (itype(i).eq.ntyp1) cycle
11192         positi=(mod(c(3,i+nres),boxzsize))
11193         if (positi.le.0) positi=positi+boxzsize
11194 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11195 c for each residue check if it is in lipid or lipid water border area
11196 C       respos=mod(c(3,i+nres),boxzsize)
11197 C       print *,positi,bordlipbot,buflipbot
11198        if ((positi.gt.bordlipbot)
11199      & .and.(positi.lt.bordliptop)) then
11200 C the energy transfer exist
11201         if (positi.lt.buflipbot) then
11202          fracinbuf=1.0d0-
11203      &     ((positi-bordlipbot)/lipbufthick)
11204 C lipbufthick is thickenes of lipid buffore
11205          sslip=sscalelip(fracinbuf)
11206          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11207          eliptran=eliptran+sslip*liptranene(itype(i))
11208          gliptranx(3,i)=gliptranx(3,i)
11209      &+ssgradlip*liptranene(itype(i))
11210          gliptranc(3,i-1)= gliptranc(3,i-1)
11211      &+ssgradlip*liptranene(itype(i))
11212 C         print *,"doing sccale for lower part"
11213         elseif (positi.gt.bufliptop) then
11214          fracinbuf=1.0d0-
11215      &((bordliptop-positi)/lipbufthick)
11216          sslip=sscalelip(fracinbuf)
11217          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11218          eliptran=eliptran+sslip*liptranene(itype(i))
11219          gliptranx(3,i)=gliptranx(3,i)
11220      &+ssgradlip*liptranene(itype(i))
11221          gliptranc(3,i-1)= gliptranc(3,i-1)
11222      &+ssgradlip*liptranene(itype(i))
11223 C          print *, "doing sscalefor top part",sslip,fracinbuf
11224         else
11225          eliptran=eliptran+liptranene(itype(i))
11226 C         print *,"I am in true lipid"
11227         endif
11228         endif ! if in lipid or buffor
11229 C       else
11230 C       eliptran=elpitran+0.0 ! I am in water
11231        enddo
11232        return
11233        end
11234 C---------------------------------------------------------
11235 C AFM soubroutine for constant force
11236        subroutine AFMforce(Eafmforce)
11237        implicit real*8 (a-h,o-z)
11238       include 'DIMENSIONS'
11239       include 'COMMON.GEO'
11240       include 'COMMON.VAR'
11241       include 'COMMON.LOCAL'
11242       include 'COMMON.CHAIN'
11243       include 'COMMON.DERIV'
11244       include 'COMMON.NAMES'
11245       include 'COMMON.INTERACT'
11246       include 'COMMON.IOUNITS'
11247       include 'COMMON.CALC'
11248       include 'COMMON.CONTROL'
11249       include 'COMMON.SPLITELE'
11250       include 'COMMON.SBRIDGE'
11251       real*8 diffafm(3)
11252       dist=0.0d0
11253       Eafmforce=0.0d0
11254       do i=1,3
11255       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11256       dist=dist+diffafm(i)**2
11257       enddo
11258       dist=dsqrt(dist)
11259       Eafmforce=-forceAFMconst*(dist-distafminit)
11260       do i=1,3
11261       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11262       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11263       enddo
11264 C      print *,'AFM',Eafmforce
11265       return
11266       end
11267 C---------------------------------------------------------
11268 C AFM subroutine with pseudoconstant velocity
11269        subroutine AFMvel(Eafmforce)
11270        implicit real*8 (a-h,o-z)
11271       include 'DIMENSIONS'
11272       include 'COMMON.GEO'
11273       include 'COMMON.VAR'
11274       include 'COMMON.LOCAL'
11275       include 'COMMON.CHAIN'
11276       include 'COMMON.DERIV'
11277       include 'COMMON.NAMES'
11278       include 'COMMON.INTERACT'
11279       include 'COMMON.IOUNITS'
11280       include 'COMMON.CALC'
11281       include 'COMMON.CONTROL'
11282       include 'COMMON.SPLITELE'
11283       include 'COMMON.SBRIDGE'
11284       real*8 diffafm(3)
11285 C Only for check grad COMMENT if not used for checkgrad
11286 C      totT=3.0d0
11287 C--------------------------------------------------------
11288 C      print *,"wchodze"
11289       dist=0.0d0
11290       Eafmforce=0.0d0
11291       do i=1,3
11292       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11293       dist=dist+diffafm(i)**2
11294       enddo
11295       dist=dsqrt(dist)
11296       Eafmforce=0.5d0*forceAFMconst
11297      & *(distafminit+totTafm*velAFMconst-dist)**2
11298 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11299       do i=1,3
11300       gradafm(i,afmend-1)=-forceAFMconst*
11301      &(distafminit+totTafm*velAFMconst-dist)
11302      &*diffafm(i)/dist
11303       gradafm(i,afmbeg-1)=forceAFMconst*
11304      &(distafminit+totTafm*velAFMconst-dist)
11305      &*diffafm(i)/dist
11306       enddo
11307 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11308       return
11309       end
11310 C-----------------------------------------------------------
11311 C first for shielding is setting of function of side-chains
11312        subroutine set_shield_fac
11313       implicit real*8 (a-h,o-z)
11314       include 'DIMENSIONS'
11315       include 'COMMON.CHAIN'
11316       include 'COMMON.DERIV'
11317       include 'COMMON.IOUNITS'
11318       include 'COMMON.SHIELD'
11319       include 'COMMON.INTERACT'
11320 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11321       double precision div77_81/0.974996043d0/,
11322      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11323
11324 C the vector between center of side_chain and peptide group
11325        double precision pep_side(3),long,side_calf(3),
11326      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11327      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11328 C the line belowe needs to be changed for FGPROC>1
11329       do i=1,nres-1
11330       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11331       ishield_list(i)=0
11332 Cif there two consequtive dummy atoms there is no peptide group between them
11333 C the line below has to be changed for FGPROC>1
11334       VolumeTotal=0.0
11335       do k=1,nres
11336        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11337        dist_pep_side=0.0
11338        dist_side_calf=0.0
11339        do j=1,3
11340 C first lets set vector conecting the ithe side-chain with kth side-chain
11341       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11342 C      pep_side(j)=2.0d0
11343 C and vector conecting the side-chain with its proper calfa
11344       side_calf(j)=c(j,k+nres)-c(j,k)
11345 C      side_calf(j)=2.0d0
11346       pept_group(j)=c(j,i)-c(j,i+1)
11347 C lets have their lenght
11348       dist_pep_side=pep_side(j)**2+dist_pep_side
11349       dist_side_calf=dist_side_calf+side_calf(j)**2
11350       dist_pept_group=dist_pept_group+pept_group(j)**2
11351       enddo
11352        dist_pep_side=dsqrt(dist_pep_side)
11353        dist_pept_group=dsqrt(dist_pept_group)
11354        dist_side_calf=dsqrt(dist_side_calf)
11355       do j=1,3
11356         pep_side_norm(j)=pep_side(j)/dist_pep_side
11357         side_calf_norm(j)=dist_side_calf
11358       enddo
11359 C now sscale fraction
11360        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11361 C       print *,buff_shield,"buff"
11362 C now sscale
11363         if (sh_frac_dist.le.0.0) cycle
11364 C If we reach here it means that this side chain reaches the shielding sphere
11365 C Lets add him to the list for gradient
11366         ishield_list(i)=ishield_list(i)+1
11367 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11368 C this list is essential otherwise problem would be O3
11369         shield_list(ishield_list(i),i)=k
11370 C Lets have the sscale value
11371         if (sh_frac_dist.gt.1.0) then
11372          scale_fac_dist=1.0d0
11373          do j=1,3
11374          sh_frac_dist_grad(j)=0.0d0
11375          enddo
11376         else
11377          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11378      &                   *(2.0*sh_frac_dist-3.0d0)
11379          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11380      &                  /dist_pep_side/buff_shield*0.5
11381 C remember for the final gradient multiply sh_frac_dist_grad(j)
11382 C for side_chain by factor -2 !
11383          do j=1,3
11384          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11385 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11386 C     &                    sh_frac_dist_grad(j)
11387          enddo
11388         endif
11389 C        if ((i.eq.3).and.(k.eq.2)) then
11390 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11391 C     & ,"TU"
11392 C        endif
11393
11394 C this is what is now we have the distance scaling now volume...
11395       short=short_r_sidechain(itype(k))
11396       long=long_r_sidechain(itype(k))
11397       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11398 C now costhet_grad
11399 C       costhet=0.0d0
11400        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11401 C       costhet_fac=0.0d0
11402        do j=1,3
11403          costhet_grad(j)=costhet_fac*pep_side(j)
11404        enddo
11405 C remember for the final gradient multiply costhet_grad(j)
11406 C for side_chain by factor -2 !
11407 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11408 C pep_side0pept_group is vector multiplication
11409       pep_side0pept_group=0.0
11410       do j=1,3
11411       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11412       enddo
11413       cosalfa=(pep_side0pept_group/
11414      & (dist_pep_side*dist_side_calf))
11415       fac_alfa_sin=1.0-cosalfa**2
11416       fac_alfa_sin=dsqrt(fac_alfa_sin)
11417       rkprim=fac_alfa_sin*(long-short)+short
11418 C now costhet_grad
11419        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11420        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11421
11422        do j=1,3
11423          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11424      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11425      &*(long-short)/fac_alfa_sin*cosalfa/
11426      &((dist_pep_side*dist_side_calf))*
11427      &((side_calf(j))-cosalfa*
11428      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11429
11430         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11431      &*(long-short)/fac_alfa_sin*cosalfa
11432      &/((dist_pep_side*dist_side_calf))*
11433      &(pep_side(j)-
11434      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11435        enddo
11436
11437       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11438      &                    /VSolvSphere_div
11439      &                    *wshield
11440 C now the gradient...
11441 C grad_shield is gradient of Calfa for peptide groups
11442 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11443 C     &               costhet,cosphi
11444 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11445 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11446       do j=1,3
11447       grad_shield(j,i)=grad_shield(j,i)
11448 C gradient po skalowaniu
11449      &                +(sh_frac_dist_grad(j)
11450 C  gradient po costhet
11451      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11452      &-scale_fac_dist*(cosphi_grad_long(j))
11453      &/(1.0-cosphi) )*div77_81
11454      &*VofOverlap
11455 C grad_shield_side is Cbeta sidechain gradient
11456       grad_shield_side(j,ishield_list(i),i)=
11457      &        (sh_frac_dist_grad(j)*-2.0d0
11458      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11459      &       +scale_fac_dist*(cosphi_grad_long(j))
11460      &        *2.0d0/(1.0-cosphi))
11461      &        *div77_81*VofOverlap
11462
11463        grad_shield_loc(j,ishield_list(i),i)=
11464      &   scale_fac_dist*cosphi_grad_loc(j)
11465      &        *2.0d0/(1.0-cosphi)
11466      &        *div77_81*VofOverlap
11467       enddo
11468       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11469       enddo
11470       fac_shield(i)=VolumeTotal*div77_81+div4_81
11471 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11472       enddo
11473       return
11474       end
11475 C--------------------------------------------------------------------------
11476       double precision function tschebyshev(m,n,x,y)
11477       implicit none
11478       include "DIMENSIONS"
11479       integer i,m,n
11480       double precision x(n),y,yy(0:maxvar),aux
11481 c Tschebyshev polynomial. Note that the first term is omitted
11482 c m=0: the constant term is included
11483 c m=1: the constant term is not included
11484       yy(0)=1.0d0
11485       yy(1)=y
11486       do i=2,n
11487         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11488       enddo
11489       aux=0.0d0
11490       do i=m,n
11491         aux=aux+x(i)*yy(i)
11492       enddo
11493       tschebyshev=aux
11494       return
11495       end
11496 C--------------------------------------------------------------------------
11497       double precision function gradtschebyshev(m,n,x,y)
11498       implicit none
11499       include "DIMENSIONS"
11500       integer i,m,n
11501       double precision x(n+1),y,yy(0:maxvar),aux
11502 c Tschebyshev polynomial. Note that the first term is omitted
11503 c m=0: the constant term is included
11504 c m=1: the constant term is not included
11505       yy(0)=1.0d0
11506       yy(1)=2.0d0*y
11507       do i=2,n
11508         yy(i)=2*y*yy(i-1)-yy(i-2)
11509       enddo
11510       aux=0.0d0
11511       do i=m,n
11512         aux=aux+x(i+1)*yy(i)*(i+1)
11513 C        print *, x(i+1),yy(i),i
11514       enddo
11515       gradtschebyshev=aux
11516       return
11517       end
11518 C------------------------------------------------------------------------
11519 C first for shielding is setting of function of side-chains
11520        subroutine set_shield_fac2
11521       implicit real*8 (a-h,o-z)
11522       include 'DIMENSIONS'
11523       include 'COMMON.CHAIN'
11524       include 'COMMON.DERIV'
11525       include 'COMMON.IOUNITS'
11526       include 'COMMON.SHIELD'
11527       include 'COMMON.INTERACT'
11528 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11529       double precision div77_81/0.974996043d0/,
11530      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11531
11532 C the vector between center of side_chain and peptide group
11533        double precision pep_side(3),long,side_calf(3),
11534      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11535      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11536 C the line belowe needs to be changed for FGPROC>1
11537       do i=1,nres-1
11538       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11539       ishield_list(i)=0
11540 Cif there two consequtive dummy atoms there is no peptide group between them
11541 C the line below has to be changed for FGPROC>1
11542       VolumeTotal=0.0
11543       do k=1,nres
11544        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11545        dist_pep_side=0.0
11546        dist_side_calf=0.0
11547        do j=1,3
11548 C first lets set vector conecting the ithe side-chain with kth side-chain
11549       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11550 C      pep_side(j)=2.0d0
11551 C and vector conecting the side-chain with its proper calfa
11552       side_calf(j)=c(j,k+nres)-c(j,k)
11553 C      side_calf(j)=2.0d0
11554       pept_group(j)=c(j,i)-c(j,i+1)
11555 C lets have their lenght
11556       dist_pep_side=pep_side(j)**2+dist_pep_side
11557       dist_side_calf=dist_side_calf+side_calf(j)**2
11558       dist_pept_group=dist_pept_group+pept_group(j)**2
11559       enddo
11560        dist_pep_side=dsqrt(dist_pep_side)
11561        dist_pept_group=dsqrt(dist_pept_group)
11562        dist_side_calf=dsqrt(dist_side_calf)
11563       do j=1,3
11564         pep_side_norm(j)=pep_side(j)/dist_pep_side
11565         side_calf_norm(j)=dist_side_calf
11566       enddo
11567 C now sscale fraction
11568        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11569 C       print *,buff_shield,"buff"
11570 C now sscale
11571         if (sh_frac_dist.le.0.0) cycle
11572 C If we reach here it means that this side chain reaches the shielding sphere
11573 C Lets add him to the list for gradient
11574         ishield_list(i)=ishield_list(i)+1
11575 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11576 C this list is essential otherwise problem would be O3
11577         shield_list(ishield_list(i),i)=k
11578 C Lets have the sscale value
11579         if (sh_frac_dist.gt.1.0) then
11580          scale_fac_dist=1.0d0
11581          do j=1,3
11582          sh_frac_dist_grad(j)=0.0d0
11583          enddo
11584         else
11585          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11586      &                   *(2.0d0*sh_frac_dist-3.0d0)
11587          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11588      &                  /dist_pep_side/buff_shield*0.5d0
11589 C remember for the final gradient multiply sh_frac_dist_grad(j)
11590 C for side_chain by factor -2 !
11591          do j=1,3
11592          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11593 C         sh_frac_dist_grad(j)=0.0d0
11594 C         scale_fac_dist=1.0d0
11595 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11596 C     &                    sh_frac_dist_grad(j)
11597          enddo
11598         endif
11599 C this is what is now we have the distance scaling now volume...
11600       short=short_r_sidechain(itype(k))
11601       long=long_r_sidechain(itype(k))
11602       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11603       sinthet=short/dist_pep_side*costhet
11604 C now costhet_grad
11605 C       costhet=0.6d0
11606 C       sinthet=0.8
11607        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11608 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11609 C     &             -short/dist_pep_side**2/costhet)
11610 C       costhet_fac=0.0d0
11611        do j=1,3
11612          costhet_grad(j)=costhet_fac*pep_side(j)
11613        enddo
11614 C remember for the final gradient multiply costhet_grad(j)
11615 C for side_chain by factor -2 !
11616 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11617 C pep_side0pept_group is vector multiplication
11618       pep_side0pept_group=0.0d0
11619       do j=1,3
11620       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11621       enddo
11622       cosalfa=(pep_side0pept_group/
11623      & (dist_pep_side*dist_side_calf))
11624       fac_alfa_sin=1.0d0-cosalfa**2
11625       fac_alfa_sin=dsqrt(fac_alfa_sin)
11626       rkprim=fac_alfa_sin*(long-short)+short
11627 C      rkprim=short
11628
11629 C now costhet_grad
11630        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11631 C       cosphi=0.6
11632        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11633        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11634      &      dist_pep_side**2)
11635 C       sinphi=0.8
11636        do j=1,3
11637          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11638      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11639      &*(long-short)/fac_alfa_sin*cosalfa/
11640      &((dist_pep_side*dist_side_calf))*
11641      &((side_calf(j))-cosalfa*
11642      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11643 C       cosphi_grad_long(j)=0.0d0
11644         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11645      &*(long-short)/fac_alfa_sin*cosalfa
11646      &/((dist_pep_side*dist_side_calf))*
11647      &(pep_side(j)-
11648      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11649 C       cosphi_grad_loc(j)=0.0d0
11650        enddo
11651 C      print *,sinphi,sinthet
11652       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11653      &                    /VSolvSphere_div
11654 C     &                    *wshield
11655 C now the gradient...
11656       do j=1,3
11657       grad_shield(j,i)=grad_shield(j,i)
11658 C gradient po skalowaniu
11659      &                +(sh_frac_dist_grad(j)*VofOverlap
11660 C  gradient po costhet
11661      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11662      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11663      &       sinphi/sinthet*costhet*costhet_grad(j)
11664      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11665      & )*wshield
11666 C grad_shield_side is Cbeta sidechain gradient
11667       grad_shield_side(j,ishield_list(i),i)=
11668      &        (sh_frac_dist_grad(j)*-2.0d0
11669      &        *VofOverlap
11670      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11671      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11672      &       sinphi/sinthet*costhet*costhet_grad(j)
11673      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11674      &       )*wshield
11675
11676        grad_shield_loc(j,ishield_list(i),i)=
11677      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11678      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11679      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11680      &        ))
11681      &        *wshield
11682       enddo
11683       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11684       enddo
11685       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11686 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11687       enddo
11688       return
11689       end
11690 C-----------------------------------------------------------------------
11691 C-----------------------------------------------------------
11692 C This subroutine is to mimic the histone like structure but as well can be
11693 C utilizet to nanostructures (infinit) small modification has to be used to
11694 C make it finite (z gradient at the ends has to be changes as well as the x,y
11695 C gradient has to be modified at the ends
11696 C The energy function is Kihara potential
11697 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11698 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11699 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11700 C simple Kihara potential
11701       subroutine calctube(Etube)
11702        implicit real*8 (a-h,o-z)
11703       include 'DIMENSIONS'
11704       include 'COMMON.GEO'
11705       include 'COMMON.VAR'
11706       include 'COMMON.LOCAL'
11707       include 'COMMON.CHAIN'
11708       include 'COMMON.DERIV'
11709       include 'COMMON.NAMES'
11710       include 'COMMON.INTERACT'
11711       include 'COMMON.IOUNITS'
11712       include 'COMMON.CALC'
11713       include 'COMMON.CONTROL'
11714       include 'COMMON.SPLITELE'
11715       include 'COMMON.SBRIDGE'
11716       double precision tub_r,vectube(3),enetube(maxres*2)
11717       Etube=0.0d0
11718       do i=1,2*nres
11719         enetube(i)=0.0d0
11720       enddo
11721 C first we calculate the distance from tube center
11722 C first sugare-phosphate group for NARES this would be peptide group
11723 C for UNRES
11724       do i=1,nres
11725 C lets ommit dummy atoms for now
11726        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11727 C now calculate distance from center of tube and direction vectors
11728       vectube(1)=(c(1,i)+c(1,i+1))/2.0d0-tubecenter(1)
11729       vectube(2)=(c(2,i)+c(2,i+1))/2.0d0-tubecenter(2)
11730 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11731 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11732
11733 C as the tube is infinity we do not calculate the Z-vector use of Z
11734 C as chosen axis
11735       vectube(3)=0.0d0
11736 C now calculte the distance
11737        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11738 C now normalize vector
11739       vectube(1)=vectube(1)/tub_r
11740       vectube(2)=vectube(2)/tub_r
11741 C calculte rdiffrence between r and r0
11742       rdiff=tub_r-tubeR0
11743 C and its 6 power
11744       rdiff6=rdiff**6.0d0
11745 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11746        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11747 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11748 C       print *,rdiff,rdiff6,pep_aa_tube
11749 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11750 C now we calculate gradient
11751        fac=(-12.0d0*pep_aa_tube/rdiff6+
11752      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11753 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11754 C     &rdiff,fac
11755
11756 C now direction of gg_tube vector
11757         do j=1,3
11758         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11759         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11760         enddo
11761         enddo
11762 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11763         do i=1,nres
11764 C Lets not jump over memory as we use many times iti
11765          iti=itype(i)
11766 C lets ommit dummy atoms for now
11767          if ((iti.eq.ntyp1)
11768 C in UNRES uncomment the line below as GLY has no side-chain...
11769 C      .or.(iti.eq.10)
11770      &   ) cycle
11771       vectube(1)=c(1,i+nres)-tubecenter(1)
11772       vectube(2)=c(2,i+nres)-tubecenter(2)
11773
11774 C as the tube is infinity we do not calculate the Z-vector use of Z
11775 C as chosen axis
11776       vectube(3)=0.0d0
11777 C now calculte the distance
11778        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11779 C now normalize vector
11780       vectube(1)=vectube(1)/tub_r
11781       vectube(2)=vectube(2)/tub_r
11782 C calculte rdiffrence between r and r0
11783       rdiff=tub_r-tubeR0
11784 C and its 6 power
11785       rdiff6=rdiff**6.0d0
11786 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11787        sc_aa_tube=sc_aa_tube_par(iti)
11788        sc_bb_tube=sc_bb_tube_par(iti)
11789        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11790 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11791 C now we calculate gradient
11792        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11793      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11794 C now direction of gg_tube vector
11795          do j=1,3
11796           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11797           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11798          enddo
11799         enddo
11800         do i=1,2*nres
11801           Etube=Etube+enetube(i)
11802         enddo
11803 C        print *,"ETUBE", etube
11804         return
11805         end
11806 C TO DO 1) add to total energy
11807 C       2) add to gradient summation
11808 C       3) add reading parameters (AND of course oppening of PARAM file)
11809 C       4) add reading the center of tube
11810 C       5) add COMMONs
11811 C       6) add to zerograd
11812