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.eq.1) then
 311 C      print *,"just before call"
 312         call calctube(Etube)
 313        elseif (TUBElog.eq.2) then
 314         call calctube2(Etube)
 315        else
 316        Etube=0.0d0
 317        endif
 318
 319 #ifdef TIMING
 320       time_enecalc=time_enecalc+MPI_Wtime()-time00
 321 #endif
 322 c      print *,"Processor",myrank," computed Uconstr"
 323 #ifdef TIMING
 324       time00=MPI_Wtime()
 325 #endif
 326 c
 327 C Sum the energies
 328 C
 329       energia(1)=evdw
 330 #ifdef SCP14
 331       energia(2)=evdw2-evdw2_14
 332       energia(18)=evdw2_14
 333 #else
 334       energia(2)=evdw2
 335       energia(18)=0.0d0
 336 #endif
 337 #ifdef SPLITELE
 338       energia(3)=ees
 339       energia(16)=evdw1
 340 #else
 341       energia(3)=ees+evdw1
 342       energia(16)=0.0d0
 343 #endif
 344       energia(4)=ecorr
 345       energia(5)=ecorr5
 346       energia(6)=ecorr6
 347       energia(7)=eel_loc
 348       energia(8)=eello_turn3
 349       energia(9)=eello_turn4
 350       energia(10)=eturn6
 351       energia(11)=ebe
 352       energia(12)=escloc
 353       energia(13)=etors
 354       energia(14)=etors_d
 355       energia(15)=ehpb
 356       energia(19)=edihcnstr
 357       energia(17)=estr
 358       energia(20)=Uconst+Uconst_back
 359       energia(21)=esccor
 360       energia(22)=eliptran
 361       energia(23)=Eafmforce
 362       energia(24)=ethetacnstr
 363       energia(25)=Etube
 364 c    Here are the energies showed per procesor if the are more processors
 365 c    per molecule then we sum it up in sum_energy subroutine
 366 c      print *," Processor",myrank," calls SUM_ENERGY"
 367       call sum_energy(energia,.true.)
 368       if (dyn_ss) call dyn_set_nss
 369 c      print *," Processor",myrank," left SUM_ENERGY"
 370 #ifdef TIMING
 371       time_sumene=time_sumene+MPI_Wtime()-time00
 372 #endif
 373       return
 374       end
 375 c-------------------------------------------------------------------------------
 376       subroutine sum_energy(energia,reduce)
 377       implicit real*8 (a-h,o-z)
 378       include 'DIMENSIONS'
 379 #ifndef ISNAN
 380       external proc_proc
 381 #ifdef WINPGI
 382 cMS$ATTRIBUTES C ::  proc_proc
 383 #endif
 384 #endif
 385 #ifdef MPI
 386       include "mpif.h"
 387 #endif
 388       include 'COMMON.SETUP'
 389       include 'COMMON.IOUNITS'
 390       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 391       include 'COMMON.FFIELD'
 392       include 'COMMON.DERIV'
 393       include 'COMMON.INTERACT'
 394       include 'COMMON.SBRIDGE'
 395       include 'COMMON.CHAIN'
 396       include 'COMMON.VAR'
 397       include 'COMMON.CONTROL'
 398       include 'COMMON.TIME1'
 399       logical reduce
 400 #ifdef MPI
 401       if (nfgtasks.gt.1 .and. reduce) then
 402 #ifdef DEBUG
 403         write (iout,*) "energies before REDUCE"
 404         call enerprint(energia)
 405         call flush(iout)
 406 #endif
 407         do i=0,n_ene
 408           enebuff(i)=energia(i)
 409         enddo
 410         time00=MPI_Wtime()
 411         call MPI_Barrier(FG_COMM,IERR)
 412         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 413         time00=MPI_Wtime()
 414         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 415      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 416 #ifdef DEBUG
 417         write (iout,*) "energies after REDUCE"
 418         call enerprint(energia)
 419         call flush(iout)
 420 #endif
 421         time_Reduce=time_Reduce+MPI_Wtime()-time00
 422       endif
 423       if (fg_rank.eq.0) then
 424 #endif
 425       evdw=energia(1)
 426 #ifdef SCP14
 427       evdw2=energia(2)+energia(18)
 428       evdw2_14=energia(18)
 429 #else
 430       evdw2=energia(2)
 431 #endif
 432 #ifdef SPLITELE
 433       ees=energia(3)
 434       evdw1=energia(16)
 435 #else
 436       ees=energia(3)
 437       evdw1=0.0d0
 438 #endif
 439       ecorr=energia(4)
 440       ecorr5=energia(5)
 441       ecorr6=energia(6)
 442       eel_loc=energia(7)
 443       eello_turn3=energia(8)
 444       eello_turn4=energia(9)
 445       eturn6=energia(10)
 446       ebe=energia(11)
 447       escloc=energia(12)
 448       etors=energia(13)
 449       etors_d=energia(14)
 450       ehpb=energia(15)
 451       edihcnstr=energia(19)
 452       estr=energia(17)
 453       Uconst=energia(20)
 454       esccor=energia(21)
 455       eliptran=energia(22)
 456       Eafmforce=energia(23)
 457       ethetacnstr=energia(24)
 458       Etube=energia(25)
 459 #ifdef SPLITELE
 460       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 461      & +wang*ebe+wtor*etors+wscloc*escloc
 462      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 463      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 464      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 465      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 466      & +ethetacnstr+wtube*Etube
 467 #else
 468       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 469      & +wang*ebe+wtor*etors+wscloc*escloc
 470      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 471      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 472      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 473      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 474      & +Eafmforce
 475      & +ethetacnstr+wtube*Etube
 476 #endif
 477       energia(0)=etot
 478 c detecting NaNQ
 479 #ifdef ISNAN
 480 #ifdef AIX
 481       if (isnan(etot).ne.0) energia(0)=1.0d+99
 482 #else
 483       if (isnan(etot)) energia(0)=1.0d+99
 484 #endif
 485 #else
 486       i=0
 487 #ifdef WINPGI
 488       idumm=proc_proc(etot,i)
 489 #else
 490       call proc_proc(etot,i)
 491 #endif
 492       if(i.eq.1)energia(0)=1.0d+99
 493 #endif
 494 #ifdef MPI
 495       endif
 496 #endif
 497       return
 498       end
 499 c-------------------------------------------------------------------------------
 500       subroutine sum_gradient
 501       implicit real*8 (a-h,o-z)
 502       include 'DIMENSIONS'
 503 #ifndef ISNAN
 504       external proc_proc
 505 #ifdef WINPGI
 506 cMS$ATTRIBUTES C ::  proc_proc
 507 #endif
 508 #endif
 509 #ifdef MPI
 510       include 'mpif.h'
 511 #endif
 512       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 513      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 514      & ,gloc_scbuf(3,-1:maxres)
 515       include 'COMMON.SETUP'
 516       include 'COMMON.IOUNITS'
 517       include 'COMMON.FFIELD'
 518       include 'COMMON.DERIV'
 519       include 'COMMON.INTERACT'
 520       include 'COMMON.SBRIDGE'
 521       include 'COMMON.CHAIN'
 522       include 'COMMON.VAR'
 523       include 'COMMON.CONTROL'
 524       include 'COMMON.TIME1'
 525       include 'COMMON.MAXGRAD'
 526       include 'COMMON.SCCOR'
 527 #ifdef TIMING
 528       time01=MPI_Wtime()
 529 #endif
 530 #ifdef DEBUG
 531       write (iout,*) "sum_gradient gvdwc, gvdwx"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 534      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538 #ifdef MPI
 539 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 540         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 541      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 542 #endif
 543 C
 544 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 545 C            in virtual-bond-vector coordinates
 546 C
 547 #ifdef DEBUG
 548 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 549 c      do i=1,nres-1
 550 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 551 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 552 c      enddo
 553 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 554 c      do i=1,nres-1
 555 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 556 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 557 c      enddo
 558       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 559       do i=1,nres
 560         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 561      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 562      &   g_corr5_loc(i)
 563       enddo
 564       call flush(iout)
 565 #endif
 566 #ifdef SPLITELE
 567       do i=0,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 572      &                wel_loc*gel_loc_long(j,i)+
 573      &                wcorr*gradcorr_long(j,i)+
 574      &                wcorr5*gradcorr5_long(j,i)+
 575      &                wcorr6*gradcorr6_long(j,i)+
 576      &                wturn6*gcorr6_turn_long(j,i)+
 577      &                wstrain*ghpbc(j,i)
 578      &                +wliptran*gliptranc(j,i)
 579      &                +gradafm(j,i)
 580      &                 +welec*gshieldc(j,i)
 581      &                 +wcorr*gshieldc_ec(j,i)
 582      &                 +wturn3*gshieldc_t3(j,i)
 583      &                 +wturn4*gshieldc_t4(j,i)
 584      &                 +wel_loc*gshieldc_ll(j,i)
 585      &                +wtube*gg_tube(j,i)
 586
 587
 588
 589         enddo
 590       enddo
 591 #else
 592       do i=0,nct
 593         do j=1,3
 594           gradbufc(j,i)=wsc*gvdwc(j,i)+
 595      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 596      &                welec*gelc_long(j,i)+
 597      &                wbond*gradb(j,i)+
 598      &                wel_loc*gel_loc_long(j,i)+
 599      &                wcorr*gradcorr_long(j,i)+
 600      &                wcorr5*gradcorr5_long(j,i)+
 601      &                wcorr6*gradcorr6_long(j,i)+
 602      &                wturn6*gcorr6_turn_long(j,i)+
 603      &                wstrain*ghpbc(j,i)
 604      &                +wliptran*gliptranc(j,i)
 605      &                +gradafm(j,i)
 606      &                 +welec*gshieldc(j,i)
 607      &                 +wcorr*gshieldc_ec(j,i)
 608      &                 +wturn4*gshieldc_t4(j,i)
 609      &                 +wel_loc*gshieldc_ll(j,i)
 610      &                +wtube*gg_tube(j,i)
 611
 612
 613
 614         enddo
 615       enddo
 616 #endif
 617 #ifdef MPI
 618       if (nfgtasks.gt.1) then
 619       time00=MPI_Wtime()
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc before allreduce"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627       do i=0,nres
 628         do j=1,3
 629           gradbufc_sum(j,i)=gradbufc(j,i)
 630         enddo
 631       enddo
 632 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 633 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 634 c      time_reduce=time_reduce+MPI_Wtime()-time00
 635 #ifdef DEBUG
 636 c      write (iout,*) "gradbufc_sum after allreduce"
 637 c      do i=1,nres
 638 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 639 c      enddo
 640 c      call flush(iout)
 641 #endif
 642 #ifdef TIMING
 643 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 644 #endif
 645       do i=nnt,nres
 646         do k=1,3
 647           gradbufc(k,i)=0.0d0
 648         enddo
 649       enddo
 650 #ifdef DEBUG
 651       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 652       write (iout,*) (i," jgrad_start",jgrad_start(i),
 653      &                  " jgrad_end  ",jgrad_end(i),
 654      &                  i=igrad_start,igrad_end)
 655 #endif
 656 c
 657 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 658 c do not parallelize this part.
 659 c
 660 c      do i=igrad_start,igrad_end
 661 c        do j=jgrad_start(i),jgrad_end(i)
 662 c          do k=1,3
 663 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 664 c          enddo
 665 c        enddo
 666 c      enddo
 667       do j=1,3
 668         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 669       enddo
 670       do i=nres-2,-1,-1
 671         do j=1,3
 672           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 673         enddo
 674       enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682       else
 683 #endif
 684 #ifdef DEBUG
 685       write (iout,*) "gradbufc"
 686       do i=1,nres
 687         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 688       enddo
 689       call flush(iout)
 690 #endif
 691       do i=-1,nres
 692         do j=1,3
 693           gradbufc_sum(j,i)=gradbufc(j,i)
 694           gradbufc(j,i)=0.0d0
 695         enddo
 696       enddo
 697       do j=1,3
 698         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 699       enddo
 700       do i=nres-2,-1,-1
 701         do j=1,3
 702           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 703         enddo
 704       enddo
 705 c      do i=nnt,nres-1
 706 c        do k=1,3
 707 c          gradbufc(k,i)=0.0d0
 708 c        enddo
 709 c        do j=i+1,nres
 710 c          do k=1,3
 711 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 712 c          enddo
 713 c        enddo
 714 c      enddo
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc after summing"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722 #ifdef MPI
 723       endif
 724 #endif
 725       do k=1,3
 726         gradbufc(k,nres)=0.0d0
 727       enddo
 728       do i=-1,nct
 729         do j=1,3
 730 #ifdef SPLITELE
 731 C          print *,gradbufc(1,13)
 732 C          print *,welec*gelc(1,13)
 733 C          print *,wel_loc*gel_loc(1,13)
 734 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 735 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 736 C          print *,wel_loc*gel_loc_long(1,13)
 737 C          print *,gradafm(1,13),"AFM"
 738           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 739      &                wel_loc*gel_loc(j,i)+
 740      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 741      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 742      &                wel_loc*gel_loc_long(j,i)+
 743      &                wcorr*gradcorr_long(j,i)+
 744      &                wcorr5*gradcorr5_long(j,i)+
 745      &                wcorr6*gradcorr6_long(j,i)+
 746      &                wturn6*gcorr6_turn_long(j,i))+
 747      &                wbond*gradb(j,i)+
 748      &                wcorr*gradcorr(j,i)+
 749      &                wturn3*gcorr3_turn(j,i)+
 750      &                wturn4*gcorr4_turn(j,i)+
 751      &                wcorr5*gradcorr5(j,i)+
 752      &                wcorr6*gradcorr6(j,i)+
 753      &                wturn6*gcorr6_turn(j,i)+
 754      &                wsccor*gsccorc(j,i)
 755      &               +wscloc*gscloc(j,i)
 756      &               +wliptran*gliptranc(j,i)
 757      &                +gradafm(j,i)
 758      &                 +welec*gshieldc(j,i)
 759      &                 +welec*gshieldc_loc(j,i)
 760      &                 +wcorr*gshieldc_ec(j,i)
 761      &                 +wcorr*gshieldc_loc_ec(j,i)
 762      &                 +wturn3*gshieldc_t3(j,i)
 763      &                 +wturn3*gshieldc_loc_t3(j,i)
 764      &                 +wturn4*gshieldc_t4(j,i)
 765      &                 +wturn4*gshieldc_loc_t4(j,i)
 766      &                 +wel_loc*gshieldc_ll(j,i)
 767      &                 +wel_loc*gshieldc_loc_ll(j,i)
 768      &                +wtube*gg_tube(j,i)
 769
 770 #else
 771           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 772      &                wel_loc*gel_loc(j,i)+
 773      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 774      &                welec*gelc_long(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i))+
 780      &                wbond*gradb(j,i)+
 781      &                wcorr*gradcorr(j,i)+
 782      &                wturn3*gcorr3_turn(j,i)+
 783      &                wturn4*gcorr4_turn(j,i)+
 784      &                wcorr5*gradcorr5(j,i)+
 785      &                wcorr6*gradcorr6(j,i)+
 786      &                wturn6*gcorr6_turn(j,i)+
 787      &                wsccor*gsccorc(j,i)
 788      &               +wscloc*gscloc(j,i)
 789      &               +wliptran*gliptranc(j,i)
 790      &                +gradafm(j,i)
 791      &                 +welec*gshieldc(j,i)
 792      &                 +welec*gshieldc_loc(j,i)
 793      &                 +wcorr*gshieldc_ec(j,i)
 794      &                 +wcorr*gshieldc_loc_ec(j,i)
 795      &                 +wturn3*gshieldc_t3(j,i)
 796      &                 +wturn3*gshieldc_loc_t3(j,i)
 797      &                 +wturn4*gshieldc_t4(j,i)
 798      &                 +wturn4*gshieldc_loc_t4(j,i)
 799      &                 +wel_loc*gshieldc_ll(j,i)
 800      &                 +wel_loc*gshieldc_loc_ll(j,i)
 801      &                +wtube*gg_tube(j,i)
 802
 803
 804 #endif
 805           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 806      &                  wbond*gradbx(j,i)+
 807      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 808      &                  wsccor*gsccorx(j,i)
 809      &                 +wscloc*gsclocx(j,i)
 810      &                 +wliptran*gliptranx(j,i)
 811      &                 +welec*gshieldx(j,i)
 812      &                 +wcorr*gshieldx_ec(j,i)
 813      &                 +wturn3*gshieldx_t3(j,i)
 814      &                 +wturn4*gshieldx_t4(j,i)
 815      &                 +wel_loc*gshieldx_ll(j,i)
 816      &                 +wtube*gg_tube_sc(j,i)
 817
 818
 819
 820         enddo
 821       enddo
 822 #ifdef DEBUG
 823       write (iout,*) "gloc before adding corr"
 824       do i=1,4*nres
 825         write (iout,*) i,gloc(i,icg)
 826       enddo
 827 #endif
 828       do i=1,nres-3
 829         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 830      &   +wcorr5*g_corr5_loc(i)
 831      &   +wcorr6*g_corr6_loc(i)
 832      &   +wturn4*gel_loc_turn4(i)
 833      &   +wturn3*gel_loc_turn3(i)
 834      &   +wturn6*gel_loc_turn6(i)
 835      &   +wel_loc*gel_loc_loc(i)
 836       enddo
 837 #ifdef DEBUG
 838       write (iout,*) "gloc after adding corr"
 839       do i=1,4*nres
 840         write (iout,*) i,gloc(i,icg)
 841       enddo
 842 #endif
 843 #ifdef MPI
 844       if (nfgtasks.gt.1) then
 845         do j=1,3
 846           do i=1,nres
 847             gradbufc(j,i)=gradc(j,i,icg)
 848             gradbufx(j,i)=gradx(j,i,icg)
 849           enddo
 850         enddo
 851         do i=1,4*nres
 852           glocbuf(i)=gloc(i,icg)
 853         enddo
 854 c#define DEBUG
 855 #ifdef DEBUG
 856       write (iout,*) "gloc_sc before reduce"
 857       do i=1,nres
 858        do j=1,1
 859         write (iout,*) i,j,gloc_sc(j,i,icg)
 860        enddo
 861       enddo
 862 #endif
 863 c#undef DEBUG
 864         do i=1,nres
 865          do j=1,3
 866           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 867          enddo
 868         enddo
 869         time00=MPI_Wtime()
 870         call MPI_Barrier(FG_COMM,IERR)
 871         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 872         time00=MPI_Wtime()
 873         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 874      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 875         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 876      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 877         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 878      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 879         time_reduce=time_reduce+MPI_Wtime()-time00
 880         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 881      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 882         time_reduce=time_reduce+MPI_Wtime()-time00
 883 c#define DEBUG
 884 #ifdef DEBUG
 885       write (iout,*) "gloc_sc after reduce"
 886       do i=1,nres
 887        do j=1,1
 888         write (iout,*) i,j,gloc_sc(j,i,icg)
 889        enddo
 890       enddo
 891 #endif
 892 c#undef DEBUG
 893 #ifdef DEBUG
 894       write (iout,*) "gloc after reduce"
 895       do i=1,4*nres
 896         write (iout,*) i,gloc(i,icg)
 897       enddo
 898 #endif
 899       endif
 900 #endif
 901       if (gnorm_check) then
 902 c
 903 c Compute the maximum elements of the gradient
 904 c
 905       gvdwc_max=0.0d0
 906       gvdwc_scp_max=0.0d0
 907       gelc_max=0.0d0
 908       gvdwpp_max=0.0d0
 909       gradb_max=0.0d0
 910       ghpbc_max=0.0d0
 911       gradcorr_max=0.0d0
 912       gel_loc_max=0.0d0
 913       gcorr3_turn_max=0.0d0
 914       gcorr4_turn_max=0.0d0
 915       gradcorr5_max=0.0d0
 916       gradcorr6_max=0.0d0
 917       gcorr6_turn_max=0.0d0
 918       gsccorc_max=0.0d0
 919       gscloc_max=0.0d0
 920       gvdwx_max=0.0d0
 921       gradx_scp_max=0.0d0
 922       ghpbx_max=0.0d0
 923       gradxorr_max=0.0d0
 924       gsccorx_max=0.0d0
 925       gsclocx_max=0.0d0
 926       do i=1,nct
 927         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 928         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 929         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 930         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 931      &   gvdwc_scp_max=gvdwc_scp_norm
 932         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 933         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 934         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 935         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 936         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 937         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 938         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 939         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 940         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 941         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 942         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 943         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 944         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 945      &    gcorr3_turn(1,i)))
 946         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 947      &    gcorr3_turn_max=gcorr3_turn_norm
 948         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 949      &    gcorr4_turn(1,i)))
 950         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 951      &    gcorr4_turn_max=gcorr4_turn_norm
 952         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 953         if (gradcorr5_norm.gt.gradcorr5_max)
 954      &    gradcorr5_max=gradcorr5_norm
 955         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 956         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 957         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 958      &    gcorr6_turn(1,i)))
 959         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 960      &    gcorr6_turn_max=gcorr6_turn_norm
 961         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 962         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 963         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 964         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 965         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 966         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 967         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 968         if (gradx_scp_norm.gt.gradx_scp_max)
 969      &    gradx_scp_max=gradx_scp_norm
 970         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 971         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 972         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 973         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 974         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 975         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 976         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 977         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 978       enddo
 979       if (gradout) then
 980 #ifdef AIX
 981         open(istat,file=statname,position="append")
 982 #else
 983         open(istat,file=statname,access="append")
 984 #endif
 985         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 986      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 987      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 988      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 989      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 990      &     gsccorx_max,gsclocx_max
 991         close(istat)
 992         if (gvdwc_max.gt.1.0d4) then
 993           write (iout,*) "gvdwc gvdwx gradb gradbx"
 994           do i=nnt,nct
 995             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 996      &        gradb(j,i),gradbx(j,i),j=1,3)
 997           enddo
 998           call pdbout(0.0d0,'cipiszcze',iout)
 999           call flush(iout)
1000         endif
1001       endif
1002       endif
1003 #ifdef DEBUG
1004       write (iout,*) "gradc gradx gloc"
1005       do i=1,nres
1006         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1007      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1008       enddo
1009 #endif
1010 #ifdef TIMING
1011       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1012 #endif
1013       return
1014       end
1015 c-------------------------------------------------------------------------------
1016       subroutine rescale_weights(t_bath)
1017       implicit real*8 (a-h,o-z)
1018       include 'DIMENSIONS'
1019       include 'COMMON.IOUNITS'
1020       include 'COMMON.FFIELD'
1021       include 'COMMON.SBRIDGE'
1022       include 'COMMON.CONTROL'
1023       double precision kfac /2.4d0/
1024       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1025 c      facT=temp0/t_bath
1026 c      facT=2*temp0/(t_bath+temp0)
1027       if (rescale_mode.eq.0) then
1028         facT=1.0d0
1029         facT2=1.0d0
1030         facT3=1.0d0
1031         facT4=1.0d0
1032         facT5=1.0d0
1033       else if (rescale_mode.eq.1) then
1034         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1035         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1036         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1037         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1038         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1039       else if (rescale_mode.eq.2) then
1040         x=t_bath/temp0
1041         x2=x*x
1042         x3=x2*x
1043         x4=x3*x
1044         x5=x4*x
1045         facT=licznik/dlog(dexp(x)+dexp(-x))
1046         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1047         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1048         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1049         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1050       else
1051         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1052         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1053 #ifdef MPI
1054        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1055 #endif
1056        stop 555
1057       endif
1058       if (shield_mode.gt.0) then
1059        wscp=weights(2)*fact
1060        wsc=weights(1)*fact
1061        wvdwpp=weights(16)*fact
1062       endif
1063       welec=weights(3)*fact
1064       wcorr=weights(4)*fact3
1065       wcorr5=weights(5)*fact4
1066       wcorr6=weights(6)*fact5
1067       wel_loc=weights(7)*fact2
1068       wturn3=weights(8)*fact2
1069       wturn4=weights(9)*fact3
1070       wturn6=weights(10)*fact5
1071       wtor=weights(13)*fact
1072       wtor_d=weights(14)*fact2
1073       wsccor=weights(21)*fact
1074
1075       return
1076       end
1077 C------------------------------------------------------------------------
1078       subroutine enerprint(energia)
1079       implicit real*8 (a-h,o-z)
1080       include 'DIMENSIONS'
1081       include 'COMMON.IOUNITS'
1082       include 'COMMON.FFIELD'
1083       include 'COMMON.SBRIDGE'
1084       include 'COMMON.MD'
1085       double precision energia(0:n_ene)
1086       etot=energia(0)
1087       evdw=energia(1)
1088       evdw2=energia(2)
1089 #ifdef SCP14
1090       evdw2=energia(2)+energia(18)
1091 #else
1092       evdw2=energia(2)
1093 #endif
1094       ees=energia(3)
1095 #ifdef SPLITELE
1096       evdw1=energia(16)
1097 #endif
1098       ecorr=energia(4)
1099       ecorr5=energia(5)
1100       ecorr6=energia(6)
1101       eel_loc=energia(7)
1102       eello_turn3=energia(8)
1103       eello_turn4=energia(9)
1104       eello_turn6=energia(10)
1105       ebe=energia(11)
1106       escloc=energia(12)
1107       etors=energia(13)
1108       etors_d=energia(14)
1109       ehpb=energia(15)
1110       edihcnstr=energia(19)
1111       estr=energia(17)
1112       Uconst=energia(20)
1113       esccor=energia(21)
1114       eliptran=energia(22)
1115       Eafmforce=energia(23)
1116       ethetacnstr=energia(24)
1117       etube=energia(25)
1118 #ifdef SPLITELE
1119       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1120      &  estr,wbond,ebe,wang,
1121      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1122      &  ecorr,wcorr,
1123      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1124      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1125      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1126      &  etube,wtube,
1127      &  etot
1128    10 format (/'Virtual-chain energies:'//
1129      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1130      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1131      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1132      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1133      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1134      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1135      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1136      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1137      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1138      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1139      & ' (SS bridges & dist. cnstr.)'/
1140      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1141      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1142      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1143      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1144      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1145      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1146      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1147      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1148      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1149      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1150      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1151      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1152      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1153      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1154      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1155      & 'ETOT=  ',1pE16.6,' (total)')
1156
1157 #else
1158       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1159      &  estr,wbond,ebe,wang,
1160      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1161      &  ecorr,wcorr,
1162      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1163      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1164      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1165      &  etube,wtube,
1166      &  etot
1167    10 format (/'Virtual-chain energies:'//
1168      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1169      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1170      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1171      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1172      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1173      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1174      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1175      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1176      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1177      & ' (SS bridges & dist. cnstr.)'/
1178      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1179      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1180      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1181      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1182      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1183      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1184      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1185      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1186      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1187      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1188      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1189      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1190      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1191      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1192      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1193      & 'ETOT=  ',1pE16.6,' (total)')
1194 #endif
1195       return
1196       end
1197 C-----------------------------------------------------------------------
1198       subroutine elj(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJ potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       parameter (accur=1.0d-10)
1206       include 'COMMON.GEO'
1207       include 'COMMON.VAR'
1208       include 'COMMON.LOCAL'
1209       include 'COMMON.CHAIN'
1210       include 'COMMON.DERIV'
1211       include 'COMMON.INTERACT'
1212       include 'COMMON.TORSION'
1213       include 'COMMON.SBRIDGE'
1214       include 'COMMON.NAMES'
1215       include 'COMMON.IOUNITS'
1216       include 'COMMON.CONTACTS'
1217       dimension gg(3)
1218 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1219       evdw=0.0D0
1220       do i=iatsc_s,iatsc_e
1221         itypi=iabs(itype(i))
1222         if (itypi.eq.ntyp1) cycle
1223         itypi1=iabs(itype(i+1))
1224         xi=c(1,nres+i)
1225         yi=c(2,nres+i)
1226         zi=c(3,nres+i)
1227 C Change 12/1/95
1228         num_conti=0
1229 C
1230 C Calculate SC interaction energy.
1231 C
1232         do iint=1,nint_gr(i)
1233 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1234 cd   &                  'iend=',iend(i,iint)
1235           do j=istart(i,iint),iend(i,iint)
1236             itypj=iabs(itype(j))
1237             if (itypj.eq.ntyp1) cycle
1238             xj=c(1,nres+j)-xi
1239             yj=c(2,nres+j)-yi
1240             zj=c(3,nres+j)-zi
1241 C Change 12/1/95 to calculate four-body interactions
1242             rij=xj*xj+yj*yj+zj*zj
1243             rrij=1.0D0/rij
1244 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1245             eps0ij=eps(itypi,itypj)
1246             fac=rrij**expon2
1247 C have you changed here?
1248             e1=fac*fac*aa
1249             e2=fac*bb
1250             evdwij=e1+e2
1251 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1252 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1253 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1254 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1255 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1256 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1257             evdw=evdw+evdwij
1258 C
1259 C Calculate the components of the gradient in DC and X
1260 C
1261             fac=-rrij*(e1+evdwij)
1262             gg(1)=xj*fac
1263             gg(2)=yj*fac
1264             gg(3)=zj*fac
1265             do k=1,3
1266               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1267               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1268               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1269               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1270             enddo
1271 cgrad            do k=i,j-1
1272 cgrad              do l=1,3
1273 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1274 cgrad              enddo
1275 cgrad            enddo
1276 C
1277 C 12/1/95, revised on 5/20/97
1278 C
1279 C Calculate the contact function. The ith column of the array JCONT will
1280 C contain the numbers of atoms that make contacts with the atom I (of numbers
1281 C greater than I). The arrays FACONT and GACONT will contain the values of
1282 C the contact function and its derivative.
1283 C
1284 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1285 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1286 C Uncomment next line, if the correlation interactions are contact function only
1287             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1288               rij=dsqrt(rij)
1289               sigij=sigma(itypi,itypj)
1290               r0ij=rs0(itypi,itypj)
1291 C
1292 C Check whether the SC's are not too far to make a contact.
1293 C
1294               rcut=1.5d0*r0ij
1295               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1296 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1297 C
1298               if (fcont.gt.0.0D0) then
1299 C If the SC-SC distance if close to sigma, apply spline.
1300 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1301 cAdam &             fcont1,fprimcont1)
1302 cAdam           fcont1=1.0d0-fcont1
1303 cAdam           if (fcont1.gt.0.0d0) then
1304 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1305 cAdam             fcont=fcont*fcont1
1306 cAdam           endif
1307 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1308 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1309 cga             do k=1,3
1310 cga               gg(k)=gg(k)*eps0ij
1311 cga             enddo
1312 cga             eps0ij=-evdwij*eps0ij
1313 C Uncomment for AL's type of SC correlation interactions.
1314 cadam           eps0ij=-evdwij
1315                 num_conti=num_conti+1
1316                 jcont(num_conti,i)=j
1317                 facont(num_conti,i)=fcont*eps0ij
1318                 fprimcont=eps0ij*fprimcont/rij
1319                 fcont=expon*fcont
1320 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1321 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1322 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1323 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1324                 gacont(1,num_conti,i)=-fprimcont*xj
1325                 gacont(2,num_conti,i)=-fprimcont*yj
1326                 gacont(3,num_conti,i)=-fprimcont*zj
1327 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1328 cd              write (iout,'(2i3,3f10.5)')
1329 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1330               endif
1331             endif
1332           enddo      ! j
1333         enddo        ! iint
1334 C Change 12/1/95
1335         num_cont(i)=num_conti
1336       enddo          ! i
1337       do i=1,nct
1338         do j=1,3
1339           gvdwc(j,i)=expon*gvdwc(j,i)
1340           gvdwx(j,i)=expon*gvdwx(j,i)
1341         enddo
1342       enddo
1343 C******************************************************************************
1344 C
1345 C                              N O T E !!!
1346 C
1347 C To save time, the factor of EXPON has been extracted from ALL components
1348 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1349 C use!
1350 C
1351 C******************************************************************************
1352       return
1353       end
1354 C-----------------------------------------------------------------------------
1355       subroutine eljk(evdw)
1356 C
1357 C This subroutine calculates the interaction energy of nonbonded side chains
1358 C assuming the LJK potential of interaction.
1359 C
1360       implicit real*8 (a-h,o-z)
1361       include 'DIMENSIONS'
1362       include 'COMMON.GEO'
1363       include 'COMMON.VAR'
1364       include 'COMMON.LOCAL'
1365       include 'COMMON.CHAIN'
1366       include 'COMMON.DERIV'
1367       include 'COMMON.INTERACT'
1368       include 'COMMON.IOUNITS'
1369       include 'COMMON.NAMES'
1370       dimension gg(3)
1371       logical scheck
1372 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1373       evdw=0.0D0
1374       do i=iatsc_s,iatsc_e
1375         itypi=iabs(itype(i))
1376         if (itypi.eq.ntyp1) cycle
1377         itypi1=iabs(itype(i+1))
1378         xi=c(1,nres+i)
1379         yi=c(2,nres+i)
1380         zi=c(3,nres+i)
1381 C
1382 C Calculate SC interaction energy.
1383 C
1384         do iint=1,nint_gr(i)
1385           do j=istart(i,iint),iend(i,iint)
1386             itypj=iabs(itype(j))
1387             if (itypj.eq.ntyp1) cycle
1388             xj=c(1,nres+j)-xi
1389             yj=c(2,nres+j)-yi
1390             zj=c(3,nres+j)-zi
1391             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1392             fac_augm=rrij**expon
1393             e_augm=augm(itypi,itypj)*fac_augm
1394             r_inv_ij=dsqrt(rrij)
1395             rij=1.0D0/r_inv_ij
1396             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1397             fac=r_shift_inv**expon
1398 C have you changed here?
1399             e1=fac*fac*aa
1400             e2=fac*bb
1401             evdwij=e_augm+e1+e2
1402 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1403 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1404 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1405 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1406 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1407 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1408 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1409             evdw=evdw+evdwij
1410 C
1411 C Calculate the components of the gradient in DC and X
1412 C
1413             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1414             gg(1)=xj*fac
1415             gg(2)=yj*fac
1416             gg(3)=zj*fac
1417             do k=1,3
1418               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1419               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1420               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1421               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1422             enddo
1423 cgrad            do k=i,j-1
1424 cgrad              do l=1,3
1425 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1426 cgrad              enddo
1427 cgrad            enddo
1428           enddo      ! j
1429         enddo        ! iint
1430       enddo          ! i
1431       do i=1,nct
1432         do j=1,3
1433           gvdwc(j,i)=expon*gvdwc(j,i)
1434           gvdwx(j,i)=expon*gvdwx(j,i)
1435         enddo
1436       enddo
1437       return
1438       end
1439 C-----------------------------------------------------------------------------
1440       subroutine ebp(evdw)
1441 C
1442 C This subroutine calculates the interaction energy of nonbonded side chains
1443 C assuming the Berne-Pechukas potential of interaction.
1444 C
1445       implicit real*8 (a-h,o-z)
1446       include 'DIMENSIONS'
1447       include 'COMMON.GEO'
1448       include 'COMMON.VAR'
1449       include 'COMMON.LOCAL'
1450       include 'COMMON.CHAIN'
1451       include 'COMMON.DERIV'
1452       include 'COMMON.NAMES'
1453       include 'COMMON.INTERACT'
1454       include 'COMMON.IOUNITS'
1455       include 'COMMON.CALC'
1456       common /srutu/ icall
1457 c     double precision rrsave(maxdim)
1458       logical lprn
1459       evdw=0.0D0
1460 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1461       evdw=0.0D0
1462 c     if (icall.eq.0) then
1463 c       lprn=.true.
1464 c     else
1465         lprn=.false.
1466 c     endif
1467       ind=0
1468       do i=iatsc_s,iatsc_e
1469         itypi=iabs(itype(i))
1470         if (itypi.eq.ntyp1) cycle
1471         itypi1=iabs(itype(i+1))
1472         xi=c(1,nres+i)
1473         yi=c(2,nres+i)
1474         zi=c(3,nres+i)
1475         dxi=dc_norm(1,nres+i)
1476         dyi=dc_norm(2,nres+i)
1477         dzi=dc_norm(3,nres+i)
1478 c        dsci_inv=dsc_inv(itypi)
1479         dsci_inv=vbld_inv(i+nres)
1480 C
1481 C Calculate SC interaction energy.
1482 C
1483         do iint=1,nint_gr(i)
1484           do j=istart(i,iint),iend(i,iint)
1485             ind=ind+1
1486             itypj=iabs(itype(j))
1487             if (itypj.eq.ntyp1) cycle
1488 c            dscj_inv=dsc_inv(itypj)
1489             dscj_inv=vbld_inv(j+nres)
1490             chi1=chi(itypi,itypj)
1491             chi2=chi(itypj,itypi)
1492             chi12=chi1*chi2
1493             chip1=chip(itypi)
1494             chip2=chip(itypj)
1495             chip12=chip1*chip2
1496             alf1=alp(itypi)
1497             alf2=alp(itypj)
1498             alf12=0.5D0*(alf1+alf2)
1499 C For diagnostics only!!!
1500 c           chi1=0.0D0
1501 c           chi2=0.0D0
1502 c           chi12=0.0D0
1503 c           chip1=0.0D0
1504 c           chip2=0.0D0
1505 c           chip12=0.0D0
1506 c           alf1=0.0D0
1507 c           alf2=0.0D0
1508 c           alf12=0.0D0
1509             xj=c(1,nres+j)-xi
1510             yj=c(2,nres+j)-yi
1511             zj=c(3,nres+j)-zi
1512             dxj=dc_norm(1,nres+j)
1513             dyj=dc_norm(2,nres+j)
1514             dzj=dc_norm(3,nres+j)
1515             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1516 cd          if (icall.eq.0) then
1517 cd            rrsave(ind)=rrij
1518 cd          else
1519 cd            rrij=rrsave(ind)
1520 cd          endif
1521             rij=dsqrt(rrij)
1522 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1523             call sc_angular
1524 C Calculate whole angle-dependent part of epsilon and contributions
1525 C to its derivatives
1526 C have you changed here?
1527             fac=(rrij*sigsq)**expon2
1528             e1=fac*fac*aa
1529             e2=fac*bb
1530             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1531             eps2der=evdwij*eps3rt
1532             eps3der=evdwij*eps2rt
1533             evdwij=evdwij*eps2rt*eps3rt
1534             evdw=evdw+evdwij
1535             if (lprn) then
1536             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1537             epsi=bb**2/aa
1538 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1539 cd     &        restyp(itypi),i,restyp(itypj),j,
1540 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1541 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1542 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1543 cd     &        evdwij
1544             endif
1545 C Calculate gradient components.
1546             e1=e1*eps1*eps2rt**2*eps3rt**2
1547             fac=-expon*(e1+evdwij)
1548             sigder=fac/sigsq
1549             fac=rrij*fac
1550 C Calculate radial part of the gradient
1551             gg(1)=xj*fac
1552             gg(2)=yj*fac
1553             gg(3)=zj*fac
1554 C Calculate the angular part of the gradient and sum add the contributions
1555 C to the appropriate components of the Cartesian gradient.
1556             call sc_grad
1557           enddo      ! j
1558         enddo        ! iint
1559       enddo          ! i
1560 c     stop
1561       return
1562       end
1563 C-----------------------------------------------------------------------------
1564       subroutine egb(evdw)
1565 C
1566 C This subroutine calculates the interaction energy of nonbonded side chains
1567 C assuming the Gay-Berne potential of interaction.
1568 C
1569       implicit real*8 (a-h,o-z)
1570       include 'DIMENSIONS'
1571       include 'COMMON.GEO'
1572       include 'COMMON.VAR'
1573       include 'COMMON.LOCAL'
1574       include 'COMMON.CHAIN'
1575       include 'COMMON.DERIV'
1576       include 'COMMON.NAMES'
1577       include 'COMMON.INTERACT'
1578       include 'COMMON.IOUNITS'
1579       include 'COMMON.CALC'
1580       include 'COMMON.CONTROL'
1581       include 'COMMON.SPLITELE'
1582       include 'COMMON.SBRIDGE'
1583       logical lprn
1584       integer xshift,yshift,zshift
1585
1586       evdw=0.0D0
1587 ccccc      energy_dec=.false.
1588 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1589       evdw=0.0D0
1590       lprn=.false.
1591 c     if (icall.eq.0) lprn=.false.
1592       ind=0
1593 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1594 C we have the original box)
1595 C      do xshift=-1,1
1596 C      do yshift=-1,1
1597 C      do zshift=-1,1
1598       do i=iatsc_s,iatsc_e
1599         itypi=iabs(itype(i))
1600         if (itypi.eq.ntyp1) cycle
1601         itypi1=iabs(itype(i+1))
1602         xi=c(1,nres+i)
1603         yi=c(2,nres+i)
1604         zi=c(3,nres+i)
1605 C Return atom into box, boxxsize is size of box in x dimension
1606 c  134   continue
1607 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1608 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1609 C Condition for being inside the proper box
1610 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1611 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1612 c        go to 134
1613 c        endif
1614 c  135   continue
1615 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1616 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1617 C Condition for being inside the proper box
1618 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1619 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1620 c        go to 135
1621 c        endif
1622 c  136   continue
1623 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1624 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1625 C Condition for being inside the proper box
1626 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1627 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1628 c        go to 136
1629 c        endif
1630           xi=mod(xi,boxxsize)
1631           if (xi.lt.0) xi=xi+boxxsize
1632           yi=mod(yi,boxysize)
1633           if (yi.lt.0) yi=yi+boxysize
1634           zi=mod(zi,boxzsize)
1635           if (zi.lt.0) zi=zi+boxzsize
1636 C define scaling factor for lipids
1637
1638 C        if (positi.le.0) positi=positi+boxzsize
1639 C        print *,i
1640 C first for peptide groups
1641 c for each residue check if it is in lipid or lipid water border area
1642        if ((zi.gt.bordlipbot)
1643      &.and.(zi.lt.bordliptop)) then
1644 C the energy transfer exist
1645         if (zi.lt.buflipbot) then
1646 C what fraction I am in
1647          fracinbuf=1.0d0-
1648      &        ((zi-bordlipbot)/lipbufthick)
1649 C lipbufthick is thickenes of lipid buffore
1650          sslipi=sscalelip(fracinbuf)
1651          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1652         elseif (zi.gt.bufliptop) then
1653          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1654          sslipi=sscalelip(fracinbuf)
1655          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1656         else
1657          sslipi=1.0d0
1658          ssgradlipi=0.0
1659         endif
1660        else
1661          sslipi=0.0d0
1662          ssgradlipi=0.0
1663        endif
1664
1665 C          xi=xi+xshift*boxxsize
1666 C          yi=yi+yshift*boxysize
1667 C          zi=zi+zshift*boxzsize
1668
1669         dxi=dc_norm(1,nres+i)
1670         dyi=dc_norm(2,nres+i)
1671         dzi=dc_norm(3,nres+i)
1672 c        dsci_inv=dsc_inv(itypi)
1673         dsci_inv=vbld_inv(i+nres)
1674 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1675 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1676 C
1677 C Calculate SC interaction energy.
1678 C
1679         do iint=1,nint_gr(i)
1680           do j=istart(i,iint),iend(i,iint)
1681             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1682
1683 c              write(iout,*) "PRZED ZWYKLE", evdwij
1684               call dyn_ssbond_ene(i,j,evdwij)
1685 c              write(iout,*) "PO ZWYKLE", evdwij
1686
1687               evdw=evdw+evdwij
1688               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1689      &                        'evdw',i,j,evdwij,' ss'
1690 C triple bond artifac removal
1691              do k=j+1,iend(i,iint)
1692 C search over all next residues
1693               if (dyn_ss_mask(k)) then
1694 C check if they are cysteins
1695 C              write(iout,*) 'k=',k
1696
1697 c              write(iout,*) "PRZED TRI", evdwij
1698                evdwij_przed_tri=evdwij
1699               call triple_ssbond_ene(i,j,k,evdwij)
1700 c               if(evdwij_przed_tri.ne.evdwij) then
1701 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1702 c               endif
1703
1704 c              write(iout,*) "PO TRI", evdwij
1705 C call the energy function that removes the artifical triple disulfide
1706 C bond the soubroutine is located in ssMD.F
1707               evdw=evdw+evdwij
1708               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1709      &                        'evdw',i,j,evdwij,'tss'
1710               endif!dyn_ss_mask(k)
1711              enddo! k
1712             ELSE
1713             ind=ind+1
1714             itypj=iabs(itype(j))
1715             if (itypj.eq.ntyp1) cycle
1716 c            dscj_inv=dsc_inv(itypj)
1717             dscj_inv=vbld_inv(j+nres)
1718 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1719 c     &       1.0d0/vbld(j+nres)
1720 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1721             sig0ij=sigma(itypi,itypj)
1722             chi1=chi(itypi,itypj)
1723             chi2=chi(itypj,itypi)
1724             chi12=chi1*chi2
1725             chip1=chip(itypi)
1726             chip2=chip(itypj)
1727             chip12=chip1*chip2
1728             alf1=alp(itypi)
1729             alf2=alp(itypj)
1730             alf12=0.5D0*(alf1+alf2)
1731 C For diagnostics only!!!
1732 c           chi1=0.0D0
1733 c           chi2=0.0D0
1734 c           chi12=0.0D0
1735 c           chip1=0.0D0
1736 c           chip2=0.0D0
1737 c           chip12=0.0D0
1738 c           alf1=0.0D0
1739 c           alf2=0.0D0
1740 c           alf12=0.0D0
1741             xj=c(1,nres+j)
1742             yj=c(2,nres+j)
1743             zj=c(3,nres+j)
1744 C Return atom J into box the original box
1745 c  137   continue
1746 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1747 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1748 C Condition for being inside the proper box
1749 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1750 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1751 c        go to 137
1752 c        endif
1753 c  138   continue
1754 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1755 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1756 C Condition for being inside the proper box
1757 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1758 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1759 c        go to 138
1760 c        endif
1761 c  139   continue
1762 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1763 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1764 C Condition for being inside the proper box
1765 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1766 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1767 c        go to 139
1768 c        endif
1769           xj=mod(xj,boxxsize)
1770           if (xj.lt.0) xj=xj+boxxsize
1771           yj=mod(yj,boxysize)
1772           if (yj.lt.0) yj=yj+boxysize
1773           zj=mod(zj,boxzsize)
1774           if (zj.lt.0) zj=zj+boxzsize
1775        if ((zj.gt.bordlipbot)
1776      &.and.(zj.lt.bordliptop)) then
1777 C the energy transfer exist
1778         if (zj.lt.buflipbot) then
1779 C what fraction I am in
1780          fracinbuf=1.0d0-
1781      &        ((zj-bordlipbot)/lipbufthick)
1782 C lipbufthick is thickenes of lipid buffore
1783          sslipj=sscalelip(fracinbuf)
1784          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1785         elseif (zj.gt.bufliptop) then
1786          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1787          sslipj=sscalelip(fracinbuf)
1788          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1789         else
1790          sslipj=1.0d0
1791          ssgradlipj=0.0
1792         endif
1793        else
1794          sslipj=0.0d0
1795          ssgradlipj=0.0
1796        endif
1797       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1798      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1799       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1800      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1801 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1802 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1803 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1804 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1805 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1806       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1807       xj_safe=xj
1808       yj_safe=yj
1809       zj_safe=zj
1810       subchap=0
1811       do xshift=-1,1
1812       do yshift=-1,1
1813       do zshift=-1,1
1814           xj=xj_safe+xshift*boxxsize
1815           yj=yj_safe+yshift*boxysize
1816           zj=zj_safe+zshift*boxzsize
1817           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1818           if(dist_temp.lt.dist_init) then
1819             dist_init=dist_temp
1820             xj_temp=xj
1821             yj_temp=yj
1822             zj_temp=zj
1823             subchap=1
1824           endif
1825        enddo
1826        enddo
1827        enddo
1828        if (subchap.eq.1) then
1829           xj=xj_temp-xi
1830           yj=yj_temp-yi
1831           zj=zj_temp-zi
1832        else
1833           xj=xj_safe-xi
1834           yj=yj_safe-yi
1835           zj=zj_safe-zi
1836        endif
1837             dxj=dc_norm(1,nres+j)
1838             dyj=dc_norm(2,nres+j)
1839             dzj=dc_norm(3,nres+j)
1840 C            xj=xj-xi
1841 C            yj=yj-yi
1842 C            zj=zj-zi
1843 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1844 c            write (iout,*) "j",j," dc_norm",
1845 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1846             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1847             rij=dsqrt(rrij)
1848             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1849             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1850
1851 c            write (iout,'(a7,4f8.3)')
1852 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1853             if (sss.gt.0.0d0) then
1854 C Calculate angle-dependent terms of energy and contributions to their
1855 C derivatives.
1856             call sc_angular
1857             sigsq=1.0D0/sigsq
1858             sig=sig0ij*dsqrt(sigsq)
1859             rij_shift=1.0D0/rij-sig+sig0ij
1860 c for diagnostics; uncomment
1861 c            rij_shift=1.2*sig0ij
1862 C I hate to put IF's in the loops, but here don't have another choice!!!!
1863             if (rij_shift.le.0.0D0) then
1864               evdw=1.0D20
1865 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1866 cd     &        restyp(itypi),i,restyp(itypj),j,
1867 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1868               return
1869             endif
1870             sigder=-sig*sigsq
1871 c---------------------------------------------------------------
1872             rij_shift=1.0D0/rij_shift
1873             fac=rij_shift**expon
1874 C here to start with
1875 C            if (c(i,3).gt.
1876             faclip=fac
1877             e1=fac*fac*aa
1878             e2=fac*bb
1879             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1880             eps2der=evdwij*eps3rt
1881             eps3der=evdwij*eps2rt
1882 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1883 C     &((sslipi+sslipj)/2.0d0+
1884 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1885 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1886 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1887             evdwij=evdwij*eps2rt*eps3rt
1888             evdw=evdw+evdwij*sss
1889             if (lprn) then
1890             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1891             epsi=bb**2/aa
1892             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1893      &        restyp(itypi),i,restyp(itypj),j,
1894      &        epsi,sigm,chi1,chi2,chip1,chip2,
1895      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1896      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1897      &        evdwij
1898             endif
1899
1900             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1901      &                        'evdw',i,j,evdwij
1902
1903 C Calculate gradient components.
1904             e1=e1*eps1*eps2rt**2*eps3rt**2
1905             fac=-expon*(e1+evdwij)*rij_shift
1906             sigder=fac*sigder
1907             fac=rij*fac
1908 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1909 c     &      evdwij,fac,sigma(itypi,itypj),expon
1910             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1911 c            fac=0.0d0
1912 C Calculate the radial part of the gradient
1913             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1914      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1915      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1916      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1917             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1918             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1919 C            gg_lipi(3)=0.0d0
1920 C            gg_lipj(3)=0.0d0
1921             gg(1)=xj*fac
1922             gg(2)=yj*fac
1923             gg(3)=zj*fac
1924 C Calculate angular part of the gradient.
1925             call sc_grad
1926             endif
1927             ENDIF    ! dyn_ss
1928           enddo      ! j
1929         enddo        ! iint
1930       enddo          ! i
1931 C      enddo          ! zshift
1932 C      enddo          ! yshift
1933 C      enddo          ! xshift
1934 c      write (iout,*) "Number of loop steps in EGB:",ind
1935 cccc      energy_dec=.false.
1936       return
1937       end
1938 C-----------------------------------------------------------------------------
1939       subroutine egbv(evdw)
1940 C
1941 C This subroutine calculates the interaction energy of nonbonded side chains
1942 C assuming the Gay-Berne-Vorobjev potential of interaction.
1943 C
1944       implicit real*8 (a-h,o-z)
1945       include 'DIMENSIONS'
1946       include 'COMMON.GEO'
1947       include 'COMMON.VAR'
1948       include 'COMMON.LOCAL'
1949       include 'COMMON.CHAIN'
1950       include 'COMMON.DERIV'
1951       include 'COMMON.NAMES'
1952       include 'COMMON.INTERACT'
1953       include 'COMMON.IOUNITS'
1954       include 'COMMON.CALC'
1955       common /srutu/ icall
1956       logical lprn
1957       evdw=0.0D0
1958 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1959       evdw=0.0D0
1960       lprn=.false.
1961 c     if (icall.eq.0) lprn=.true.
1962       ind=0
1963       do i=iatsc_s,iatsc_e
1964         itypi=iabs(itype(i))
1965         if (itypi.eq.ntyp1) cycle
1966         itypi1=iabs(itype(i+1))
1967         xi=c(1,nres+i)
1968         yi=c(2,nres+i)
1969         zi=c(3,nres+i)
1970           xi=mod(xi,boxxsize)
1971           if (xi.lt.0) xi=xi+boxxsize
1972           yi=mod(yi,boxysize)
1973           if (yi.lt.0) yi=yi+boxysize
1974           zi=mod(zi,boxzsize)
1975           if (zi.lt.0) zi=zi+boxzsize
1976 C define scaling factor for lipids
1977
1978 C        if (positi.le.0) positi=positi+boxzsize
1979 C        print *,i
1980 C first for peptide groups
1981 c for each residue check if it is in lipid or lipid water border area
1982        if ((zi.gt.bordlipbot)
1983      &.and.(zi.lt.bordliptop)) then
1984 C the energy transfer exist
1985         if (zi.lt.buflipbot) then
1986 C what fraction I am in
1987          fracinbuf=1.0d0-
1988      &        ((zi-bordlipbot)/lipbufthick)
1989 C lipbufthick is thickenes of lipid buffore
1990          sslipi=sscalelip(fracinbuf)
1991          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1992         elseif (zi.gt.bufliptop) then
1993          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1994          sslipi=sscalelip(fracinbuf)
1995          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1996         else
1997          sslipi=1.0d0
1998          ssgradlipi=0.0
1999         endif
2000        else
2001          sslipi=0.0d0
2002          ssgradlipi=0.0
2003        endif
2004
2005         dxi=dc_norm(1,nres+i)
2006         dyi=dc_norm(2,nres+i)
2007         dzi=dc_norm(3,nres+i)
2008 c        dsci_inv=dsc_inv(itypi)
2009         dsci_inv=vbld_inv(i+nres)
2010 C
2011 C Calculate SC interaction energy.
2012 C
2013         do iint=1,nint_gr(i)
2014           do j=istart(i,iint),iend(i,iint)
2015             ind=ind+1
2016             itypj=iabs(itype(j))
2017             if (itypj.eq.ntyp1) cycle
2018 c            dscj_inv=dsc_inv(itypj)
2019             dscj_inv=vbld_inv(j+nres)
2020             sig0ij=sigma(itypi,itypj)
2021             r0ij=r0(itypi,itypj)
2022             chi1=chi(itypi,itypj)
2023             chi2=chi(itypj,itypi)
2024             chi12=chi1*chi2
2025             chip1=chip(itypi)
2026             chip2=chip(itypj)
2027             chip12=chip1*chip2
2028             alf1=alp(itypi)
2029             alf2=alp(itypj)
2030             alf12=0.5D0*(alf1+alf2)
2031 C For diagnostics only!!!
2032 c           chi1=0.0D0
2033 c           chi2=0.0D0
2034 c           chi12=0.0D0
2035 c           chip1=0.0D0
2036 c           chip2=0.0D0
2037 c           chip12=0.0D0
2038 c           alf1=0.0D0
2039 c           alf2=0.0D0
2040 c           alf12=0.0D0
2041 C            xj=c(1,nres+j)-xi
2042 C            yj=c(2,nres+j)-yi
2043 C            zj=c(3,nres+j)-zi
2044           xj=mod(xj,boxxsize)
2045           if (xj.lt.0) xj=xj+boxxsize
2046           yj=mod(yj,boxysize)
2047           if (yj.lt.0) yj=yj+boxysize
2048           zj=mod(zj,boxzsize)
2049           if (zj.lt.0) zj=zj+boxzsize
2050        if ((zj.gt.bordlipbot)
2051      &.and.(zj.lt.bordliptop)) then
2052 C the energy transfer exist
2053         if (zj.lt.buflipbot) then
2054 C what fraction I am in
2055          fracinbuf=1.0d0-
2056      &        ((zj-bordlipbot)/lipbufthick)
2057 C lipbufthick is thickenes of lipid buffore
2058          sslipj=sscalelip(fracinbuf)
2059          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2060         elseif (zj.gt.bufliptop) then
2061          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2062          sslipj=sscalelip(fracinbuf)
2063          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2064         else
2065          sslipj=1.0d0
2066          ssgradlipj=0.0
2067         endif
2068        else
2069          sslipj=0.0d0
2070          ssgradlipj=0.0
2071        endif
2072       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2073      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2074       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2075      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2076 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2077 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2078 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2079       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2080       xj_safe=xj
2081       yj_safe=yj
2082       zj_safe=zj
2083       subchap=0
2084       do xshift=-1,1
2085       do yshift=-1,1
2086       do zshift=-1,1
2087           xj=xj_safe+xshift*boxxsize
2088           yj=yj_safe+yshift*boxysize
2089           zj=zj_safe+zshift*boxzsize
2090           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2091           if(dist_temp.lt.dist_init) then
2092             dist_init=dist_temp
2093             xj_temp=xj
2094             yj_temp=yj
2095             zj_temp=zj
2096             subchap=1
2097           endif
2098        enddo
2099        enddo
2100        enddo
2101        if (subchap.eq.1) then
2102           xj=xj_temp-xi
2103           yj=yj_temp-yi
2104           zj=zj_temp-zi
2105        else
2106           xj=xj_safe-xi
2107           yj=yj_safe-yi
2108           zj=zj_safe-zi
2109        endif
2110             dxj=dc_norm(1,nres+j)
2111             dyj=dc_norm(2,nres+j)
2112             dzj=dc_norm(3,nres+j)
2113             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2114             rij=dsqrt(rrij)
2115 C Calculate angle-dependent terms of energy and contributions to their
2116 C derivatives.
2117             call sc_angular
2118             sigsq=1.0D0/sigsq
2119             sig=sig0ij*dsqrt(sigsq)
2120             rij_shift=1.0D0/rij-sig+r0ij
2121 C I hate to put IF's in the loops, but here don't have another choice!!!!
2122             if (rij_shift.le.0.0D0) then
2123               evdw=1.0D20
2124               return
2125             endif
2126             sigder=-sig*sigsq
2127 c---------------------------------------------------------------
2128             rij_shift=1.0D0/rij_shift
2129             fac=rij_shift**expon
2130             e1=fac*fac*aa
2131             e2=fac*bb
2132             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2133             eps2der=evdwij*eps3rt
2134             eps3der=evdwij*eps2rt
2135             fac_augm=rrij**expon
2136             e_augm=augm(itypi,itypj)*fac_augm
2137             evdwij=evdwij*eps2rt*eps3rt
2138             evdw=evdw+evdwij+e_augm
2139             if (lprn) then
2140             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2141             epsi=bb**2/aa
2142             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2143      &        restyp(itypi),i,restyp(itypj),j,
2144      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2145      &        chi1,chi2,chip1,chip2,
2146      &        eps1,eps2rt**2,eps3rt**2,
2147      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2148      &        evdwij+e_augm
2149             endif
2150 C Calculate gradient components.
2151             e1=e1*eps1*eps2rt**2*eps3rt**2
2152             fac=-expon*(e1+evdwij)*rij_shift
2153             sigder=fac*sigder
2154             fac=rij*fac-2*expon*rrij*e_augm
2155             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2156 C Calculate the radial part of the gradient
2157             gg(1)=xj*fac
2158             gg(2)=yj*fac
2159             gg(3)=zj*fac
2160 C Calculate angular part of the gradient.
2161             call sc_grad
2162           enddo      ! j
2163         enddo        ! iint
2164       enddo          ! i
2165       end
2166 C-----------------------------------------------------------------------------
2167       subroutine sc_angular
2168 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2169 C om12. Called by ebp, egb, and egbv.
2170       implicit none
2171       include 'COMMON.CALC'
2172       include 'COMMON.IOUNITS'
2173       erij(1)=xj*rij
2174       erij(2)=yj*rij
2175       erij(3)=zj*rij
2176       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2177       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2178       om12=dxi*dxj+dyi*dyj+dzi*dzj
2179       chiom12=chi12*om12
2180 C Calculate eps1(om12) and its derivative in om12
2181       faceps1=1.0D0-om12*chiom12
2182       faceps1_inv=1.0D0/faceps1
2183       eps1=dsqrt(faceps1_inv)
2184 C Following variable is eps1*deps1/dom12
2185       eps1_om12=faceps1_inv*chiom12
2186 c diagnostics only
2187 c      faceps1_inv=om12
2188 c      eps1=om12
2189 c      eps1_om12=1.0d0
2190 c      write (iout,*) "om12",om12," eps1",eps1
2191 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2192 C and om12.
2193       om1om2=om1*om2
2194       chiom1=chi1*om1
2195       chiom2=chi2*om2
2196       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2197       sigsq=1.0D0-facsig*faceps1_inv
2198       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2199       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2200       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2201 c diagnostics only
2202 c      sigsq=1.0d0
2203 c      sigsq_om1=0.0d0
2204 c      sigsq_om2=0.0d0
2205 c      sigsq_om12=0.0d0
2206 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2207 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2208 c     &    " eps1",eps1
2209 C Calculate eps2 and its derivatives in om1, om2, and om12.
2210       chipom1=chip1*om1
2211       chipom2=chip2*om2
2212       chipom12=chip12*om12
2213       facp=1.0D0-om12*chipom12
2214       facp_inv=1.0D0/facp
2215       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2216 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2217 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2218 C Following variable is the square root of eps2
2219       eps2rt=1.0D0-facp1*facp_inv
2220 C Following three variables are the derivatives of the square root of eps
2221 C in om1, om2, and om12.
2222       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2223       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2224       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2225 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2226       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2227 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2228 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2229 c     &  " eps2rt_om12",eps2rt_om12
2230 C Calculate whole angle-dependent part of epsilon and contributions
2231 C to its derivatives
2232       return
2233       end
2234 C----------------------------------------------------------------------------
2235       subroutine sc_grad
2236       implicit real*8 (a-h,o-z)
2237       include 'DIMENSIONS'
2238       include 'COMMON.CHAIN'
2239       include 'COMMON.DERIV'
2240       include 'COMMON.CALC'
2241       include 'COMMON.IOUNITS'
2242       double precision dcosom1(3),dcosom2(3)
2243 cc      print *,'sss=',sss
2244       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2245       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2246       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2247      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2248 c diagnostics only
2249 c      eom1=0.0d0
2250 c      eom2=0.0d0
2251 c      eom12=evdwij*eps1_om12
2252 c end diagnostics
2253 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2254 c     &  " sigder",sigder
2255 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2256 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2257       do k=1,3
2258         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2259         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2260       enddo
2261       do k=1,3
2262         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2263       enddo
2264 c      write (iout,*) "gg",(gg(k),k=1,3)
2265       do k=1,3
2266         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2267      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2268      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2269         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2270      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2271      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2272 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2273 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2274 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2275 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2276       enddo
2277 C
2278 C Calculate the components of the gradient in DC and X
2279 C
2280 cgrad      do k=i,j-1
2281 cgrad        do l=1,3
2282 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2283 cgrad        enddo
2284 cgrad      enddo
2285       do l=1,3
2286         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2287         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2288       enddo
2289       return
2290       end
2291 C-----------------------------------------------------------------------
2292       subroutine e_softsphere(evdw)
2293 C
2294 C This subroutine calculates the interaction energy of nonbonded side chains
2295 C assuming the LJ potential of interaction.
2296 C
2297       implicit real*8 (a-h,o-z)
2298       include 'DIMENSIONS'
2299       parameter (accur=1.0d-10)
2300       include 'COMMON.GEO'
2301       include 'COMMON.VAR'
2302       include 'COMMON.LOCAL'
2303       include 'COMMON.CHAIN'
2304       include 'COMMON.DERIV'
2305       include 'COMMON.INTERACT'
2306       include 'COMMON.TORSION'
2307       include 'COMMON.SBRIDGE'
2308       include 'COMMON.NAMES'
2309       include 'COMMON.IOUNITS'
2310       include 'COMMON.CONTACTS'
2311       dimension gg(3)
2312 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2313       evdw=0.0D0
2314       do i=iatsc_s,iatsc_e
2315         itypi=iabs(itype(i))
2316         if (itypi.eq.ntyp1) cycle
2317         itypi1=iabs(itype(i+1))
2318         xi=c(1,nres+i)
2319         yi=c(2,nres+i)
2320         zi=c(3,nres+i)
2321 C
2322 C Calculate SC interaction energy.
2323 C
2324         do iint=1,nint_gr(i)
2325 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2326 cd   &                  'iend=',iend(i,iint)
2327           do j=istart(i,iint),iend(i,iint)
2328             itypj=iabs(itype(j))
2329             if (itypj.eq.ntyp1) cycle
2330             xj=c(1,nres+j)-xi
2331             yj=c(2,nres+j)-yi
2332             zj=c(3,nres+j)-zi
2333             rij=xj*xj+yj*yj+zj*zj
2334 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2335             r0ij=r0(itypi,itypj)
2336             r0ijsq=r0ij*r0ij
2337 c            print *,i,j,r0ij,dsqrt(rij)
2338             if (rij.lt.r0ijsq) then
2339               evdwij=0.25d0*(rij-r0ijsq)**2
2340               fac=rij-r0ijsq
2341             else
2342               evdwij=0.0d0
2343               fac=0.0d0
2344             endif
2345             evdw=evdw+evdwij
2346 C
2347 C Calculate the components of the gradient in DC and X
2348 C
2349             gg(1)=xj*fac
2350             gg(2)=yj*fac
2351             gg(3)=zj*fac
2352             do k=1,3
2353               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2354               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2355               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2356               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2357             enddo
2358 cgrad            do k=i,j-1
2359 cgrad              do l=1,3
2360 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2361 cgrad              enddo
2362 cgrad            enddo
2363           enddo ! j
2364         enddo ! iint
2365       enddo ! i
2366       return
2367       end
2368 C--------------------------------------------------------------------------
2369       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2370      &              eello_turn4)
2371 C
2372 C Soft-sphere potential of p-p interaction
2373 C
2374       implicit real*8 (a-h,o-z)
2375       include 'DIMENSIONS'
2376       include 'COMMON.CONTROL'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.DERIV'
2383       include 'COMMON.INTERACT'
2384       include 'COMMON.CONTACTS'
2385       include 'COMMON.TORSION'
2386       include 'COMMON.VECTORS'
2387       include 'COMMON.FFIELD'
2388       dimension ggg(3)
2389 C      write(iout,*) 'In EELEC_soft_sphere'
2390       ees=0.0D0
2391       evdw1=0.0D0
2392       eel_loc=0.0d0
2393       eello_turn3=0.0d0
2394       eello_turn4=0.0d0
2395       ind=0
2396       do i=iatel_s,iatel_e
2397         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2398         dxi=dc(1,i)
2399         dyi=dc(2,i)
2400         dzi=dc(3,i)
2401         xmedi=c(1,i)+0.5d0*dxi
2402         ymedi=c(2,i)+0.5d0*dyi
2403         zmedi=c(3,i)+0.5d0*dzi
2404           xmedi=mod(xmedi,boxxsize)
2405           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2406           ymedi=mod(ymedi,boxysize)
2407           if (ymedi.lt.0) ymedi=ymedi+boxysize
2408           zmedi=mod(zmedi,boxzsize)
2409           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2410         num_conti=0
2411 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2412         do j=ielstart(i),ielend(i)
2413           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2414           ind=ind+1
2415           iteli=itel(i)
2416           itelj=itel(j)
2417           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2418           r0ij=rpp(iteli,itelj)
2419           r0ijsq=r0ij*r0ij
2420           dxj=dc(1,j)
2421           dyj=dc(2,j)
2422           dzj=dc(3,j)
2423           xj=c(1,j)+0.5D0*dxj
2424           yj=c(2,j)+0.5D0*dyj
2425           zj=c(3,j)+0.5D0*dzj
2426           xj=mod(xj,boxxsize)
2427           if (xj.lt.0) xj=xj+boxxsize
2428           yj=mod(yj,boxysize)
2429           if (yj.lt.0) yj=yj+boxysize
2430           zj=mod(zj,boxzsize)
2431           if (zj.lt.0) zj=zj+boxzsize
2432       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2433       xj_safe=xj
2434       yj_safe=yj
2435       zj_safe=zj
2436       isubchap=0
2437       do xshift=-1,1
2438       do yshift=-1,1
2439       do zshift=-1,1
2440           xj=xj_safe+xshift*boxxsize
2441           yj=yj_safe+yshift*boxysize
2442           zj=zj_safe+zshift*boxzsize
2443           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2444           if(dist_temp.lt.dist_init) then
2445             dist_init=dist_temp
2446             xj_temp=xj
2447             yj_temp=yj
2448             zj_temp=zj
2449             isubchap=1
2450           endif
2451        enddo
2452        enddo
2453        enddo
2454        if (isubchap.eq.1) then
2455           xj=xj_temp-xmedi
2456           yj=yj_temp-ymedi
2457           zj=zj_temp-zmedi
2458        else
2459           xj=xj_safe-xmedi
2460           yj=yj_safe-ymedi
2461           zj=zj_safe-zmedi
2462        endif
2463           rij=xj*xj+yj*yj+zj*zj
2464             sss=sscale(sqrt(rij))
2465             sssgrad=sscagrad(sqrt(rij))
2466           if (rij.lt.r0ijsq) then
2467             evdw1ij=0.25d0*(rij-r0ijsq)**2
2468             fac=rij-r0ijsq
2469           else
2470             evdw1ij=0.0d0
2471             fac=0.0d0
2472           endif
2473           evdw1=evdw1+evdw1ij*sss
2474 C
2475 C Calculate contributions to the Cartesian gradient.
2476 C
2477           ggg(1)=fac*xj*sssgrad
2478           ggg(2)=fac*yj*sssgrad
2479           ggg(3)=fac*zj*sssgrad
2480           do k=1,3
2481             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2482             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2483           enddo
2484 *
2485 * Loop over residues i+1 thru j-1.
2486 *
2487 cgrad          do k=i+1,j-1
2488 cgrad            do l=1,3
2489 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2490 cgrad            enddo
2491 cgrad          enddo
2492         enddo ! j
2493       enddo   ! i
2494 cgrad      do i=nnt,nct-1
2495 cgrad        do k=1,3
2496 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2497 cgrad        enddo
2498 cgrad        do j=i+1,nct-1
2499 cgrad          do k=1,3
2500 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2501 cgrad          enddo
2502 cgrad        enddo
2503 cgrad      enddo
2504       return
2505       end
2506 c------------------------------------------------------------------------------
2507       subroutine vec_and_deriv
2508       implicit real*8 (a-h,o-z)
2509       include 'DIMENSIONS'
2510 #ifdef MPI
2511       include 'mpif.h'
2512 #endif
2513       include 'COMMON.IOUNITS'
2514       include 'COMMON.GEO'
2515       include 'COMMON.VAR'
2516       include 'COMMON.LOCAL'
2517       include 'COMMON.CHAIN'
2518       include 'COMMON.VECTORS'
2519       include 'COMMON.SETUP'
2520       include 'COMMON.TIME1'
2521       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2522 C Compute the local reference systems. For reference system (i), the
2523 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2524 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2525 #ifdef PARVEC
2526       do i=ivec_start,ivec_end
2527 #else
2528       do i=1,nres-1
2529 #endif
2530           if (i.eq.nres-1) then
2531 C Case of the last full residue
2532 C Compute the Z-axis
2533             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2534             costh=dcos(pi-theta(nres))
2535             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2536             do k=1,3
2537               uz(k,i)=fac*uz(k,i)
2538             enddo
2539 C Compute the derivatives of uz
2540             uzder(1,1,1)= 0.0d0
2541             uzder(2,1,1)=-dc_norm(3,i-1)
2542             uzder(3,1,1)= dc_norm(2,i-1)
2543             uzder(1,2,1)= dc_norm(3,i-1)
2544             uzder(2,2,1)= 0.0d0
2545             uzder(3,2,1)=-dc_norm(1,i-1)
2546             uzder(1,3,1)=-dc_norm(2,i-1)
2547             uzder(2,3,1)= dc_norm(1,i-1)
2548             uzder(3,3,1)= 0.0d0
2549             uzder(1,1,2)= 0.0d0
2550             uzder(2,1,2)= dc_norm(3,i)
2551             uzder(3,1,2)=-dc_norm(2,i)
2552             uzder(1,2,2)=-dc_norm(3,i)
2553             uzder(2,2,2)= 0.0d0
2554             uzder(3,2,2)= dc_norm(1,i)
2555             uzder(1,3,2)= dc_norm(2,i)
2556             uzder(2,3,2)=-dc_norm(1,i)
2557             uzder(3,3,2)= 0.0d0
2558 C Compute the Y-axis
2559             facy=fac
2560             do k=1,3
2561               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2562             enddo
2563 C Compute the derivatives of uy
2564             do j=1,3
2565               do k=1,3
2566                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2567      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2568                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2569               enddo
2570               uyder(j,j,1)=uyder(j,j,1)-costh
2571               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2572             enddo
2573             do j=1,2
2574               do k=1,3
2575                 do l=1,3
2576                   uygrad(l,k,j,i)=uyder(l,k,j)
2577                   uzgrad(l,k,j,i)=uzder(l,k,j)
2578                 enddo
2579               enddo
2580             enddo
2581             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2582             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2583             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2584             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2585           else
2586 C Other residues
2587 C Compute the Z-axis
2588             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2589             costh=dcos(pi-theta(i+2))
2590             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2591             do k=1,3
2592               uz(k,i)=fac*uz(k,i)
2593             enddo
2594 C Compute the derivatives of uz
2595             uzder(1,1,1)= 0.0d0
2596             uzder(2,1,1)=-dc_norm(3,i+1)
2597             uzder(3,1,1)= dc_norm(2,i+1)
2598             uzder(1,2,1)= dc_norm(3,i+1)
2599             uzder(2,2,1)= 0.0d0
2600             uzder(3,2,1)=-dc_norm(1,i+1)
2601             uzder(1,3,1)=-dc_norm(2,i+1)
2602             uzder(2,3,1)= dc_norm(1,i+1)
2603             uzder(3,3,1)= 0.0d0
2604             uzder(1,1,2)= 0.0d0
2605             uzder(2,1,2)= dc_norm(3,i)
2606             uzder(3,1,2)=-dc_norm(2,i)
2607             uzder(1,2,2)=-dc_norm(3,i)
2608             uzder(2,2,2)= 0.0d0
2609             uzder(3,2,2)= dc_norm(1,i)
2610             uzder(1,3,2)= dc_norm(2,i)
2611             uzder(2,3,2)=-dc_norm(1,i)
2612             uzder(3,3,2)= 0.0d0
2613 C Compute the Y-axis
2614             facy=fac
2615             do k=1,3
2616               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2617             enddo
2618 C Compute the derivatives of uy
2619             do j=1,3
2620               do k=1,3
2621                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2622      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2623                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2624               enddo
2625               uyder(j,j,1)=uyder(j,j,1)-costh
2626               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2627             enddo
2628             do j=1,2
2629               do k=1,3
2630                 do l=1,3
2631                   uygrad(l,k,j,i)=uyder(l,k,j)
2632                   uzgrad(l,k,j,i)=uzder(l,k,j)
2633                 enddo
2634               enddo
2635             enddo
2636             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2637             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2638             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2639             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2640           endif
2641       enddo
2642       do i=1,nres-1
2643         vbld_inv_temp(1)=vbld_inv(i+1)
2644         if (i.lt.nres-1) then
2645           vbld_inv_temp(2)=vbld_inv(i+2)
2646           else
2647           vbld_inv_temp(2)=vbld_inv(i)
2648           endif
2649         do j=1,2
2650           do k=1,3
2651             do l=1,3
2652               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2653               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2654             enddo
2655           enddo
2656         enddo
2657       enddo
2658 #if defined(PARVEC) && defined(MPI)
2659       if (nfgtasks1.gt.1) then
2660         time00=MPI_Wtime()
2661 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2662 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2663 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2664         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2665      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2666      &   FG_COMM1,IERR)
2667         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2668      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2671      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2672      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2673         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2674      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2675      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2676         time_gather=time_gather+MPI_Wtime()-time00
2677       endif
2678 c      if (fg_rank.eq.0) then
2679 c        write (iout,*) "Arrays UY and UZ"
2680 c        do i=1,nres-1
2681 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2682 c     &     (uz(k,i),k=1,3)
2683 c        enddo
2684 c      endif
2685 #endif
2686       return
2687       end
2688 C-----------------------------------------------------------------------------
2689       subroutine check_vecgrad
2690       implicit real*8 (a-h,o-z)
2691       include 'DIMENSIONS'
2692       include 'COMMON.IOUNITS'
2693       include 'COMMON.GEO'
2694       include 'COMMON.VAR'
2695       include 'COMMON.LOCAL'
2696       include 'COMMON.CHAIN'
2697       include 'COMMON.VECTORS'
2698       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2699       dimension uyt(3,maxres),uzt(3,maxres)
2700       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2701       double precision delta /1.0d-7/
2702       call vec_and_deriv
2703 cd      do i=1,nres
2704 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2705 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2706 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2707 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2708 cd     &     (dc_norm(if90,i),if90=1,3)
2709 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2710 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2711 cd          write(iout,'(a)')
2712 cd      enddo
2713       do i=1,nres
2714         do j=1,2
2715           do k=1,3
2716             do l=1,3
2717               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2718               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2719             enddo
2720           enddo
2721         enddo
2722       enddo
2723       call vec_and_deriv
2724       do i=1,nres
2725         do j=1,3
2726           uyt(j,i)=uy(j,i)
2727           uzt(j,i)=uz(j,i)
2728         enddo
2729       enddo
2730       do i=1,nres
2731 cd        write (iout,*) 'i=',i
2732         do k=1,3
2733           erij(k)=dc_norm(k,i)
2734         enddo
2735         do j=1,3
2736           do k=1,3
2737             dc_norm(k,i)=erij(k)
2738           enddo
2739           dc_norm(j,i)=dc_norm(j,i)+delta
2740 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2741 c          do k=1,3
2742 c            dc_norm(k,i)=dc_norm(k,i)/fac
2743 c          enddo
2744 c          write (iout,*) (dc_norm(k,i),k=1,3)
2745 c          write (iout,*) (erij(k),k=1,3)
2746           call vec_and_deriv
2747           do k=1,3
2748             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2749             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2750             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2751             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2752           enddo
2753 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2754 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2755 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2756         enddo
2757         do k=1,3
2758           dc_norm(k,i)=erij(k)
2759         enddo
2760 cd        do k=1,3
2761 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2762 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2763 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2764 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2765 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2766 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2767 cd          write (iout,'(a)')
2768 cd        enddo
2769       enddo
2770       return
2771       end
2772 C--------------------------------------------------------------------------
2773       subroutine set_matrices
2774       implicit real*8 (a-h,o-z)
2775       include 'DIMENSIONS'
2776 #ifdef MPI
2777       include "mpif.h"
2778       include "COMMON.SETUP"
2779       integer IERR
2780       integer status(MPI_STATUS_SIZE)
2781 #endif
2782       include 'COMMON.IOUNITS'
2783       include 'COMMON.GEO'
2784       include 'COMMON.VAR'
2785       include 'COMMON.LOCAL'
2786       include 'COMMON.CHAIN'
2787       include 'COMMON.DERIV'
2788       include 'COMMON.INTERACT'
2789       include 'COMMON.CONTACTS'
2790       include 'COMMON.TORSION'
2791       include 'COMMON.VECTORS'
2792       include 'COMMON.FFIELD'
2793       double precision auxvec(2),auxmat(2,2)
2794 C
2795 C Compute the virtual-bond-torsional-angle dependent quantities needed
2796 C to calculate the el-loc multibody terms of various order.
2797 C
2798 c      write(iout,*) 'nphi=',nphi,nres
2799 #ifdef PARMAT
2800       do i=ivec_start+2,ivec_end+2
2801 #else
2802       do i=3,nres+1
2803 #endif
2804 #ifdef NEWCORR
2805         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2806           iti = itype2loc(itype(i-2))
2807         else
2808           iti=nloctyp
2809         endif
2810 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2811         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2812           iti1 = itype2loc(itype(i-1))
2813         else
2814           iti1=nloctyp
2815         endif
2816 c        write(iout,*),i
2817         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2818      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2819      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2820         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2821      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2822      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2823 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2824 c     &*(cos(theta(i)/2.0)
2825         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2826      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2827      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2828 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2829 c     &*(cos(theta(i)/2.0)
2830         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2831      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2832      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2833 c        if (ggb1(1,i).eq.0.0d0) then
2834 c        write(iout,*) 'i=',i,ggb1(1,i),
2835 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2836 c     &bnew1(2,1,iti)*cos(theta(i)),
2837 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2838 c        endif
2839         b1(2,i-2)=bnew1(1,2,iti)
2840         gtb1(2,i-2)=0.0
2841         b2(2,i-2)=bnew2(1,2,iti)
2842         gtb2(2,i-2)=0.0
2843         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2844         EE(1,2,i-2)=eeold(1,2,iti)
2845         EE(2,1,i-2)=eeold(2,1,iti)
2846         EE(2,2,i-2)=eeold(2,2,iti)
2847         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2848         gtEE(1,2,i-2)=0.0d0
2849         gtEE(2,2,i-2)=0.0d0
2850         gtEE(2,1,i-2)=0.0d0
2851 c        EE(2,2,iti)=0.0d0
2852 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2853 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2854 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2855 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2856        b1tilde(1,i-2)=b1(1,i-2)
2857        b1tilde(2,i-2)=-b1(2,i-2)
2858        b2tilde(1,i-2)=b2(1,i-2)
2859        b2tilde(2,i-2)=-b2(2,i-2)
2860 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2861 c       write(iout,*)  'b1=',b1(1,i-2)
2862 c       write (iout,*) 'theta=', theta(i-1)
2863        enddo
2864 #else
2865         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2866           iti = itype2loc(itype(i-2))
2867         else
2868           iti=nloctyp
2869         endif
2870 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2871         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2872           iti1 = itype2loc(itype(i-1))
2873         else
2874           iti1=nloctyp
2875         endif
2876         b1(1,i-2)=b(3,iti)
2877         b1(2,i-2)=b(5,iti)
2878         b2(1,i-2)=b(2,iti)
2879         b2(2,i-2)=b(4,iti)
2880        b1tilde(1,i-2)=b1(1,i-2)
2881        b1tilde(2,i-2)=-b1(2,i-2)
2882        b2tilde(1,i-2)=b2(1,i-2)
2883        b2tilde(2,i-2)=-b2(2,i-2)
2884         EE(1,2,i-2)=eeold(1,2,iti)
2885         EE(2,1,i-2)=eeold(2,1,iti)
2886         EE(2,2,i-2)=eeold(2,2,iti)
2887         EE(1,1,i-2)=eeold(1,1,iti)
2888       enddo
2889 #endif
2890 #ifdef PARMAT
2891       do i=ivec_start+2,ivec_end+2
2892 #else
2893       do i=3,nres+1
2894 #endif
2895         if (i .lt. nres+1) then
2896           sin1=dsin(phi(i))
2897           cos1=dcos(phi(i))
2898           sintab(i-2)=sin1
2899           costab(i-2)=cos1
2900           obrot(1,i-2)=cos1
2901           obrot(2,i-2)=sin1
2902           sin2=dsin(2*phi(i))
2903           cos2=dcos(2*phi(i))
2904           sintab2(i-2)=sin2
2905           costab2(i-2)=cos2
2906           obrot2(1,i-2)=cos2
2907           obrot2(2,i-2)=sin2
2908           Ug(1,1,i-2)=-cos1
2909           Ug(1,2,i-2)=-sin1
2910           Ug(2,1,i-2)=-sin1
2911           Ug(2,2,i-2)= cos1
2912           Ug2(1,1,i-2)=-cos2
2913           Ug2(1,2,i-2)=-sin2
2914           Ug2(2,1,i-2)=-sin2
2915           Ug2(2,2,i-2)= cos2
2916         else
2917           costab(i-2)=1.0d0
2918           sintab(i-2)=0.0d0
2919           obrot(1,i-2)=1.0d0
2920           obrot(2,i-2)=0.0d0
2921           obrot2(1,i-2)=0.0d0
2922           obrot2(2,i-2)=0.0d0
2923           Ug(1,1,i-2)=1.0d0
2924           Ug(1,2,i-2)=0.0d0
2925           Ug(2,1,i-2)=0.0d0
2926           Ug(2,2,i-2)=1.0d0
2927           Ug2(1,1,i-2)=0.0d0
2928           Ug2(1,2,i-2)=0.0d0
2929           Ug2(2,1,i-2)=0.0d0
2930           Ug2(2,2,i-2)=0.0d0
2931         endif
2932         if (i .gt. 3 .and. i .lt. nres+1) then
2933           obrot_der(1,i-2)=-sin1
2934           obrot_der(2,i-2)= cos1
2935           Ugder(1,1,i-2)= sin1
2936           Ugder(1,2,i-2)=-cos1
2937           Ugder(2,1,i-2)=-cos1
2938           Ugder(2,2,i-2)=-sin1
2939           dwacos2=cos2+cos2
2940           dwasin2=sin2+sin2
2941           obrot2_der(1,i-2)=-dwasin2
2942           obrot2_der(2,i-2)= dwacos2
2943           Ug2der(1,1,i-2)= dwasin2
2944           Ug2der(1,2,i-2)=-dwacos2
2945           Ug2der(2,1,i-2)=-dwacos2
2946           Ug2der(2,2,i-2)=-dwasin2
2947         else
2948           obrot_der(1,i-2)=0.0d0
2949           obrot_der(2,i-2)=0.0d0
2950           Ugder(1,1,i-2)=0.0d0
2951           Ugder(1,2,i-2)=0.0d0
2952           Ugder(2,1,i-2)=0.0d0
2953           Ugder(2,2,i-2)=0.0d0
2954           obrot2_der(1,i-2)=0.0d0
2955           obrot2_der(2,i-2)=0.0d0
2956           Ug2der(1,1,i-2)=0.0d0
2957           Ug2der(1,2,i-2)=0.0d0
2958           Ug2der(2,1,i-2)=0.0d0
2959           Ug2der(2,2,i-2)=0.0d0
2960         endif
2961 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2962         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2963           iti = itype2loc(itype(i-2))
2964         else
2965           iti=nloctyp
2966         endif
2967 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2968         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2969           iti1 = itype2loc(itype(i-1))
2970         else
2971           iti1=nloctyp
2972         endif
2973 cd        write (iout,*) '*******i',i,' iti1',iti
2974 cd        write (iout,*) 'b1',b1(:,iti)
2975 cd        write (iout,*) 'b2',b2(:,iti)
2976 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2977 c        if (i .gt. iatel_s+2) then
2978         if (i .gt. nnt+2) then
2979           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2980 #ifdef NEWCORR
2981           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2982 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2983 #endif
2984 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2985 c     &    EE(1,2,iti),EE(2,2,i)
2986           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2987           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2988 c          write(iout,*) "Macierz EUG",
2989 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2990 c     &    eug(2,2,i-2)
2991           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2992      &    then
2993           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2994           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2995           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2996           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2997           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2998           endif
2999         else
3000           do k=1,2
3001             Ub2(k,i-2)=0.0d0
3002             Ctobr(k,i-2)=0.0d0
3003             Dtobr2(k,i-2)=0.0d0
3004             do l=1,2
3005               EUg(l,k,i-2)=0.0d0
3006               CUg(l,k,i-2)=0.0d0
3007               DUg(l,k,i-2)=0.0d0
3008               DtUg2(l,k,i-2)=0.0d0
3009             enddo
3010           enddo
3011         endif
3012         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3013         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3014         do k=1,2
3015           muder(k,i-2)=Ub2der(k,i-2)
3016         enddo
3017 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3018         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3019           if (itype(i-1).le.ntyp) then
3020             iti1 = itype2loc(itype(i-1))
3021           else
3022             iti1=nloctyp
3023           endif
3024         else
3025           iti1=nloctyp
3026         endif
3027         do k=1,2
3028           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3029         enddo
3030 #ifdef MUOUT
3031         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3032      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3033      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3034      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3035      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3036      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3037 #endif
3038 cd        write (iout,*) 'mu1',mu1(:,i-2)
3039 cd        write (iout,*) 'mu2',mu2(:,i-2)
3040         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3041      &  then
3042         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3043         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3044         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3045         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3046         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3047 C Vectors and matrices dependent on a single virtual-bond dihedral.
3048         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3049         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3050         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3051         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3052         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3053         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3054         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3055         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3056         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3057         endif
3058       enddo
3059 C Matrices dependent on two consecutive virtual-bond dihedrals.
3060 C The order of matrices is from left to right.
3061       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3062      &then
3063 c      do i=max0(ivec_start,2),ivec_end
3064       do i=2,nres-1
3065         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3066         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3067         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3068         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3069         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3070         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3071         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3072         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3073       enddo
3074       endif
3075 #if defined(MPI) && defined(PARMAT)
3076 #ifdef DEBUG
3077 c      if (fg_rank.eq.0) then
3078         write (iout,*) "Arrays UG and UGDER before GATHER"
3079         do i=1,nres-1
3080           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3081      &     ((ug(l,k,i),l=1,2),k=1,2),
3082      &     ((ugder(l,k,i),l=1,2),k=1,2)
3083         enddo
3084         write (iout,*) "Arrays UG2 and UG2DER"
3085         do i=1,nres-1
3086           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3087      &     ((ug2(l,k,i),l=1,2),k=1,2),
3088      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3089         enddo
3090         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3091         do i=1,nres-1
3092           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3093      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3094      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3095         enddo
3096         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3097         do i=1,nres-1
3098           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3099      &     costab(i),sintab(i),costab2(i),sintab2(i)
3100         enddo
3101         write (iout,*) "Array MUDER"
3102         do i=1,nres-1
3103           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3104         enddo
3105 c      endif
3106 #endif
3107       if (nfgtasks.gt.1) then
3108         time00=MPI_Wtime()
3109 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3110 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3111 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3112 #ifdef MATGATHER
3113         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3115      &   FG_COMM1,IERR)
3116         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3118      &   FG_COMM1,IERR)
3119         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3121      &   FG_COMM1,IERR)
3122         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3123      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3124      &   FG_COMM1,IERR)
3125         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3126      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3127      &   FG_COMM1,IERR)
3128         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3129      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3130      &   FG_COMM1,IERR)
3131         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3132      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3133      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3134         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3135      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3136      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3137         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3138      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3139      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3140         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3141      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3142      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3143         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3144      &  then
3145         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3146      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3147      &   FG_COMM1,IERR)
3148         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3149      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3150      &   FG_COMM1,IERR)
3151         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3152      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3153      &   FG_COMM1,IERR)
3154        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3155      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3156      &   FG_COMM1,IERR)
3157         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3158      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3159      &   FG_COMM1,IERR)
3160         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3161      &   ivec_count(fg_rank1),
3162      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3163      &   FG_COMM1,IERR)
3164         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3165      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3166      &   FG_COMM1,IERR)
3167         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3168      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3169      &   FG_COMM1,IERR)
3170         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3171      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3172      &   FG_COMM1,IERR)
3173         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3174      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3175      &   FG_COMM1,IERR)
3176         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3177      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3178      &   FG_COMM1,IERR)
3179         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3180      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3181      &   FG_COMM1,IERR)
3182         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3183      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3184      &   FG_COMM1,IERR)
3185         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3186      &   ivec_count(fg_rank1),
3187      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3188      &   FG_COMM1,IERR)
3189         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3190      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3191      &   FG_COMM1,IERR)
3192        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3193      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3194      &   FG_COMM1,IERR)
3195         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3196      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3197      &   FG_COMM1,IERR)
3198        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3199      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3200      &   FG_COMM1,IERR)
3201         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3202      &   ivec_count(fg_rank1),
3203      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3204      &   FG_COMM1,IERR)
3205         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3206      &   ivec_count(fg_rank1),
3207      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3208      &   FG_COMM1,IERR)
3209         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3210      &   ivec_count(fg_rank1),
3211      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3212      &   MPI_MAT2,FG_COMM1,IERR)
3213         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3214      &   ivec_count(fg_rank1),
3215      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3216      &   MPI_MAT2,FG_COMM1,IERR)
3217         endif
3218 #else
3219 c Passes matrix info through the ring
3220       isend=fg_rank1
3221       irecv=fg_rank1-1
3222       if (irecv.lt.0) irecv=nfgtasks1-1
3223       iprev=irecv
3224       inext=fg_rank1+1
3225       if (inext.ge.nfgtasks1) inext=0
3226       do i=1,nfgtasks1-1
3227 c        write (iout,*) "isend",isend," irecv",irecv
3228 c        call flush(iout)
3229         lensend=lentyp(isend)
3230         lenrecv=lentyp(irecv)
3231 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3232 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3233 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3234 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3235 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3236 c        write (iout,*) "Gather ROTAT1"
3237 c        call flush(iout)
3238 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3239 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3240 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3241 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3242 c        write (iout,*) "Gather ROTAT2"
3243 c        call flush(iout)
3244         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3245      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3246      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3247      &   iprev,4400+irecv,FG_COMM,status,IERR)
3248 c        write (iout,*) "Gather ROTAT_OLD"
3249 c        call flush(iout)
3250         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3251      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3252      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3253      &   iprev,5500+irecv,FG_COMM,status,IERR)
3254 c        write (iout,*) "Gather PRECOMP11"
3255 c        call flush(iout)
3256         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3257      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3258      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3259      &   iprev,6600+irecv,FG_COMM,status,IERR)
3260 c        write (iout,*) "Gather PRECOMP12"
3261 c        call flush(iout)
3262         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3263      &  then
3264         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3265      &   MPI_ROTAT2(lensend),inext,7700+isend,
3266      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3267      &   iprev,7700+irecv,FG_COMM,status,IERR)
3268 c        write (iout,*) "Gather PRECOMP21"
3269 c        call flush(iout)
3270         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3271      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3272      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3273      &   iprev,8800+irecv,FG_COMM,status,IERR)
3274 c        write (iout,*) "Gather PRECOMP22"
3275 c        call flush(iout)
3276         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3277      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3278      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3279      &   MPI_PRECOMP23(lenrecv),
3280      &   iprev,9900+irecv,FG_COMM,status,IERR)
3281 c        write (iout,*) "Gather PRECOMP23"
3282 c        call flush(iout)
3283         endif
3284         isend=irecv
3285         irecv=irecv-1
3286         if (irecv.lt.0) irecv=nfgtasks1-1
3287       enddo
3288 #endif
3289         time_gather=time_gather+MPI_Wtime()-time00
3290       endif
3291 #ifdef DEBUG
3292 c      if (fg_rank.eq.0) then
3293         write (iout,*) "Arrays UG and UGDER"
3294         do i=1,nres-1
3295           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3296      &     ((ug(l,k,i),l=1,2),k=1,2),
3297      &     ((ugder(l,k,i),l=1,2),k=1,2)
3298         enddo
3299         write (iout,*) "Arrays UG2 and UG2DER"
3300         do i=1,nres-1
3301           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3302      &     ((ug2(l,k,i),l=1,2),k=1,2),
3303      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3304         enddo
3305         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3306         do i=1,nres-1
3307           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3308      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3309      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3310         enddo
3311         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3312         do i=1,nres-1
3313           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3314      &     costab(i),sintab(i),costab2(i),sintab2(i)
3315         enddo
3316         write (iout,*) "Array MUDER"
3317         do i=1,nres-1
3318           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3319         enddo
3320 c      endif
3321 #endif
3322 #endif
3323 cd      do i=1,nres
3324 cd        iti = itype2loc(itype(i))
3325 cd        write (iout,*) i
3326 cd        do j=1,2
3327 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3328 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3329 cd        enddo
3330 cd      enddo
3331       return
3332       end
3333 C--------------------------------------------------------------------------
3334       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3335 C
3336 C This subroutine calculates the average interaction energy and its gradient
3337 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3338 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3339 C The potential depends both on the distance of peptide-group centers and on
3340 C the orientation of the CA-CA virtual bonds.
3341 C
3342       implicit real*8 (a-h,o-z)
3343 #ifdef MPI
3344       include 'mpif.h'
3345 #endif
3346       include 'DIMENSIONS'
3347       include 'COMMON.CONTROL'
3348       include 'COMMON.SETUP'
3349       include 'COMMON.IOUNITS'
3350       include 'COMMON.GEO'
3351       include 'COMMON.VAR'
3352       include 'COMMON.LOCAL'
3353       include 'COMMON.CHAIN'
3354       include 'COMMON.DERIV'
3355       include 'COMMON.INTERACT'
3356       include 'COMMON.CONTACTS'
3357       include 'COMMON.TORSION'
3358       include 'COMMON.VECTORS'
3359       include 'COMMON.FFIELD'
3360       include 'COMMON.TIME1'
3361       include 'COMMON.SPLITELE'
3362       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3363      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3364       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3365      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3366       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3367      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3368      &    num_conti,j1,j2
3369 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3370 #ifdef MOMENT
3371       double precision scal_el /1.0d0/
3372 #else
3373       double precision scal_el /0.5d0/
3374 #endif
3375 C 12/13/98
3376 C 13-go grudnia roku pamietnego...
3377       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3378      &                   0.0d0,1.0d0,0.0d0,
3379      &                   0.0d0,0.0d0,1.0d0/
3380 cd      write(iout,*) 'In EELEC'
3381 cd      do i=1,nloctyp
3382 cd        write(iout,*) 'Type',i
3383 cd        write(iout,*) 'B1',B1(:,i)
3384 cd        write(iout,*) 'B2',B2(:,i)
3385 cd        write(iout,*) 'CC',CC(:,:,i)
3386 cd        write(iout,*) 'DD',DD(:,:,i)
3387 cd        write(iout,*) 'EE',EE(:,:,i)
3388 cd      enddo
3389 cd      call check_vecgrad
3390 cd      stop
3391       if (icheckgrad.eq.1) then
3392         do i=1,nres-1
3393           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3394           do k=1,3
3395             dc_norm(k,i)=dc(k,i)*fac
3396           enddo
3397 c          write (iout,*) 'i',i,' fac',fac
3398         enddo
3399       endif
3400       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3401      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3402      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3403 c        call vec_and_deriv
3404 #ifdef TIMING
3405         time01=MPI_Wtime()
3406 #endif
3407         call set_matrices
3408 #ifdef TIMING
3409         time_mat=time_mat+MPI_Wtime()-time01
3410 #endif
3411       endif
3412 cd      do i=1,nres-1
3413 cd        write (iout,*) 'i=',i
3414 cd        do k=1,3
3415 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3416 cd        enddo
3417 cd        do k=1,3
3418 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3419 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3420 cd        enddo
3421 cd      enddo
3422       t_eelecij=0.0d0
3423       ees=0.0D0
3424       evdw1=0.0D0
3425       eel_loc=0.0d0
3426       eello_turn3=0.0d0
3427       eello_turn4=0.0d0
3428       ind=0
3429       do i=1,nres
3430         num_cont_hb(i)=0
3431       enddo
3432 cd      print '(a)','Enter EELEC'
3433 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3434       do i=1,nres
3435         gel_loc_loc(i)=0.0d0
3436         gcorr_loc(i)=0.0d0
3437       enddo
3438 c
3439 c
3440 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3441 C
3442 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3443 C
3444 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3445       do i=iturn3_start,iturn3_end
3446 c        if (i.le.1) cycle
3447 C        write(iout,*) "tu jest i",i
3448         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3449 C changes suggested by Ana to avoid out of bounds
3450 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3451 c     & .or.((i+4).gt.nres)
3452 c     & .or.((i-1).le.0)
3453 C end of changes by Ana
3454      &  .or. itype(i+2).eq.ntyp1
3455      &  .or. itype(i+3).eq.ntyp1) cycle
3456 C Adam: Instructions below will switch off existing interactions
3457 c        if(i.gt.1)then
3458 c          if(itype(i-1).eq.ntyp1)cycle
3459 c        end if
3460 c        if(i.LT.nres-3)then
3461 c          if (itype(i+4).eq.ntyp1) cycle
3462 c        end if
3463         dxi=dc(1,i)
3464         dyi=dc(2,i)
3465         dzi=dc(3,i)
3466         dx_normi=dc_norm(1,i)
3467         dy_normi=dc_norm(2,i)
3468         dz_normi=dc_norm(3,i)
3469         xmedi=c(1,i)+0.5d0*dxi
3470         ymedi=c(2,i)+0.5d0*dyi
3471         zmedi=c(3,i)+0.5d0*dzi
3472           xmedi=mod(xmedi,boxxsize)
3473           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3474           ymedi=mod(ymedi,boxysize)
3475           if (ymedi.lt.0) ymedi=ymedi+boxysize
3476           zmedi=mod(zmedi,boxzsize)
3477           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3478         num_conti=0
3479         call eelecij(i,i+2,ees,evdw1,eel_loc)
3480         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3481         num_cont_hb(i)=num_conti
3482       enddo
3483       do i=iturn4_start,iturn4_end
3484         if (i.lt.1) cycle
3485         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3486 C changes suggested by Ana to avoid out of bounds
3487 c     & .or.((i+5).gt.nres)
3488 c     & .or.((i-1).le.0)
3489 C end of changes suggested by Ana
3490      &    .or. itype(i+3).eq.ntyp1
3491      &    .or. itype(i+4).eq.ntyp1
3492 c     &    .or. itype(i+5).eq.ntyp1
3493 c     &    .or. itype(i).eq.ntyp1
3494 c     &    .or. itype(i-1).eq.ntyp1
3495      &                             ) cycle
3496         dxi=dc(1,i)
3497         dyi=dc(2,i)
3498         dzi=dc(3,i)
3499         dx_normi=dc_norm(1,i)
3500         dy_normi=dc_norm(2,i)
3501         dz_normi=dc_norm(3,i)
3502         xmedi=c(1,i)+0.5d0*dxi
3503         ymedi=c(2,i)+0.5d0*dyi
3504         zmedi=c(3,i)+0.5d0*dzi
3505 C Return atom into box, boxxsize is size of box in x dimension
3506 c  194   continue
3507 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3508 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3509 C Condition for being inside the proper box
3510 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3511 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3512 c        go to 194
3513 c        endif
3514 c  195   continue
3515 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3516 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3517 C Condition for being inside the proper box
3518 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3519 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3520 c        go to 195
3521 c        endif
3522 c  196   continue
3523 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3524 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3525 C Condition for being inside the proper box
3526 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3527 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3528 c        go to 196
3529 c        endif
3530           xmedi=mod(xmedi,boxxsize)
3531           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3532           ymedi=mod(ymedi,boxysize)
3533           if (ymedi.lt.0) ymedi=ymedi+boxysize
3534           zmedi=mod(zmedi,boxzsize)
3535           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3536
3537         num_conti=num_cont_hb(i)
3538 c        write(iout,*) "JESTEM W PETLI"
3539         call eelecij(i,i+3,ees,evdw1,eel_loc)
3540         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3541      &   call eturn4(i,eello_turn4)
3542         num_cont_hb(i)=num_conti
3543       enddo   ! i
3544 C Loop over all neighbouring boxes
3545 C      do xshift=-1,1
3546 C      do yshift=-1,1
3547 C      do zshift=-1,1
3548 c
3549 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3550 c
3551 CTU KURWA
3552       do i=iatel_s,iatel_e
3553 C        do i=75,75
3554 c        if (i.le.1) cycle
3555         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3556 C changes suggested by Ana to avoid out of bounds
3557 c     & .or.((i+2).gt.nres)
3558 c     & .or.((i-1).le.0)
3559 C end of changes by Ana
3560 c     &  .or. itype(i+2).eq.ntyp1
3561 c     &  .or. itype(i-1).eq.ntyp1
3562      &                ) cycle
3563         dxi=dc(1,i)
3564         dyi=dc(2,i)
3565         dzi=dc(3,i)
3566         dx_normi=dc_norm(1,i)
3567         dy_normi=dc_norm(2,i)
3568         dz_normi=dc_norm(3,i)
3569         xmedi=c(1,i)+0.5d0*dxi
3570         ymedi=c(2,i)+0.5d0*dyi
3571         zmedi=c(3,i)+0.5d0*dzi
3572           xmedi=mod(xmedi,boxxsize)
3573           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3574           ymedi=mod(ymedi,boxysize)
3575           if (ymedi.lt.0) ymedi=ymedi+boxysize
3576           zmedi=mod(zmedi,boxzsize)
3577           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3578 C          xmedi=xmedi+xshift*boxxsize
3579 C          ymedi=ymedi+yshift*boxysize
3580 C          zmedi=zmedi+zshift*boxzsize
3581
3582 C Return tom into box, boxxsize is size of box in x dimension
3583 c  164   continue
3584 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3585 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3586 C Condition for being inside the proper box
3587 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3588 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3589 c        go to 164
3590 c        endif
3591 c  165   continue
3592 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3593 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3594 C Condition for being inside the proper box
3595 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3596 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3597 c        go to 165
3598 c        endif
3599 c  166   continue
3600 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3601 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3602 cC Condition for being inside the proper box
3603 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3604 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3605 c        go to 166
3606 c        endif
3607
3608 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3609         num_conti=num_cont_hb(i)
3610 C I TU KURWA
3611         do j=ielstart(i),ielend(i)
3612 C          do j=16,17
3613 C          write (iout,*) i,j
3614 C         if (j.le.1) cycle
3615           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3616 C changes suggested by Ana to avoid out of bounds
3617 c     & .or.((j+2).gt.nres)
3618 c     & .or.((j-1).le.0)
3619 C end of changes by Ana
3620 c     & .or.itype(j+2).eq.ntyp1
3621 c     & .or.itype(j-1).eq.ntyp1
3622      &) cycle
3623           call eelecij(i,j,ees,evdw1,eel_loc)
3624         enddo ! j
3625         num_cont_hb(i)=num_conti
3626       enddo   ! i
3627 C     enddo   ! zshift
3628 C      enddo   ! yshift
3629 C      enddo   ! xshift
3630
3631 c      write (iout,*) "Number of loop steps in EELEC:",ind
3632 cd      do i=1,nres
3633 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3634 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3635 cd      enddo
3636 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3637 ccc      eel_loc=eel_loc+eello_turn3
3638 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3639       return
3640       end
3641 C-------------------------------------------------------------------------------
3642       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3643       implicit real*8 (a-h,o-z)
3644       include 'DIMENSIONS'
3645 #ifdef MPI
3646       include "mpif.h"
3647 #endif
3648       include 'COMMON.CONTROL'
3649       include 'COMMON.IOUNITS'
3650       include 'COMMON.GEO'
3651       include 'COMMON.VAR'
3652       include 'COMMON.LOCAL'
3653       include 'COMMON.CHAIN'
3654       include 'COMMON.DERIV'
3655       include 'COMMON.INTERACT'
3656       include 'COMMON.CONTACTS'
3657       include 'COMMON.TORSION'
3658       include 'COMMON.VECTORS'
3659       include 'COMMON.FFIELD'
3660       include 'COMMON.TIME1'
3661       include 'COMMON.SPLITELE'
3662       include 'COMMON.SHIELD'
3663       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3664      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3665       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3666      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3667      &    gmuij2(4),gmuji2(4)
3668       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3669      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3670      &    num_conti,j1,j2
3671 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3672 #ifdef MOMENT
3673       double precision scal_el /1.0d0/
3674 #else
3675       double precision scal_el /0.5d0/
3676 #endif
3677 C 12/13/98
3678 C 13-go grudnia roku pamietnego...
3679       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3680      &                   0.0d0,1.0d0,0.0d0,
3681      &                   0.0d0,0.0d0,1.0d0/
3682        integer xshift,yshift,zshift
3683 c          time00=MPI_Wtime()
3684 cd      write (iout,*) "eelecij",i,j
3685 c          ind=ind+1
3686           iteli=itel(i)
3687           itelj=itel(j)
3688           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3689           aaa=app(iteli,itelj)
3690           bbb=bpp(iteli,itelj)
3691           ael6i=ael6(iteli,itelj)
3692           ael3i=ael3(iteli,itelj)
3693           dxj=dc(1,j)
3694           dyj=dc(2,j)
3695           dzj=dc(3,j)
3696           dx_normj=dc_norm(1,j)
3697           dy_normj=dc_norm(2,j)
3698           dz_normj=dc_norm(3,j)
3699 C          xj=c(1,j)+0.5D0*dxj-xmedi
3700 C          yj=c(2,j)+0.5D0*dyj-ymedi
3701 C          zj=c(3,j)+0.5D0*dzj-zmedi
3702           xj=c(1,j)+0.5D0*dxj
3703           yj=c(2,j)+0.5D0*dyj
3704           zj=c(3,j)+0.5D0*dzj
3705           xj=mod(xj,boxxsize)
3706           if (xj.lt.0) xj=xj+boxxsize
3707           yj=mod(yj,boxysize)
3708           if (yj.lt.0) yj=yj+boxysize
3709           zj=mod(zj,boxzsize)
3710           if (zj.lt.0) zj=zj+boxzsize
3711           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3712       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3713       xj_safe=xj
3714       yj_safe=yj
3715       zj_safe=zj
3716       isubchap=0
3717       do xshift=-1,1
3718       do yshift=-1,1
3719       do zshift=-1,1
3720           xj=xj_safe+xshift*boxxsize
3721           yj=yj_safe+yshift*boxysize
3722           zj=zj_safe+zshift*boxzsize
3723           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3724           if(dist_temp.lt.dist_init) then
3725             dist_init=dist_temp
3726             xj_temp=xj
3727             yj_temp=yj
3728             zj_temp=zj
3729             isubchap=1
3730           endif
3731        enddo
3732        enddo
3733        enddo
3734        if (isubchap.eq.1) then
3735           xj=xj_temp-xmedi
3736           yj=yj_temp-ymedi
3737           zj=zj_temp-zmedi
3738        else
3739           xj=xj_safe-xmedi
3740           yj=yj_safe-ymedi
3741           zj=zj_safe-zmedi
3742        endif
3743 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3744 c  174   continue
3745 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3746 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3747 C Condition for being inside the proper box
3748 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3749 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3750 c        go to 174
3751 c        endif
3752 c  175   continue
3753 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3754 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3755 C Condition for being inside the proper box
3756 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3757 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3758 c        go to 175
3759 c        endif
3760 c  176   continue
3761 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3762 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3763 C Condition for being inside the proper box
3764 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3765 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3766 c        go to 176
3767 c        endif
3768 C        endif !endPBC condintion
3769 C        xj=xj-xmedi
3770 C        yj=yj-ymedi
3771 C        zj=zj-zmedi
3772           rij=xj*xj+yj*yj+zj*zj
3773
3774             sss=sscale(sqrt(rij))
3775             sssgrad=sscagrad(sqrt(rij))
3776 c            if (sss.gt.0.0d0) then
3777           rrmij=1.0D0/rij
3778           rij=dsqrt(rij)
3779           rmij=1.0D0/rij
3780           r3ij=rrmij*rmij
3781           r6ij=r3ij*r3ij
3782           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3783           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3784           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3785           fac=cosa-3.0D0*cosb*cosg
3786           ev1=aaa*r6ij*r6ij
3787 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3788           if (j.eq.i+2) ev1=scal_el*ev1
3789           ev2=bbb*r6ij
3790           fac3=ael6i*r6ij
3791           fac4=ael3i*r3ij
3792           evdwij=(ev1+ev2)
3793           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3794           el2=fac4*fac
3795 C MARYSIA
3796 C          eesij=(el1+el2)
3797 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3798           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3799           if (shield_mode.gt.0) then
3800 C          fac_shield(i)=0.4
3801 C          fac_shield(j)=0.6
3802           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3803           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3804           eesij=(el1+el2)
3805           ees=ees+eesij
3806           else
3807           fac_shield(i)=1.0
3808           fac_shield(j)=1.0
3809           eesij=(el1+el2)
3810           ees=ees+eesij
3811           endif
3812           evdw1=evdw1+evdwij*sss
3813 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3814 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3815 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3816 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3817
3818           if (energy_dec) then
3819               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3820      &'evdw1',i,j,evdwij
3821      &,iteli,itelj,aaa,evdw1
3822               write (iout,*) sss
3823               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3824      &fac_shield(i),fac_shield(j)
3825           endif
3826
3827 C
3828 C Calculate contributions to the Cartesian gradient.
3829 C
3830 #ifdef SPLITELE
3831           facvdw=-6*rrmij*(ev1+evdwij)*sss
3832           facel=-3*rrmij*(el1+eesij)
3833           fac1=fac
3834           erij(1)=xj*rmij
3835           erij(2)=yj*rmij
3836           erij(3)=zj*rmij
3837
3838 *
3839 * Radial derivatives. First process both termini of the fragment (i,j)
3840 *
3841           ggg(1)=facel*xj
3842           ggg(2)=facel*yj
3843           ggg(3)=facel*zj
3844           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3845      &  (shield_mode.gt.0)) then
3846 C          print *,i,j
3847           do ilist=1,ishield_list(i)
3848            iresshield=shield_list(ilist,i)
3849            do k=1,3
3850            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3851      &      *2.0
3852            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3853      &              rlocshield
3854      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3855             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3856 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3857 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3858 C             if (iresshield.gt.i) then
3859 C               do ishi=i+1,iresshield-1
3860 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3861 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3862 C
3863 C              enddo
3864 C             else
3865 C               do ishi=iresshield,i
3866 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3867 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3868 C
3869 C               enddo
3870 C              endif
3871            enddo
3872           enddo
3873           do ilist=1,ishield_list(j)
3874            iresshield=shield_list(ilist,j)
3875            do k=1,3
3876            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3877      &     *2.0
3878            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3879      &              rlocshield
3880      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3881            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3882
3883 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3884 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3885 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3886 C             if (iresshield.gt.j) then
3887 C               do ishi=j+1,iresshield-1
3888 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3889 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3890 C
3891 C               enddo
3892 C            else
3893 C               do ishi=iresshield,j
3894 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3895 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3896 C               enddo
3897 C              endif
3898            enddo
3899           enddo
3900
3901           do k=1,3
3902             gshieldc(k,i)=gshieldc(k,i)+
3903      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3904             gshieldc(k,j)=gshieldc(k,j)+
3905      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3906             gshieldc(k,i-1)=gshieldc(k,i-1)+
3907      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3908             gshieldc(k,j-1)=gshieldc(k,j-1)+
3909      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3910
3911            enddo
3912            endif
3913 c          do k=1,3
3914 c            ghalf=0.5D0*ggg(k)
3915 c            gelc(k,i)=gelc(k,i)+ghalf
3916 c            gelc(k,j)=gelc(k,j)+ghalf
3917 c          enddo
3918 c 9/28/08 AL Gradient compotents will be summed only at the end
3919 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3920           do k=1,3
3921             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3922 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3923             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3924 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3925 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3926 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3927 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3928 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3929           enddo
3930 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3931
3932 *
3933 * Loop over residues i+1 thru j-1.
3934 *
3935 cgrad          do k=i+1,j-1
3936 cgrad            do l=1,3
3937 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3938 cgrad            enddo
3939 cgrad          enddo
3940           if (sss.gt.0.0) then
3941           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3942           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3943           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3944           else
3945           ggg(1)=0.0
3946           ggg(2)=0.0
3947           ggg(3)=0.0
3948           endif
3949 c          do k=1,3
3950 c            ghalf=0.5D0*ggg(k)
3951 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3952 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3953 c          enddo
3954 c 9/28/08 AL Gradient compotents will be summed only at the end
3955           do k=1,3
3956             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3957             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3958           enddo
3959 *
3960 * Loop over residues i+1 thru j-1.
3961 *
3962 cgrad          do k=i+1,j-1
3963 cgrad            do l=1,3
3964 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3965 cgrad            enddo
3966 cgrad          enddo
3967 #else
3968 C MARYSIA
3969           facvdw=(ev1+evdwij)*sss
3970           facel=(el1+eesij)
3971           fac1=fac
3972           fac=-3*rrmij*(facvdw+facvdw+facel)
3973           erij(1)=xj*rmij
3974           erij(2)=yj*rmij
3975           erij(3)=zj*rmij
3976 *
3977 * Radial derivatives. First process both termini of the fragment (i,j)
3978 *
3979           ggg(1)=fac*xj
3980 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3981           ggg(2)=fac*yj
3982 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3983           ggg(3)=fac*zj
3984 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3985 c          do k=1,3
3986 c            ghalf=0.5D0*ggg(k)
3987 c            gelc(k,i)=gelc(k,i)+ghalf
3988 c            gelc(k,j)=gelc(k,j)+ghalf
3989 c          enddo
3990 c 9/28/08 AL Gradient compotents will be summed only at the end
3991           do k=1,3
3992             gelc_long(k,j)=gelc(k,j)+ggg(k)
3993             gelc_long(k,i)=gelc(k,i)-ggg(k)
3994           enddo
3995 *
3996 * Loop over residues i+1 thru j-1.
3997 *
3998 cgrad          do k=i+1,j-1
3999 cgrad            do l=1,3
4000 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4001 cgrad            enddo
4002 cgrad          enddo
4003 c 9/28/08 AL Gradient compotents will be summed only at the end
4004           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4005           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4006           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4007           do k=1,3
4008             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4009             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4010           enddo
4011 #endif
4012 *
4013 * Angular part
4014 *
4015           ecosa=2.0D0*fac3*fac1+fac4
4016           fac4=-3.0D0*fac4
4017           fac3=-6.0D0*fac3
4018           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4019           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4020           do k=1,3
4021             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4022             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4023           enddo
4024 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4025 cd   &          (dcosg(k),k=1,3)
4026           do k=1,3
4027             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4028      &      fac_shield(i)**2*fac_shield(j)**2
4029           enddo
4030 c          do k=1,3
4031 c            ghalf=0.5D0*ggg(k)
4032 c            gelc(k,i)=gelc(k,i)+ghalf
4033 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4034 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4035 c            gelc(k,j)=gelc(k,j)+ghalf
4036 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4037 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4038 c          enddo
4039 cgrad          do k=i+1,j-1
4040 cgrad            do l=1,3
4041 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4042 cgrad            enddo
4043 cgrad          enddo
4044 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4045           do k=1,3
4046             gelc(k,i)=gelc(k,i)
4047      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4048      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4049      &           *fac_shield(i)**2*fac_shield(j)**2
4050             gelc(k,j)=gelc(k,j)
4051      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4052      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4053      &           *fac_shield(i)**2*fac_shield(j)**2
4054             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4055             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4056           enddo
4057 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4058
4059 C MARYSIA
4060 c          endif !sscale
4061           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4062      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4063      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4064 C
4065 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4066 C   energy of a peptide unit is assumed in the form of a second-order
4067 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4068 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4069 C   are computed for EVERY pair of non-contiguous peptide groups.
4070 C
4071
4072           if (j.lt.nres-1) then
4073             j1=j+1
4074             j2=j-1
4075           else
4076             j1=j-1
4077             j2=j-2
4078           endif
4079           kkk=0
4080           lll=0
4081           do k=1,2
4082             do l=1,2
4083               kkk=kkk+1
4084               muij(kkk)=mu(k,i)*mu(l,j)
4085 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4086 #ifdef NEWCORR
4087              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4088 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4089              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4090              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4091 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4092              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4093 #endif
4094             enddo
4095           enddo
4096 cd         write (iout,*) 'EELEC: i',i,' j',j
4097 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4098 cd          write(iout,*) 'muij',muij
4099           ury=scalar(uy(1,i),erij)
4100           urz=scalar(uz(1,i),erij)
4101           vry=scalar(uy(1,j),erij)
4102           vrz=scalar(uz(1,j),erij)
4103           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4104           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4105           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4106           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4107           fac=dsqrt(-ael6i)*r3ij
4108           a22=a22*fac
4109           a23=a23*fac
4110           a32=a32*fac
4111           a33=a33*fac
4112 cd          write (iout,'(4i5,4f10.5)')
4113 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4114 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4115 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4116 cd     &      uy(:,j),uz(:,j)
4117 cd          write (iout,'(4f10.5)')
4118 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4119 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4120 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4121 cd           write (iout,'(9f10.5/)')
4122 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4123 C Derivatives of the elements of A in virtual-bond vectors
4124           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4125           do k=1,3
4126             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4127             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4128             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4129             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4130             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4131             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4132             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4133             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4134             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4135             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4136             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4137             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4138           enddo
4139 C Compute radial contributions to the gradient
4140           facr=-3.0d0*rrmij
4141           a22der=a22*facr
4142           a23der=a23*facr
4143           a32der=a32*facr
4144           a33der=a33*facr
4145           agg(1,1)=a22der*xj
4146           agg(2,1)=a22der*yj
4147           agg(3,1)=a22der*zj
4148           agg(1,2)=a23der*xj
4149           agg(2,2)=a23der*yj
4150           agg(3,2)=a23der*zj
4151           agg(1,3)=a32der*xj
4152           agg(2,3)=a32der*yj
4153           agg(3,3)=a32der*zj
4154           agg(1,4)=a33der*xj
4155           agg(2,4)=a33der*yj
4156           agg(3,4)=a33der*zj
4157 C Add the contributions coming from er
4158           fac3=-3.0d0*fac
4159           do k=1,3
4160             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4161             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4162             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4163             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4164           enddo
4165           do k=1,3
4166 C Derivatives in DC(i)
4167 cgrad            ghalf1=0.5d0*agg(k,1)
4168 cgrad            ghalf2=0.5d0*agg(k,2)
4169 cgrad            ghalf3=0.5d0*agg(k,3)
4170 cgrad            ghalf4=0.5d0*agg(k,4)
4171             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4172      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4173             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4174      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4175             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4176      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4177             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4178      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4179 C Derivatives in DC(i+1)
4180             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4181      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4182             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4183      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4184             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4185      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4186             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4187      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4188 C Derivatives in DC(j)
4189             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4190      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4191             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4192      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4193             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4194      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4195             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4196      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4197 C Derivatives in DC(j+1) or DC(nres-1)
4198             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4199      &      -3.0d0*vryg(k,3)*ury)
4200             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4201      &      -3.0d0*vrzg(k,3)*ury)
4202             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4203      &      -3.0d0*vryg(k,3)*urz)
4204             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4205      &      -3.0d0*vrzg(k,3)*urz)
4206 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4207 cgrad              do l=1,4
4208 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4209 cgrad              enddo
4210 cgrad            endif
4211           enddo
4212           acipa(1,1)=a22
4213           acipa(1,2)=a23
4214           acipa(2,1)=a32
4215           acipa(2,2)=a33
4216           a22=-a22
4217           a23=-a23
4218           do l=1,2
4219             do k=1,3
4220               agg(k,l)=-agg(k,l)
4221               aggi(k,l)=-aggi(k,l)
4222               aggi1(k,l)=-aggi1(k,l)
4223               aggj(k,l)=-aggj(k,l)
4224               aggj1(k,l)=-aggj1(k,l)
4225             enddo
4226           enddo
4227           if (j.lt.nres-1) then
4228             a22=-a22
4229             a32=-a32
4230             do l=1,3,2
4231               do k=1,3
4232                 agg(k,l)=-agg(k,l)
4233                 aggi(k,l)=-aggi(k,l)
4234                 aggi1(k,l)=-aggi1(k,l)
4235                 aggj(k,l)=-aggj(k,l)
4236                 aggj1(k,l)=-aggj1(k,l)
4237               enddo
4238             enddo
4239           else
4240             a22=-a22
4241             a23=-a23
4242             a32=-a32
4243             a33=-a33
4244             do l=1,4
4245               do k=1,3
4246                 agg(k,l)=-agg(k,l)
4247                 aggi(k,l)=-aggi(k,l)
4248                 aggi1(k,l)=-aggi1(k,l)
4249                 aggj(k,l)=-aggj(k,l)
4250                 aggj1(k,l)=-aggj1(k,l)
4251               enddo
4252             enddo
4253           endif
4254           ENDIF ! WCORR
4255           IF (wel_loc.gt.0.0d0) THEN
4256 C Contribution to the local-electrostatic energy coming from the i-j pair
4257           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4258      &     +a33*muij(4)
4259           if (shield_mode.eq.0) then
4260            fac_shield(i)=1.0
4261            fac_shield(j)=1.0
4262 C          else
4263 C           fac_shield(i)=0.4
4264 C           fac_shield(j)=0.6
4265           endif
4266           eel_loc_ij=eel_loc_ij
4267      &    *fac_shield(i)*fac_shield(j)
4268 C Now derivative over eel_loc
4269           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4270      &  (shield_mode.gt.0)) then
4271 C          print *,i,j
4272
4273           do ilist=1,ishield_list(i)
4274            iresshield=shield_list(ilist,i)
4275            do k=1,3
4276            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4277      &                                          /fac_shield(i)
4278 C     &      *2.0
4279            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4280      &              rlocshield
4281      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4282             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4283      &      +rlocshield
4284            enddo
4285           enddo
4286           do ilist=1,ishield_list(j)
4287            iresshield=shield_list(ilist,j)
4288            do k=1,3
4289            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4290      &                                       /fac_shield(j)
4291 C     &     *2.0
4292            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4293      &              rlocshield
4294      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4295            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4296      &             +rlocshield
4297
4298            enddo
4299           enddo
4300
4301           do k=1,3
4302             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4303      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4304             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4305      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4306             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4307      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4308             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4309      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4310            enddo
4311            endif
4312
4313
4314 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4315 c     &                     ' eel_loc_ij',eel_loc_ij
4316 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4317 C Calculate patrial derivative for theta angle
4318 #ifdef NEWCORR
4319          geel_loc_ij=(a22*gmuij1(1)
4320      &     +a23*gmuij1(2)
4321      &     +a32*gmuij1(3)
4322      &     +a33*gmuij1(4))
4323      &    *fac_shield(i)*fac_shield(j)
4324 c         write(iout,*) "derivative over thatai"
4325 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4326 c     &   a33*gmuij1(4)
4327          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4328      &      geel_loc_ij*wel_loc
4329 c         write(iout,*) "derivative over thatai-1"
4330 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4331 c     &   a33*gmuij2(4)
4332          geel_loc_ij=
4333      &     a22*gmuij2(1)
4334      &     +a23*gmuij2(2)
4335      &     +a32*gmuij2(3)
4336      &     +a33*gmuij2(4)
4337          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4338      &      geel_loc_ij*wel_loc
4339      &    *fac_shield(i)*fac_shield(j)
4340
4341 c  Derivative over j residue
4342          geel_loc_ji=a22*gmuji1(1)
4343      &     +a23*gmuji1(2)
4344      &     +a32*gmuji1(3)
4345      &     +a33*gmuji1(4)
4346 c         write(iout,*) "derivative over thataj"
4347 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4348 c     &   a33*gmuji1(4)
4349
4350         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4351      &      geel_loc_ji*wel_loc
4352      &    *fac_shield(i)*fac_shield(j)
4353
4354          geel_loc_ji=
4355      &     +a22*gmuji2(1)
4356      &     +a23*gmuji2(2)
4357      &     +a32*gmuji2(3)
4358      &     +a33*gmuji2(4)
4359 c         write(iout,*) "derivative over thataj-1"
4360 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4361 c     &   a33*gmuji2(4)
4362          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4363      &      geel_loc_ji*wel_loc
4364      &    *fac_shield(i)*fac_shield(j)
4365 #endif
4366 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4367
4368           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4369      &            'eelloc',i,j,eel_loc_ij
4370 c           if (eel_loc_ij.ne.0)
4371 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4372 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4373
4374           eel_loc=eel_loc+eel_loc_ij
4375 C Partial derivatives in virtual-bond dihedral angles gamma
4376           if (i.gt.1)
4377      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4378      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4379      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4380      &    *fac_shield(i)*fac_shield(j)
4381
4382           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4383      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4384      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4385      &    *fac_shield(i)*fac_shield(j)
4386 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4387           do l=1,3
4388             ggg(l)=(agg(l,1)*muij(1)+
4389      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4390      &    *fac_shield(i)*fac_shield(j)
4391             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4392             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4393 cgrad            ghalf=0.5d0*ggg(l)
4394 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4395 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4396           enddo
4397 cgrad          do k=i+1,j2
4398 cgrad            do l=1,3
4399 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4400 cgrad            enddo
4401 cgrad          enddo
4402 C Remaining derivatives of eello
4403           do l=1,3
4404             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4405      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4406      &    *fac_shield(i)*fac_shield(j)
4407
4408             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4409      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4410      &    *fac_shield(i)*fac_shield(j)
4411
4412             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4413      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4414      &    *fac_shield(i)*fac_shield(j)
4415
4416             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4417      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4418      &    *fac_shield(i)*fac_shield(j)
4419
4420           enddo
4421           ENDIF
4422 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4423 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4424           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4425      &       .and. num_conti.le.maxconts) then
4426 c            write (iout,*) i,j," entered corr"
4427 C
4428 C Calculate the contact function. The ith column of the array JCONT will
4429 C contain the numbers of atoms that make contacts with the atom I (of numbers
4430 C greater than I). The arrays FACONT and GACONT will contain the values of
4431 C the contact function and its derivative.
4432 c           r0ij=1.02D0*rpp(iteli,itelj)
4433 c           r0ij=1.11D0*rpp(iteli,itelj)
4434             r0ij=2.20D0*rpp(iteli,itelj)
4435 c           r0ij=1.55D0*rpp(iteli,itelj)
4436             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4437             if (fcont.gt.0.0D0) then
4438               num_conti=num_conti+1
4439               if (num_conti.gt.maxconts) then
4440                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4441      &                         ' will skip next contacts for this conf.'
4442               else
4443                 jcont_hb(num_conti,i)=j
4444 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4445 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4446                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4447      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4448 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4449 C  terms.
4450                 d_cont(num_conti,i)=rij
4451 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4452 C     --- Electrostatic-interaction matrix ---
4453                 a_chuj(1,1,num_conti,i)=a22
4454                 a_chuj(1,2,num_conti,i)=a23
4455                 a_chuj(2,1,num_conti,i)=a32
4456                 a_chuj(2,2,num_conti,i)=a33
4457 C     --- Gradient of rij
4458                 do kkk=1,3
4459                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4460                 enddo
4461                 kkll=0
4462                 do k=1,2
4463                   do l=1,2
4464                     kkll=kkll+1
4465                     do m=1,3
4466                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4467                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4468                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4469                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4470                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4471                     enddo
4472                   enddo
4473                 enddo
4474                 ENDIF
4475                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4476 C Calculate contact energies
4477                 cosa4=4.0D0*cosa
4478                 wij=cosa-3.0D0*cosb*cosg
4479                 cosbg1=cosb+cosg
4480                 cosbg2=cosb-cosg
4481 c               fac3=dsqrt(-ael6i)/r0ij**3
4482                 fac3=dsqrt(-ael6i)*r3ij
4483 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4484                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4485                 if (ees0tmp.gt.0) then
4486                   ees0pij=dsqrt(ees0tmp)
4487                 else
4488                   ees0pij=0
4489                 endif
4490 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4491                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4492                 if (ees0tmp.gt.0) then
4493                   ees0mij=dsqrt(ees0tmp)
4494                 else
4495                   ees0mij=0
4496                 endif
4497 c               ees0mij=0.0D0
4498                 if (shield_mode.eq.0) then
4499                 fac_shield(i)=1.0d0
4500                 fac_shield(j)=1.0d0
4501                 else
4502                 ees0plist(num_conti,i)=j
4503 C                fac_shield(i)=0.4d0
4504 C                fac_shield(j)=0.6d0
4505                 endif
4506                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4507      &          *fac_shield(i)*fac_shield(j)
4508                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4509      &          *fac_shield(i)*fac_shield(j)
4510 C Diagnostics. Comment out or remove after debugging!
4511 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4512 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4513 c               ees0m(num_conti,i)=0.0D0
4514 C End diagnostics.
4515 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4516 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4517 C Angular derivatives of the contact function
4518                 ees0pij1=fac3/ees0pij
4519                 ees0mij1=fac3/ees0mij
4520                 fac3p=-3.0D0*fac3*rrmij
4521                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4522                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4523 c               ees0mij1=0.0D0
4524                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4525                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4526                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4527                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4528                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4529                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4530                 ecosap=ecosa1+ecosa2
4531                 ecosbp=ecosb1+ecosb2
4532                 ecosgp=ecosg1+ecosg2
4533                 ecosam=ecosa1-ecosa2
4534                 ecosbm=ecosb1-ecosb2
4535                 ecosgm=ecosg1-ecosg2
4536 C Diagnostics
4537 c               ecosap=ecosa1
4538 c               ecosbp=ecosb1
4539 c               ecosgp=ecosg1
4540 c               ecosam=0.0D0
4541 c               ecosbm=0.0D0
4542 c               ecosgm=0.0D0
4543 C End diagnostics
4544                 facont_hb(num_conti,i)=fcont
4545                 fprimcont=fprimcont/rij
4546 cd              facont_hb(num_conti,i)=1.0D0
4547 C Following line is for diagnostics.
4548 cd              fprimcont=0.0D0
4549                 do k=1,3
4550                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4551                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4552                 enddo
4553                 do k=1,3
4554                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4555                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4556                 enddo
4557                 gggp(1)=gggp(1)+ees0pijp*xj
4558                 gggp(2)=gggp(2)+ees0pijp*yj
4559                 gggp(3)=gggp(3)+ees0pijp*zj
4560                 gggm(1)=gggm(1)+ees0mijp*xj
4561                 gggm(2)=gggm(2)+ees0mijp*yj
4562                 gggm(3)=gggm(3)+ees0mijp*zj
4563 C Derivatives due to the contact function
4564                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4565                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4566                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4567                 do k=1,3
4568 c
4569 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4570 c          following the change of gradient-summation algorithm.
4571 c
4572 cgrad                  ghalfp=0.5D0*gggp(k)
4573 cgrad                  ghalfm=0.5D0*gggm(k)
4574                   gacontp_hb1(k,num_conti,i)=!ghalfp
4575      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4576      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4577      &          *fac_shield(i)*fac_shield(j)
4578
4579                   gacontp_hb2(k,num_conti,i)=!ghalfp
4580      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4581      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4582      &          *fac_shield(i)*fac_shield(j)
4583
4584                   gacontp_hb3(k,num_conti,i)=gggp(k)
4585      &          *fac_shield(i)*fac_shield(j)
4586
4587                   gacontm_hb1(k,num_conti,i)=!ghalfm
4588      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4589      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4590      &          *fac_shield(i)*fac_shield(j)
4591
4592                   gacontm_hb2(k,num_conti,i)=!ghalfm
4593      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4594      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4595      &          *fac_shield(i)*fac_shield(j)
4596
4597                   gacontm_hb3(k,num_conti,i)=gggm(k)
4598      &          *fac_shield(i)*fac_shield(j)
4599
4600                 enddo
4601 C Diagnostics. Comment out or remove after debugging!
4602 cdiag           do k=1,3
4603 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4604 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4605 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4606 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4607 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4608 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4609 cdiag           enddo
4610               ENDIF ! wcorr
4611               endif  ! num_conti.le.maxconts
4612             endif  ! fcont.gt.0
4613           endif    ! j.gt.i+1
4614           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4615             do k=1,4
4616               do l=1,3
4617                 ghalf=0.5d0*agg(l,k)
4618                 aggi(l,k)=aggi(l,k)+ghalf
4619                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4620                 aggj(l,k)=aggj(l,k)+ghalf
4621               enddo
4622             enddo
4623             if (j.eq.nres-1 .and. i.lt.j-2) then
4624               do k=1,4
4625                 do l=1,3
4626                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4627                 enddo
4628               enddo
4629             endif
4630           endif
4631 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4632       return
4633       end
4634 C-----------------------------------------------------------------------------
4635       subroutine eturn3(i,eello_turn3)
4636 C Third- and fourth-order contributions from turns
4637       implicit real*8 (a-h,o-z)
4638       include 'DIMENSIONS'
4639       include 'COMMON.IOUNITS'
4640       include 'COMMON.GEO'
4641       include 'COMMON.VAR'
4642       include 'COMMON.LOCAL'
4643       include 'COMMON.CHAIN'
4644       include 'COMMON.DERIV'
4645       include 'COMMON.INTERACT'
4646       include 'COMMON.CONTACTS'
4647       include 'COMMON.TORSION'
4648       include 'COMMON.VECTORS'
4649       include 'COMMON.FFIELD'
4650       include 'COMMON.CONTROL'
4651       include 'COMMON.SHIELD'
4652       dimension ggg(3)
4653       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4654      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4655      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4656      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4657      &  auxgmat2(2,2),auxgmatt2(2,2)
4658       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4659      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4660       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4661      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4662      &    num_conti,j1,j2
4663       j=i+2
4664 c      write (iout,*) "eturn3",i,j,j1,j2
4665       a_temp(1,1)=a22
4666       a_temp(1,2)=a23
4667       a_temp(2,1)=a32
4668       a_temp(2,2)=a33
4669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4670 C
4671 C               Third-order contributions
4672 C
4673 C                 (i+2)o----(i+3)
4674 C                      | |
4675 C                      | |
4676 C                 (i+1)o----i
4677 C
4678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4679 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4680         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4681 c auxalary matices for theta gradient
4682 c auxalary matrix for i+1 and constant i+2
4683         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4684 c auxalary matrix for i+2 and constant i+1
4685         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4686         call transpose2(auxmat(1,1),auxmat1(1,1))
4687         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4688         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4689         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4690         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4691         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4692         if (shield_mode.eq.0) then
4693         fac_shield(i)=1.0
4694         fac_shield(j)=1.0
4695 C        else
4696 C        fac_shield(i)=0.4
4697 C        fac_shield(j)=0.6
4698         endif
4699         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4700      &  *fac_shield(i)*fac_shield(j)
4701         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4702      &  *fac_shield(i)*fac_shield(j)
4703 C#ifdef NEWCORR
4704 C Derivatives in theta
4705         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4706      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4707      &   *fac_shield(i)*fac_shield(j)
4708         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4709      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4710      &   *fac_shield(i)*fac_shield(j)
4711 C#endif
4712
4713 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4714 C Derivatives in shield mode
4715           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4716      &  (shield_mode.gt.0)) then
4717 C          print *,i,j
4718
4719           do ilist=1,ishield_list(i)
4720            iresshield=shield_list(ilist,i)
4721            do k=1,3
4722            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4723 C     &      *2.0
4724            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4725      &              rlocshield
4726      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4727             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4728      &      +rlocshield
4729            enddo
4730           enddo
4731           do ilist=1,ishield_list(j)
4732            iresshield=shield_list(ilist,j)
4733            do k=1,3
4734            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4735 C     &     *2.0
4736            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4737      &              rlocshield
4738      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4739            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4740      &             +rlocshield
4741
4742            enddo
4743           enddo
4744
4745           do k=1,3
4746             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4747      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4748             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4749      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4750             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4751      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4752             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4753      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4754            enddo
4755            endif
4756
4757 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4758 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4759 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4760 cd     &    ' eello_turn3_num',4*eello_turn3_num
4761 C Derivatives in gamma(i)
4762         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4763         call transpose2(auxmat2(1,1),auxmat3(1,1))
4764         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4765         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4766      &   *fac_shield(i)*fac_shield(j)
4767 C Derivatives in gamma(i+1)
4768         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4769         call transpose2(auxmat2(1,1),auxmat3(1,1))
4770         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4771         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4772      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4773      &   *fac_shield(i)*fac_shield(j)
4774 C Cartesian derivatives
4775         do l=1,3
4776 c            ghalf1=0.5d0*agg(l,1)
4777 c            ghalf2=0.5d0*agg(l,2)
4778 c            ghalf3=0.5d0*agg(l,3)
4779 c            ghalf4=0.5d0*agg(l,4)
4780           a_temp(1,1)=aggi(l,1)!+ghalf1
4781           a_temp(1,2)=aggi(l,2)!+ghalf2
4782           a_temp(2,1)=aggi(l,3)!+ghalf3
4783           a_temp(2,2)=aggi(l,4)!+ghalf4
4784           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4785           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4786      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4787      &   *fac_shield(i)*fac_shield(j)
4788
4789           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4790           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4791           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4792           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4793           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4794           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4795      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4796      &   *fac_shield(i)*fac_shield(j)
4797           a_temp(1,1)=aggj(l,1)!+ghalf1
4798           a_temp(1,2)=aggj(l,2)!+ghalf2
4799           a_temp(2,1)=aggj(l,3)!+ghalf3
4800           a_temp(2,2)=aggj(l,4)!+ghalf4
4801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4802           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4804      &   *fac_shield(i)*fac_shield(j)
4805           a_temp(1,1)=aggj1(l,1)
4806           a_temp(1,2)=aggj1(l,2)
4807           a_temp(2,1)=aggj1(l,3)
4808           a_temp(2,2)=aggj1(l,4)
4809           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4810           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4811      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4812      &   *fac_shield(i)*fac_shield(j)
4813         enddo
4814       return
4815       end
4816 C-------------------------------------------------------------------------------
4817       subroutine eturn4(i,eello_turn4)
4818 C Third- and fourth-order contributions from turns
4819       implicit real*8 (a-h,o-z)
4820       include 'DIMENSIONS'
4821       include 'COMMON.IOUNITS'
4822       include 'COMMON.GEO'
4823       include 'COMMON.VAR'
4824       include 'COMMON.LOCAL'
4825       include 'COMMON.CHAIN'
4826       include 'COMMON.DERIV'
4827       include 'COMMON.INTERACT'
4828       include 'COMMON.CONTACTS'
4829       include 'COMMON.TORSION'
4830       include 'COMMON.VECTORS'
4831       include 'COMMON.FFIELD'
4832       include 'COMMON.CONTROL'
4833       include 'COMMON.SHIELD'
4834       dimension ggg(3)
4835       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4836      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4837      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4838      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4839      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4840      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4841      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4846      &    num_conti,j1,j2
4847       j=i+3
4848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4849 C
4850 C               Fourth-order contributions
4851 C
4852 C                 (i+3)o----(i+4)
4853 C                     /  |
4854 C               (i+2)o   |
4855 C                     \  |
4856 C                 (i+1)o----i
4857 C
4858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4861 c        write(iout,*)"WCHODZE W PROGRAM"
4862         a_temp(1,1)=a22
4863         a_temp(1,2)=a23
4864         a_temp(2,1)=a32
4865         a_temp(2,2)=a33
4866         iti1=itype2loc(itype(i+1))
4867         iti2=itype2loc(itype(i+2))
4868         iti3=itype2loc(itype(i+3))
4869 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4870         call transpose2(EUg(1,1,i+1),e1t(1,1))
4871         call transpose2(Eug(1,1,i+2),e2t(1,1))
4872         call transpose2(Eug(1,1,i+3),e3t(1,1))
4873 C Ematrix derivative in theta
4874         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4875         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4876         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4877         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4878 c       eta1 in derivative theta
4879         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4880         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4881 c       auxgvec is derivative of Ub2 so i+3 theta
4882         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4883 c       auxalary matrix of E i+1
4884         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4885 c        s1=0.0
4886 c        gs1=0.0
4887         s1=scalar2(b1(1,i+2),auxvec(1))
4888 c derivative of theta i+2 with constant i+3
4889         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4890 c derivative of theta i+2 with constant i+2
4891         gs32=scalar2(b1(1,i+2),auxgvec(1))
4892 c derivative of E matix in theta of i+1
4893         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4894
4895         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4896 c       ea31 in derivative theta
4897         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4898         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4899 c auxilary matrix auxgvec of Ub2 with constant E matirx
4900         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4901 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4902         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4903
4904 c        s2=0.0
4905 c        gs2=0.0
4906         s2=scalar2(b1(1,i+1),auxvec(1))
4907 c derivative of theta i+1 with constant i+3
4908         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4909 c derivative of theta i+2 with constant i+1
4910         gs21=scalar2(b1(1,i+1),auxgvec(1))
4911 c derivative of theta i+3 with constant i+1
4912         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4913 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4914 c     &  gtb1(1,i+1)
4915         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4916 c two derivatives over diffetent matrices
4917 c gtae3e2 is derivative over i+3
4918         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4919 c ae3gte2 is derivative over i+2
4920         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4921         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4922 c three possible derivative over theta E matices
4923 c i+1
4924         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4925 c i+2
4926         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4927 c i+3
4928         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4929         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4930
4931         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4932         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4933         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4934         if (shield_mode.eq.0) then
4935         fac_shield(i)=1.0
4936         fac_shield(j)=1.0
4937 C        else
4938 C        fac_shield(i)=0.6
4939 C        fac_shield(j)=0.4
4940         endif
4941         eello_turn4=eello_turn4-(s1+s2+s3)
4942      &  *fac_shield(i)*fac_shield(j)
4943         eello_t4=-(s1+s2+s3)
4944      &  *fac_shield(i)*fac_shield(j)
4945 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4946         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4947      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4948 C Now derivative over shield:
4949           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4950      &  (shield_mode.gt.0)) then
4951 C          print *,i,j
4952
4953           do ilist=1,ishield_list(i)
4954            iresshield=shield_list(ilist,i)
4955            do k=1,3
4956            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4957 C     &      *2.0
4958            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4959      &              rlocshield
4960      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4961             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4962      &      +rlocshield
4963            enddo
4964           enddo
4965           do ilist=1,ishield_list(j)
4966            iresshield=shield_list(ilist,j)
4967            do k=1,3
4968            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4969 C     &     *2.0
4970            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4971      &              rlocshield
4972      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4973            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4974      &             +rlocshield
4975
4976            enddo
4977           enddo
4978
4979           do k=1,3
4980             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4981      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4982             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4983      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4984             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4985      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4986             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4987      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4988            enddo
4989            endif
4990
4991
4992
4993
4994
4995
4996 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4997 cd     &    ' eello_turn4_num',8*eello_turn4_num
4998 #ifdef NEWCORR
4999         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5000      &                  -(gs13+gsE13+gsEE1)*wturn4
5001      &  *fac_shield(i)*fac_shield(j)
5002         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5003      &                    -(gs23+gs21+gsEE2)*wturn4
5004      &  *fac_shield(i)*fac_shield(j)
5005
5006         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5007      &                    -(gs32+gsE31+gsEE3)*wturn4
5008      &  *fac_shield(i)*fac_shield(j)
5009
5010 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5011 c     &   gs2
5012 #endif
5013         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5014      &      'eturn4',i,j,-(s1+s2+s3)
5015 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5016 c     &    ' eello_turn4_num',8*eello_turn4_num
5017 C Derivatives in gamma(i)
5018         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5019         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5020         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5021         s1=scalar2(b1(1,i+2),auxvec(1))
5022         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5023         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5024         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5025      &  *fac_shield(i)*fac_shield(j)
5026 C Derivatives in gamma(i+1)
5027         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5028         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5029         s2=scalar2(b1(1,i+1),auxvec(1))
5030         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5031         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5032         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5033         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5034      &  *fac_shield(i)*fac_shield(j)
5035 C Derivatives in gamma(i+2)
5036         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5037         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5038         s1=scalar2(b1(1,i+2),auxvec(1))
5039         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5040         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5041         s2=scalar2(b1(1,i+1),auxvec(1))
5042         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5043         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5044         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5045         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5046      &  *fac_shield(i)*fac_shield(j)
5047 C Cartesian derivatives
5048 C Derivatives of this turn contributions in DC(i+2)
5049         if (j.lt.nres-1) then
5050           do l=1,3
5051             a_temp(1,1)=agg(l,1)
5052             a_temp(1,2)=agg(l,2)
5053             a_temp(2,1)=agg(l,3)
5054             a_temp(2,2)=agg(l,4)
5055             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5056             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5057             s1=scalar2(b1(1,i+2),auxvec(1))
5058             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5059             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5060             s2=scalar2(b1(1,i+1),auxvec(1))
5061             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5062             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5063             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5064             ggg(l)=-(s1+s2+s3)
5065             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5066      &  *fac_shield(i)*fac_shield(j)
5067           enddo
5068         endif
5069 C Remaining derivatives of this turn contribution
5070         do l=1,3
5071           a_temp(1,1)=aggi(l,1)
5072           a_temp(1,2)=aggi(l,2)
5073           a_temp(2,1)=aggi(l,3)
5074           a_temp(2,2)=aggi(l,4)
5075           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5076           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5077           s1=scalar2(b1(1,i+2),auxvec(1))
5078           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5079           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5080           s2=scalar2(b1(1,i+1),auxvec(1))
5081           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5082           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5083           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5084           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5085      &  *fac_shield(i)*fac_shield(j)
5086           a_temp(1,1)=aggi1(l,1)
5087           a_temp(1,2)=aggi1(l,2)
5088           a_temp(2,1)=aggi1(l,3)
5089           a_temp(2,2)=aggi1(l,4)
5090           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5091           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5092           s1=scalar2(b1(1,i+2),auxvec(1))
5093           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5094           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5095           s2=scalar2(b1(1,i+1),auxvec(1))
5096           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5097           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5098           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5099           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5100      &  *fac_shield(i)*fac_shield(j)
5101           a_temp(1,1)=aggj(l,1)
5102           a_temp(1,2)=aggj(l,2)
5103           a_temp(2,1)=aggj(l,3)
5104           a_temp(2,2)=aggj(l,4)
5105           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5106           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5107           s1=scalar2(b1(1,i+2),auxvec(1))
5108           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5109           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5110           s2=scalar2(b1(1,i+1),auxvec(1))
5111           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5112           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5113           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5114           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5115      &  *fac_shield(i)*fac_shield(j)
5116           a_temp(1,1)=aggj1(l,1)
5117           a_temp(1,2)=aggj1(l,2)
5118           a_temp(2,1)=aggj1(l,3)
5119           a_temp(2,2)=aggj1(l,4)
5120           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5121           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5122           s1=scalar2(b1(1,i+2),auxvec(1))
5123           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5124           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5125           s2=scalar2(b1(1,i+1),auxvec(1))
5126           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5127           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5128           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5129 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5130           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5131      &  *fac_shield(i)*fac_shield(j)
5132         enddo
5133       return
5134       end
5135 C-----------------------------------------------------------------------------
5136       subroutine vecpr(u,v,w)
5137       implicit real*8(a-h,o-z)
5138       dimension u(3),v(3),w(3)
5139       w(1)=u(2)*v(3)-u(3)*v(2)
5140       w(2)=-u(1)*v(3)+u(3)*v(1)
5141       w(3)=u(1)*v(2)-u(2)*v(1)
5142       return
5143       end
5144 C-----------------------------------------------------------------------------
5145       subroutine unormderiv(u,ugrad,unorm,ungrad)
5146 C This subroutine computes the derivatives of a normalized vector u, given
5147 C the derivatives computed without normalization conditions, ugrad. Returns
5148 C ungrad.
5149       implicit none
5150       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5151       double precision vec(3)
5152       double precision scalar
5153       integer i,j
5154 c      write (2,*) 'ugrad',ugrad
5155 c      write (2,*) 'u',u
5156       do i=1,3
5157         vec(i)=scalar(ugrad(1,i),u(1))
5158       enddo
5159 c      write (2,*) 'vec',vec
5160       do i=1,3
5161         do j=1,3
5162           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5163         enddo
5164       enddo
5165 c      write (2,*) 'ungrad',ungrad
5166       return
5167       end
5168 C-----------------------------------------------------------------------------
5169       subroutine escp_soft_sphere(evdw2,evdw2_14)
5170 C
5171 C This subroutine calculates the excluded-volume interaction energy between
5172 C peptide-group centers and side chains and its gradient in virtual-bond and
5173 C side-chain vectors.
5174 C
5175       implicit real*8 (a-h,o-z)
5176       include 'DIMENSIONS'
5177       include 'COMMON.GEO'
5178       include 'COMMON.VAR'
5179       include 'COMMON.LOCAL'
5180       include 'COMMON.CHAIN'
5181       include 'COMMON.DERIV'
5182       include 'COMMON.INTERACT'
5183       include 'COMMON.FFIELD'
5184       include 'COMMON.IOUNITS'
5185       include 'COMMON.CONTROL'
5186       dimension ggg(3)
5187       evdw2=0.0D0
5188       evdw2_14=0.0d0
5189       r0_scp=4.5d0
5190 cd    print '(a)','Enter ESCP'
5191 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5192 C      do xshift=-1,1
5193 C      do yshift=-1,1
5194 C      do zshift=-1,1
5195       do i=iatscp_s,iatscp_e
5196         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5197         iteli=itel(i)
5198         xi=0.5D0*(c(1,i)+c(1,i+1))
5199         yi=0.5D0*(c(2,i)+c(2,i+1))
5200         zi=0.5D0*(c(3,i)+c(3,i+1))
5201 C Return atom into box, boxxsize is size of box in x dimension
5202 c  134   continue
5203 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5204 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5205 C Condition for being inside the proper box
5206 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5207 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5208 c        go to 134
5209 c        endif
5210 c  135   continue
5211 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5212 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5213 C Condition for being inside the proper box
5214 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5215 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5216 c        go to 135
5217 c c       endif
5218 c  136   continue
5219 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5220 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5221 cC Condition for being inside the proper box
5222 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5223 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5224 c        go to 136
5225 c        endif
5226           xi=mod(xi,boxxsize)
5227           if (xi.lt.0) xi=xi+boxxsize
5228           yi=mod(yi,boxysize)
5229           if (yi.lt.0) yi=yi+boxysize
5230           zi=mod(zi,boxzsize)
5231           if (zi.lt.0) zi=zi+boxzsize
5232 C          xi=xi+xshift*boxxsize
5233 C          yi=yi+yshift*boxysize
5234 C          zi=zi+zshift*boxzsize
5235         do iint=1,nscp_gr(i)
5236
5237         do j=iscpstart(i,iint),iscpend(i,iint)
5238           if (itype(j).eq.ntyp1) cycle
5239           itypj=iabs(itype(j))
5240 C Uncomment following three lines for SC-p interactions
5241 c         xj=c(1,nres+j)-xi
5242 c         yj=c(2,nres+j)-yi
5243 c         zj=c(3,nres+j)-zi
5244 C Uncomment following three lines for Ca-p interactions
5245           xj=c(1,j)
5246           yj=c(2,j)
5247           zj=c(3,j)
5248 c  174   continue
5249 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5250 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5251 C Condition for being inside the proper box
5252 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5253 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5254 c        go to 174
5255 c        endif
5256 c  175   continue
5257 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5258 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5259 cC Condition for being inside the proper box
5260 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5261 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5262 c        go to 175
5263 c        endif
5264 c  176   continue
5265 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5266 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5267 C Condition for being inside the proper box
5268 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5269 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5270 c        go to 176
5271           xj=mod(xj,boxxsize)
5272           if (xj.lt.0) xj=xj+boxxsize
5273           yj=mod(yj,boxysize)
5274           if (yj.lt.0) yj=yj+boxysize
5275           zj=mod(zj,boxzsize)
5276           if (zj.lt.0) zj=zj+boxzsize
5277       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5278       xj_safe=xj
5279       yj_safe=yj
5280       zj_safe=zj
5281       subchap=0
5282       do xshift=-1,1
5283       do yshift=-1,1
5284       do zshift=-1,1
5285           xj=xj_safe+xshift*boxxsize
5286           yj=yj_safe+yshift*boxysize
5287           zj=zj_safe+zshift*boxzsize
5288           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5289           if(dist_temp.lt.dist_init) then
5290             dist_init=dist_temp
5291             xj_temp=xj
5292             yj_temp=yj
5293             zj_temp=zj
5294             subchap=1
5295           endif
5296        enddo
5297        enddo
5298        enddo
5299        if (subchap.eq.1) then
5300           xj=xj_temp-xi
5301           yj=yj_temp-yi
5302           zj=zj_temp-zi
5303        else
5304           xj=xj_safe-xi
5305           yj=yj_safe-yi
5306           zj=zj_safe-zi
5307        endif
5308 c c       endif
5309 C          xj=xj-xi
5310 C          yj=yj-yi
5311 C          zj=zj-zi
5312           rij=xj*xj+yj*yj+zj*zj
5313
5314           r0ij=r0_scp
5315           r0ijsq=r0ij*r0ij
5316           if (rij.lt.r0ijsq) then
5317             evdwij=0.25d0*(rij-r0ijsq)**2
5318             fac=rij-r0ijsq
5319           else
5320             evdwij=0.0d0
5321             fac=0.0d0
5322           endif
5323           evdw2=evdw2+evdwij
5324 C
5325 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5326 C
5327           ggg(1)=xj*fac
5328           ggg(2)=yj*fac
5329           ggg(3)=zj*fac
5330 cgrad          if (j.lt.i) then
5331 cd          write (iout,*) 'j<i'
5332 C Uncomment following three lines for SC-p interactions
5333 c           do k=1,3
5334 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5335 c           enddo
5336 cgrad          else
5337 cd          write (iout,*) 'j>i'
5338 cgrad            do k=1,3
5339 cgrad              ggg(k)=-ggg(k)
5340 C Uncomment following line for SC-p interactions
5341 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5342 cgrad            enddo
5343 cgrad          endif
5344 cgrad          do k=1,3
5345 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5346 cgrad          enddo
5347 cgrad          kstart=min0(i+1,j)
5348 cgrad          kend=max0(i-1,j-1)
5349 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5350 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5351 cgrad          do k=kstart,kend
5352 cgrad            do l=1,3
5353 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5354 cgrad            enddo
5355 cgrad          enddo
5356           do k=1,3
5357             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5358             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5359           enddo
5360         enddo
5361
5362         enddo ! iint
5363       enddo ! i
5364 C      enddo !zshift
5365 C      enddo !yshift
5366 C      enddo !xshift
5367       return
5368       end
5369 C-----------------------------------------------------------------------------
5370       subroutine escp(evdw2,evdw2_14)
5371 C
5372 C This subroutine calculates the excluded-volume interaction energy between
5373 C peptide-group centers and side chains and its gradient in virtual-bond and
5374 C side-chain vectors.
5375 C
5376       implicit real*8 (a-h,o-z)
5377       include 'DIMENSIONS'
5378       include 'COMMON.GEO'
5379       include 'COMMON.VAR'
5380       include 'COMMON.LOCAL'
5381       include 'COMMON.CHAIN'
5382       include 'COMMON.DERIV'
5383       include 'COMMON.INTERACT'
5384       include 'COMMON.FFIELD'
5385       include 'COMMON.IOUNITS'
5386       include 'COMMON.CONTROL'
5387       include 'COMMON.SPLITELE'
5388       dimension ggg(3)
5389       evdw2=0.0D0
5390       evdw2_14=0.0d0
5391 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5392 cd    print '(a)','Enter ESCP'
5393 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5394 C      do xshift=-1,1
5395 C      do yshift=-1,1
5396 C      do zshift=-1,1
5397       do i=iatscp_s,iatscp_e
5398         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5399         iteli=itel(i)
5400         xi=0.5D0*(c(1,i)+c(1,i+1))
5401         yi=0.5D0*(c(2,i)+c(2,i+1))
5402         zi=0.5D0*(c(3,i)+c(3,i+1))
5403           xi=mod(xi,boxxsize)
5404           if (xi.lt.0) xi=xi+boxxsize
5405           yi=mod(yi,boxysize)
5406           if (yi.lt.0) yi=yi+boxysize
5407           zi=mod(zi,boxzsize)
5408           if (zi.lt.0) zi=zi+boxzsize
5409 c          xi=xi+xshift*boxxsize
5410 c          yi=yi+yshift*boxysize
5411 c          zi=zi+zshift*boxzsize
5412 c        print *,xi,yi,zi,'polozenie i'
5413 C Return atom into box, boxxsize is size of box in x dimension
5414 c  134   continue
5415 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5416 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5417 C Condition for being inside the proper box
5418 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5419 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5420 c        go to 134
5421 c        endif
5422 c  135   continue
5423 c          print *,xi,boxxsize,"pierwszy"
5424
5425 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5426 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5427 C Condition for being inside the proper box
5428 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5429 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5430 c        go to 135
5431 c        endif
5432 c  136   continue
5433 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5434 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5435 C Condition for being inside the proper box
5436 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5437 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5438 c        go to 136
5439 c        endif
5440         do iint=1,nscp_gr(i)
5441
5442         do j=iscpstart(i,iint),iscpend(i,iint)
5443           itypj=iabs(itype(j))
5444           if (itypj.eq.ntyp1) cycle
5445 C Uncomment following three lines for SC-p interactions
5446 c         xj=c(1,nres+j)-xi
5447 c         yj=c(2,nres+j)-yi
5448 c         zj=c(3,nres+j)-zi
5449 C Uncomment following three lines for Ca-p interactions
5450           xj=c(1,j)
5451           yj=c(2,j)
5452           zj=c(3,j)
5453           xj=mod(xj,boxxsize)
5454           if (xj.lt.0) xj=xj+boxxsize
5455           yj=mod(yj,boxysize)
5456           if (yj.lt.0) yj=yj+boxysize
5457           zj=mod(zj,boxzsize)
5458           if (zj.lt.0) zj=zj+boxzsize
5459 c  174   continue
5460 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5461 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5462 C Condition for being inside the proper box
5463 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5464 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5465 c        go to 174
5466 c        endif
5467 c  175   continue
5468 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5469 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5470 cC Condition for being inside the proper box
5471 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5472 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5473 c        go to 175
5474 c        endif
5475 c  176   continue
5476 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5477 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5478 C Condition for being inside the proper box
5479 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5480 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5481 c        go to 176
5482 c        endif
5483 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5484       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5485       xj_safe=xj
5486       yj_safe=yj
5487       zj_safe=zj
5488       subchap=0
5489       do xshift=-1,1
5490       do yshift=-1,1
5491       do zshift=-1,1
5492           xj=xj_safe+xshift*boxxsize
5493           yj=yj_safe+yshift*boxysize
5494           zj=zj_safe+zshift*boxzsize
5495           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5496           if(dist_temp.lt.dist_init) then
5497             dist_init=dist_temp
5498             xj_temp=xj
5499             yj_temp=yj
5500             zj_temp=zj
5501             subchap=1
5502           endif
5503        enddo
5504        enddo
5505        enddo
5506        if (subchap.eq.1) then
5507           xj=xj_temp-xi
5508           yj=yj_temp-yi
5509           zj=zj_temp-zi
5510        else
5511           xj=xj_safe-xi
5512           yj=yj_safe-yi
5513           zj=zj_safe-zi
5514        endif
5515 c          print *,xj,yj,zj,'polozenie j'
5516           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5517 c          print *,rrij
5518           sss=sscale(1.0d0/(dsqrt(rrij)))
5519 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5520 c          if (sss.eq.0) print *,'czasem jest OK'
5521           if (sss.le.0.0d0) cycle
5522           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5523           fac=rrij**expon2
5524           e1=fac*fac*aad(itypj,iteli)
5525           e2=fac*bad(itypj,iteli)
5526           if (iabs(j-i) .le. 2) then
5527             e1=scal14*e1
5528             e2=scal14*e2
5529             evdw2_14=evdw2_14+(e1+e2)*sss
5530           endif
5531           evdwij=e1+e2
5532           evdw2=evdw2+evdwij*sss
5533           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5534      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5535      &       bad(itypj,iteli)
5536 C
5537 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5538 C
5539           fac=-(evdwij+e1)*rrij*sss
5540           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5541           ggg(1)=xj*fac
5542           ggg(2)=yj*fac
5543           ggg(3)=zj*fac
5544 cgrad          if (j.lt.i) then
5545 cd          write (iout,*) 'j<i'
5546 C Uncomment following three lines for SC-p interactions
5547 c           do k=1,3
5548 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5549 c           enddo
5550 cgrad          else
5551 cd          write (iout,*) 'j>i'
5552 cgrad            do k=1,3
5553 cgrad              ggg(k)=-ggg(k)
5554 C Uncomment following line for SC-p interactions
5555 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5556 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5557 cgrad            enddo
5558 cgrad          endif
5559 cgrad          do k=1,3
5560 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5561 cgrad          enddo
5562 cgrad          kstart=min0(i+1,j)
5563 cgrad          kend=max0(i-1,j-1)
5564 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5565 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5566 cgrad          do k=kstart,kend
5567 cgrad            do l=1,3
5568 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5569 cgrad            enddo
5570 cgrad          enddo
5571           do k=1,3
5572             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5573             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5574           enddo
5575 c        endif !endif for sscale cutoff
5576         enddo ! j
5577
5578         enddo ! iint
5579       enddo ! i
5580 c      enddo !zshift
5581 c      enddo !yshift
5582 c      enddo !xshift
5583       do i=1,nct
5584         do j=1,3
5585           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5586           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5587           gradx_scp(j,i)=expon*gradx_scp(j,i)
5588         enddo
5589       enddo
5590 C******************************************************************************
5591 C
5592 C                              N O T E !!!
5593 C
5594 C To save time the factor EXPON has been extracted from ALL components
5595 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5596 C use!
5597 C
5598 C******************************************************************************
5599       return
5600       end
5601 C--------------------------------------------------------------------------
5602       subroutine edis(ehpb)
5603 C
5604 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5605 C
5606       implicit real*8 (a-h,o-z)
5607       include 'DIMENSIONS'
5608       include 'COMMON.SBRIDGE'
5609       include 'COMMON.CHAIN'
5610       include 'COMMON.DERIV'
5611       include 'COMMON.VAR'
5612       include 'COMMON.INTERACT'
5613       include 'COMMON.IOUNITS'
5614       include 'COMMON.CONTROL'
5615       dimension ggg(3)
5616       ehpb=0.0D0
5617       do i=1,3
5618        ggg(i)=0.0d0
5619       enddo
5620 C      write (iout,*) ,"link_end",link_end,constr_dist
5621 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5622 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5623       if (link_end.eq.0) return
5624       do i=link_start,link_end
5625 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5626 C CA-CA distance used in regularization of structure.
5627         ii=ihpb(i)
5628         jj=jhpb(i)
5629 C iii and jjj point to the residues for which the distance is assigned.
5630         if (ii.gt.nres) then
5631           iii=ii-nres
5632           jjj=jj-nres
5633         else
5634           iii=ii
5635           jjj=jj
5636         endif
5637 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5638 c     &    dhpb(i),dhpb1(i),forcon(i)
5639 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5640 C    distance and angle dependent SS bond potential.
5641 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5642 C     & iabs(itype(jjj)).eq.1) then
5643 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5644 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5645         if (.not.dyn_ss .and. i.le.nss) then
5646 C 15/02/13 CC dynamic SSbond - additional check
5647          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5648      & iabs(itype(jjj)).eq.1) then
5649           call ssbond_ene(iii,jjj,eij)
5650           ehpb=ehpb+2*eij
5651          endif
5652 cd          write (iout,*) "eij",eij
5653 cd   &   ' waga=',waga,' fac=',fac
5654         else if (ii.gt.nres .and. jj.gt.nres) then
5655 c Restraints from contact prediction
5656           dd=dist(ii,jj)
5657           if (constr_dist.eq.11) then
5658             ehpb=ehpb+fordepth(i)**4.0d0
5659      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5660             fac=fordepth(i)**4.0d0
5661      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5662           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5663      &    ehpb,fordepth(i),dd
5664            else
5665           if (dhpb1(i).gt.0.0d0) then
5666             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5667             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5668 c            write (iout,*) "beta nmr",
5669 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5670           else
5671             dd=dist(ii,jj)
5672             rdis=dd-dhpb(i)
5673 C Get the force constant corresponding to this distance.
5674             waga=forcon(i)
5675 C Calculate the contribution to energy.
5676             ehpb=ehpb+waga*rdis*rdis
5677 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5678 C
5679 C Evaluate gradient.
5680 C
5681             fac=waga*rdis/dd
5682           endif
5683           endif
5684           do j=1,3
5685             ggg(j)=fac*(c(j,jj)-c(j,ii))
5686           enddo
5687           do j=1,3
5688             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5689             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5690           enddo
5691           do k=1,3
5692             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5693             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5694           enddo
5695         else
5696 C Calculate the distance between the two points and its difference from the
5697 C target distance.
5698           dd=dist(ii,jj)
5699           if (constr_dist.eq.11) then
5700             ehpb=ehpb+fordepth(i)**4.0d0
5701      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5702             fac=fordepth(i)**4.0d0
5703      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5704           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5705      &    ehpb,fordepth(i),dd
5706            else
5707           if (dhpb1(i).gt.0.0d0) then
5708             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5709             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5710 c            write (iout,*) "alph nmr",
5711 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5712           else
5713             rdis=dd-dhpb(i)
5714 C Get the force constant corresponding to this distance.
5715             waga=forcon(i)
5716 C Calculate the contribution to energy.
5717             ehpb=ehpb+waga*rdis*rdis
5718 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5719 C
5720 C Evaluate gradient.
5721 C
5722             fac=waga*rdis/dd
5723           endif
5724           endif
5725             do j=1,3
5726               ggg(j)=fac*(c(j,jj)-c(j,ii))
5727             enddo
5728 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5729 C If this is a SC-SC distance, we need to calculate the contributions to the
5730 C Cartesian gradient in the SC vectors (ghpbx).
5731           if (iii.lt.ii) then
5732           do j=1,3
5733             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5734             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5735           enddo
5736           endif
5737 cgrad        do j=iii,jjj-1
5738 cgrad          do k=1,3
5739 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5740 cgrad          enddo
5741 cgrad        enddo
5742           do k=1,3
5743             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5744             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5745           enddo
5746         endif
5747       enddo
5748       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5749       return
5750       end
5751 C--------------------------------------------------------------------------
5752       subroutine ssbond_ene(i,j,eij)
5753 C
5754 C Calculate the distance and angle dependent SS-bond potential energy
5755 C using a free-energy function derived based on RHF/6-31G** ab initio
5756 C calculations of diethyl disulfide.
5757 C
5758 C A. Liwo and U. Kozlowska, 11/24/03
5759 C
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.SBRIDGE'
5763       include 'COMMON.CHAIN'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.LOCAL'
5766       include 'COMMON.INTERACT'
5767       include 'COMMON.VAR'
5768       include 'COMMON.IOUNITS'
5769       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5770       itypi=iabs(itype(i))
5771       xi=c(1,nres+i)
5772       yi=c(2,nres+i)
5773       zi=c(3,nres+i)
5774       dxi=dc_norm(1,nres+i)
5775       dyi=dc_norm(2,nres+i)
5776       dzi=dc_norm(3,nres+i)
5777 c      dsci_inv=dsc_inv(itypi)
5778       dsci_inv=vbld_inv(nres+i)
5779       itypj=iabs(itype(j))
5780 c      dscj_inv=dsc_inv(itypj)
5781       dscj_inv=vbld_inv(nres+j)
5782       xj=c(1,nres+j)-xi
5783       yj=c(2,nres+j)-yi
5784       zj=c(3,nres+j)-zi
5785       dxj=dc_norm(1,nres+j)
5786       dyj=dc_norm(2,nres+j)
5787       dzj=dc_norm(3,nres+j)
5788       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5789       rij=dsqrt(rrij)
5790       erij(1)=xj*rij
5791       erij(2)=yj*rij
5792       erij(3)=zj*rij
5793       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5794       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5795       om12=dxi*dxj+dyi*dyj+dzi*dzj
5796       do k=1,3
5797         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5798         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5799       enddo
5800       rij=1.0d0/rij
5801       deltad=rij-d0cm
5802       deltat1=1.0d0-om1
5803       deltat2=1.0d0+om2
5804       deltat12=om2-om1+2.0d0
5805       cosphi=om12-om1*om2
5806       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5807      &  +akct*deltad*deltat12
5808      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5809 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5810 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5811 c     &  " deltat12",deltat12," eij",eij
5812       ed=2*akcm*deltad+akct*deltat12
5813       pom1=akct*deltad
5814       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5815       eom1=-2*akth*deltat1-pom1-om2*pom2
5816       eom2= 2*akth*deltat2+pom1-om1*pom2
5817       eom12=pom2
5818       do k=1,3
5819         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5820         ghpbx(k,i)=ghpbx(k,i)-ggk
5821      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5822      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5823         ghpbx(k,j)=ghpbx(k,j)+ggk
5824      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5825      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5826         ghpbc(k,i)=ghpbc(k,i)-ggk
5827         ghpbc(k,j)=ghpbc(k,j)+ggk
5828       enddo
5829 C
5830 C Calculate the components of the gradient in DC and X
5831 C
5832 cgrad      do k=i,j-1
5833 cgrad        do l=1,3
5834 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5835 cgrad        enddo
5836 cgrad      enddo
5837       return
5838       end
5839 C--------------------------------------------------------------------------
5840       subroutine ebond(estr)
5841 c
5842 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5843 c
5844       implicit real*8 (a-h,o-z)
5845       include 'DIMENSIONS'
5846       include 'COMMON.LOCAL'
5847       include 'COMMON.GEO'
5848       include 'COMMON.INTERACT'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.VAR'
5851       include 'COMMON.CHAIN'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.NAMES'
5854       include 'COMMON.FFIELD'
5855       include 'COMMON.CONTROL'
5856       include 'COMMON.SETUP'
5857       double precision u(3),ud(3)
5858       estr=0.0d0
5859       estr1=0.0d0
5860       do i=ibondp_start,ibondp_end
5861         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5862 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5863 c          do j=1,3
5864 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5865 c     &      *dc(j,i-1)/vbld(i)
5866 c          enddo
5867 c          if (energy_dec) write(iout,*)
5868 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5869 c        else
5870 C       Checking if it involves dummy (NH3+ or COO-) group
5871          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5872 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5873         diff = vbld(i)-vbldpDUM
5874         if (energy_dec) write(iout,*) "dum_bond",i,diff
5875          else
5876 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5877         diff = vbld(i)-vbldp0
5878          endif
5879         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5880      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5881         estr=estr+diff*diff
5882         do j=1,3
5883           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5884         enddo
5885 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5886 c        endif
5887       enddo
5888
5889       estr=0.5d0*AKP*estr+estr1
5890 c
5891 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5892 c
5893       do i=ibond_start,ibond_end
5894         iti=iabs(itype(i))
5895         if (iti.ne.10 .and. iti.ne.ntyp1) then
5896           nbi=nbondterm(iti)
5897           if (nbi.eq.1) then
5898             diff=vbld(i+nres)-vbldsc0(1,iti)
5899             if (energy_dec)  write (iout,*)
5900      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5901      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5902             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5903             do j=1,3
5904               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5905             enddo
5906           else
5907             do j=1,nbi
5908               diff=vbld(i+nres)-vbldsc0(j,iti)
5909               ud(j)=aksc(j,iti)*diff
5910               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5911             enddo
5912             uprod=u(1)
5913             do j=2,nbi
5914               uprod=uprod*u(j)
5915             enddo
5916             usum=0.0d0
5917             usumsqder=0.0d0
5918             do j=1,nbi
5919               uprod1=1.0d0
5920               uprod2=1.0d0
5921               do k=1,nbi
5922                 if (k.ne.j) then
5923                   uprod1=uprod1*u(k)
5924                   uprod2=uprod2*u(k)*u(k)
5925                 endif
5926               enddo
5927               usum=usum+uprod1
5928               usumsqder=usumsqder+ud(j)*uprod2
5929             enddo
5930             estr=estr+uprod/usum
5931             do j=1,3
5932              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5933             enddo
5934           endif
5935         endif
5936       enddo
5937       return
5938       end
5939 #ifdef CRYST_THETA
5940 C--------------------------------------------------------------------------
5941       subroutine ebend(etheta,ethetacnstr)
5942 C
5943 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5944 C angles gamma and its derivatives in consecutive thetas and gammas.
5945 C
5946       implicit real*8 (a-h,o-z)
5947       include 'DIMENSIONS'
5948       include 'COMMON.LOCAL'
5949       include 'COMMON.GEO'
5950       include 'COMMON.INTERACT'
5951       include 'COMMON.DERIV'
5952       include 'COMMON.VAR'
5953       include 'COMMON.CHAIN'
5954       include 'COMMON.IOUNITS'
5955       include 'COMMON.NAMES'
5956       include 'COMMON.FFIELD'
5957       include 'COMMON.CONTROL'
5958       include 'COMMON.TORCNSTR'
5959       common /calcthet/ term1,term2,termm,diffak,ratak,
5960      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5961      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5962       double precision y(2),z(2)
5963       delta=0.02d0*pi
5964 c      time11=dexp(-2*time)
5965 c      time12=1.0d0
5966       etheta=0.0D0
5967 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5968       do i=ithet_start,ithet_end
5969         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5970      &  .or.itype(i).eq.ntyp1) cycle
5971 C Zero the energy function and its derivative at 0 or pi.
5972         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5973         it=itype(i-1)
5974         ichir1=isign(1,itype(i-2))
5975         ichir2=isign(1,itype(i))
5976          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5977          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5978          if (itype(i-1).eq.10) then
5979           itype1=isign(10,itype(i-2))
5980           ichir11=isign(1,itype(i-2))
5981           ichir12=isign(1,itype(i-2))
5982           itype2=isign(10,itype(i))
5983           ichir21=isign(1,itype(i))
5984           ichir22=isign(1,itype(i))
5985          endif
5986
5987         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5988 #ifdef OSF
5989           phii=phi(i)
5990           if (phii.ne.phii) phii=150.0
5991 #else
5992           phii=phi(i)
5993 #endif
5994           y(1)=dcos(phii)
5995           y(2)=dsin(phii)
5996         else
5997           y(1)=0.0D0
5998           y(2)=0.0D0
5999         endif
6000         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6001 #ifdef OSF
6002           phii1=phi(i+1)
6003           if (phii1.ne.phii1) phii1=150.0
6004           phii1=pinorm(phii1)
6005           z(1)=cos(phii1)
6006 #else
6007           phii1=phi(i+1)
6008 #endif
6009           z(1)=dcos(phii1)
6010           z(2)=dsin(phii1)
6011         else
6012           z(1)=0.0D0
6013           z(2)=0.0D0
6014         endif
6015 C Calculate the "mean" value of theta from the part of the distribution
6016 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6017 C In following comments this theta will be referred to as t_c.
6018         thet_pred_mean=0.0d0
6019         do k=1,2
6020             athetk=athet(k,it,ichir1,ichir2)
6021             bthetk=bthet(k,it,ichir1,ichir2)
6022           if (it.eq.10) then
6023              athetk=athet(k,itype1,ichir11,ichir12)
6024              bthetk=bthet(k,itype2,ichir21,ichir22)
6025           endif
6026          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6027 c         write(iout,*) 'chuj tu', y(k),z(k)
6028         enddo
6029         dthett=thet_pred_mean*ssd
6030         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6031 C Derivatives of the "mean" values in gamma1 and gamma2.
6032         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6033      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6034          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6035      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6036          if (it.eq.10) then
6037       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6038      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6039         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6040      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6041          endif
6042         if (theta(i).gt.pi-delta) then
6043           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6044      &         E_tc0)
6045           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6046           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6047           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6048      &        E_theta)
6049           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6050      &        E_tc)
6051         else if (theta(i).lt.delta) then
6052           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6053           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6054           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6055      &        E_theta)
6056           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6057           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6058      &        E_tc)
6059         else
6060           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6061      &        E_theta,E_tc)
6062         endif
6063         etheta=etheta+ethetai
6064         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6065      &      'ebend',i,ethetai,theta(i),itype(i)
6066         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6067         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6068         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6069       enddo
6070       ethetacnstr=0.0d0
6071 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6072       do i=ithetaconstr_start,ithetaconstr_end
6073         itheta=itheta_constr(i)
6074         thetiii=theta(itheta)
6075         difi=pinorm(thetiii-theta_constr0(i))
6076         if (difi.gt.theta_drange(i)) then
6077           difi=difi-theta_drange(i)
6078           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6079           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6080      &    +for_thet_constr(i)*difi**3
6081         else if (difi.lt.-drange(i)) then
6082           difi=difi+drange(i)
6083           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6084           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6085      &    +for_thet_constr(i)*difi**3
6086         else
6087           difi=0.0
6088         endif
6089        if (energy_dec) then
6090         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6091      &    i,itheta,rad2deg*thetiii,
6092      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6093      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6094      &    gloc(itheta+nphi-2,icg)
6095         endif
6096       enddo
6097
6098 C Ufff.... We've done all this!!!
6099       return
6100       end
6101 C---------------------------------------------------------------------------
6102       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6103      &     E_tc)
6104       implicit real*8 (a-h,o-z)
6105       include 'DIMENSIONS'
6106       include 'COMMON.LOCAL'
6107       include 'COMMON.IOUNITS'
6108       common /calcthet/ term1,term2,termm,diffak,ratak,
6109      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6110      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6111 C Calculate the contributions to both Gaussian lobes.
6112 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6113 C The "polynomial part" of the "standard deviation" of this part of
6114 C the distributioni.
6115 ccc        write (iout,*) thetai,thet_pred_mean
6116         sig=polthet(3,it)
6117         do j=2,0,-1
6118           sig=sig*thet_pred_mean+polthet(j,it)
6119         enddo
6120 C Derivative of the "interior part" of the "standard deviation of the"
6121 C gamma-dependent Gaussian lobe in t_c.
6122         sigtc=3*polthet(3,it)
6123         do j=2,1,-1
6124           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6125         enddo
6126         sigtc=sig*sigtc
6127 C Set the parameters of both Gaussian lobes of the distribution.
6128 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6129         fac=sig*sig+sigc0(it)
6130         sigcsq=fac+fac
6131         sigc=1.0D0/sigcsq
6132 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6133         sigsqtc=-4.0D0*sigcsq*sigtc
6134 c       print *,i,sig,sigtc,sigsqtc
6135 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6136         sigtc=-sigtc/(fac*fac)
6137 C Following variable is sigma(t_c)**(-2)
6138         sigcsq=sigcsq*sigcsq
6139         sig0i=sig0(it)
6140         sig0inv=1.0D0/sig0i**2
6141         delthec=thetai-thet_pred_mean
6142         delthe0=thetai-theta0i
6143         term1=-0.5D0*sigcsq*delthec*delthec
6144         term2=-0.5D0*sig0inv*delthe0*delthe0
6145 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6146 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6147 C NaNs in taking the logarithm. We extract the largest exponent which is added
6148 C to the energy (this being the log of the distribution) at the end of energy
6149 C term evaluation for this virtual-bond angle.
6150         if (term1.gt.term2) then
6151           termm=term1
6152           term2=dexp(term2-termm)
6153           term1=1.0d0
6154         else
6155           termm=term2
6156           term1=dexp(term1-termm)
6157           term2=1.0d0
6158         endif
6159 C The ratio between the gamma-independent and gamma-dependent lobes of
6160 C the distribution is a Gaussian function of thet_pred_mean too.
6161         diffak=gthet(2,it)-thet_pred_mean
6162         ratak=diffak/gthet(3,it)**2
6163         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6164 C Let's differentiate it in thet_pred_mean NOW.
6165         aktc=ak*ratak
6166 C Now put together the distribution terms to make complete distribution.
6167         termexp=term1+ak*term2
6168         termpre=sigc+ak*sig0i
6169 C Contribution of the bending energy from this theta is just the -log of
6170 C the sum of the contributions from the two lobes and the pre-exponential
6171 C factor. Simple enough, isn't it?
6172         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6173 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6174 C NOW the derivatives!!!
6175 C 6/6/97 Take into account the deformation.
6176         E_theta=(delthec*sigcsq*term1
6177      &       +ak*delthe0*sig0inv*term2)/termexp
6178         E_tc=((sigtc+aktc*sig0i)/termpre
6179      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6180      &       aktc*term2)/termexp)
6181       return
6182       end
6183 c-----------------------------------------------------------------------------
6184       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6185       implicit real*8 (a-h,o-z)
6186       include 'DIMENSIONS'
6187       include 'COMMON.LOCAL'
6188       include 'COMMON.IOUNITS'
6189       common /calcthet/ term1,term2,termm,diffak,ratak,
6190      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6191      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6192       delthec=thetai-thet_pred_mean
6193       delthe0=thetai-theta0i
6194 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6195       t3 = thetai-thet_pred_mean
6196       t6 = t3**2
6197       t9 = term1
6198       t12 = t3*sigcsq
6199       t14 = t12+t6*sigsqtc
6200       t16 = 1.0d0
6201       t21 = thetai-theta0i
6202       t23 = t21**2
6203       t26 = term2
6204       t27 = t21*t26
6205       t32 = termexp
6206       t40 = t32**2
6207       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6208      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6209      & *(-t12*t9-ak*sig0inv*t27)
6210       return
6211       end
6212 #else
6213 C--------------------------------------------------------------------------
6214       subroutine ebend(etheta,ethetacnstr)
6215 C
6216 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6217 C angles gamma and its derivatives in consecutive thetas and gammas.
6218 C ab initio-derived potentials from
6219 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6220 C
6221       implicit real*8 (a-h,o-z)
6222       include 'DIMENSIONS'
6223       include 'COMMON.LOCAL'
6224       include 'COMMON.GEO'
6225       include 'COMMON.INTERACT'
6226       include 'COMMON.DERIV'
6227       include 'COMMON.VAR'
6228       include 'COMMON.CHAIN'
6229       include 'COMMON.IOUNITS'
6230       include 'COMMON.NAMES'
6231       include 'COMMON.FFIELD'
6232       include 'COMMON.CONTROL'
6233       include 'COMMON.TORCNSTR'
6234       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6235      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6236      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6237      & sinph1ph2(maxdouble,maxdouble)
6238       logical lprn /.false./, lprn1 /.false./
6239       etheta=0.0D0
6240       do i=ithet_start,ithet_end
6241 c        print *,i,itype(i-1),itype(i),itype(i-2)
6242         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6243      &  .or.itype(i).eq.ntyp1) cycle
6244 C        print *,i,theta(i)
6245         if (iabs(itype(i+1)).eq.20) iblock=2
6246         if (iabs(itype(i+1)).ne.20) iblock=1
6247         dethetai=0.0d0
6248         dephii=0.0d0
6249         dephii1=0.0d0
6250         theti2=0.5d0*theta(i)
6251         ityp2=ithetyp((itype(i-1)))
6252         do k=1,nntheterm
6253           coskt(k)=dcos(k*theti2)
6254           sinkt(k)=dsin(k*theti2)
6255         enddo
6256 C        print *,ethetai
6257         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6258 #ifdef OSF
6259           phii=phi(i)
6260           if (phii.ne.phii) phii=150.0
6261 #else
6262           phii=phi(i)
6263 #endif
6264           ityp1=ithetyp((itype(i-2)))
6265 C propagation of chirality for glycine type
6266           do k=1,nsingle
6267             cosph1(k)=dcos(k*phii)
6268             sinph1(k)=dsin(k*phii)
6269           enddo
6270         else
6271           phii=0.0d0
6272           do k=1,nsingle
6273           ityp1=ithetyp((itype(i-2)))
6274             cosph1(k)=0.0d0
6275             sinph1(k)=0.0d0
6276           enddo
6277         endif
6278         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6279 #ifdef OSF
6280           phii1=phi(i+1)
6281           if (phii1.ne.phii1) phii1=150.0
6282           phii1=pinorm(phii1)
6283 #else
6284           phii1=phi(i+1)
6285 #endif
6286           ityp3=ithetyp((itype(i)))
6287           do k=1,nsingle
6288             cosph2(k)=dcos(k*phii1)
6289             sinph2(k)=dsin(k*phii1)
6290           enddo
6291         else
6292           phii1=0.0d0
6293           ityp3=ithetyp((itype(i)))
6294           do k=1,nsingle
6295             cosph2(k)=0.0d0
6296             sinph2(k)=0.0d0
6297           enddo
6298         endif
6299         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6300         do k=1,ndouble
6301           do l=1,k-1
6302             ccl=cosph1(l)*cosph2(k-l)
6303             ssl=sinph1(l)*sinph2(k-l)
6304             scl=sinph1(l)*cosph2(k-l)
6305             csl=cosph1(l)*sinph2(k-l)
6306             cosph1ph2(l,k)=ccl-ssl
6307             cosph1ph2(k,l)=ccl+ssl
6308             sinph1ph2(l,k)=scl+csl
6309             sinph1ph2(k,l)=scl-csl
6310           enddo
6311         enddo
6312         if (lprn) then
6313         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6314      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6315         write (iout,*) "coskt and sinkt"
6316         do k=1,nntheterm
6317           write (iout,*) k,coskt(k),sinkt(k)
6318         enddo
6319         endif
6320         do k=1,ntheterm
6321           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6322           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6323      &      *coskt(k)
6324           if (lprn)
6325      &    write (iout,*) "k",k,"
6326      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6327      &     " ethetai",ethetai
6328         enddo
6329         if (lprn) then
6330         write (iout,*) "cosph and sinph"
6331         do k=1,nsingle
6332           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6333         enddo
6334         write (iout,*) "cosph1ph2 and sinph2ph2"
6335         do k=2,ndouble
6336           do l=1,k-1
6337             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6338      &         sinph1ph2(l,k),sinph1ph2(k,l)
6339           enddo
6340         enddo
6341         write(iout,*) "ethetai",ethetai
6342         endif
6343 C       print *,ethetai
6344         do m=1,ntheterm2
6345           do k=1,nsingle
6346             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6347      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6348      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6349      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6350             ethetai=ethetai+sinkt(m)*aux
6351             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6352             dephii=dephii+k*sinkt(m)*(
6353      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6354      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6355             dephii1=dephii1+k*sinkt(m)*(
6356      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6357      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6358             if (lprn)
6359      &      write (iout,*) "m",m," k",k," bbthet",
6360      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6361      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6362      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6363      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6364 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6365           enddo
6366         enddo
6367 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6368 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6369 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6370 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6371         if (lprn)
6372      &  write(iout,*) "ethetai",ethetai
6373 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6374         do m=1,ntheterm3
6375           do k=2,ndouble
6376             do l=1,k-1
6377               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6378      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6379      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6380      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6381               ethetai=ethetai+sinkt(m)*aux
6382               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6383               dephii=dephii+l*sinkt(m)*(
6384      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6385      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6386      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6387      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6388               dephii1=dephii1+(k-l)*sinkt(m)*(
6389      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6390      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6391      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6392      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6393               if (lprn) then
6394               write (iout,*) "m",m," k",k," l",l," ffthet",
6395      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6396      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6397      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6398      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6399      &            " ethetai",ethetai
6400               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6401      &            cosph1ph2(k,l)*sinkt(m),
6402      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6403               endif
6404             enddo
6405           enddo
6406         enddo
6407 10      continue
6408 c        lprn1=.true.
6409 C        print *,ethetai
6410         if (lprn1)
6411      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6412      &   i,theta(i)*rad2deg,phii*rad2deg,
6413      &   phii1*rad2deg,ethetai
6414 c        lprn1=.false.
6415         etheta=etheta+ethetai
6416         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6417         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6418         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6419       enddo
6420 C now constrains
6421       ethetacnstr=0.0d0
6422 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6423       do i=ithetaconstr_start,ithetaconstr_end
6424         itheta=itheta_constr(i)
6425         thetiii=theta(itheta)
6426         difi=pinorm(thetiii-theta_constr0(i))
6427         if (difi.gt.theta_drange(i)) then
6428           difi=difi-theta_drange(i)
6429           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6430           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6431      &    +for_thet_constr(i)*difi**3
6432         else if (difi.lt.-drange(i)) then
6433           difi=difi+drange(i)
6434           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6435           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6436      &    +for_thet_constr(i)*difi**3
6437         else
6438           difi=0.0
6439         endif
6440        if (energy_dec) then
6441         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6442      &    i,itheta,rad2deg*thetiii,
6443      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6444      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6445      &    gloc(itheta+nphi-2,icg)
6446         endif
6447       enddo
6448
6449       return
6450       end
6451 #endif
6452 #ifdef CRYST_SC
6453 c-----------------------------------------------------------------------------
6454       subroutine esc(escloc)
6455 C Calculate the local energy of a side chain and its derivatives in the
6456 C corresponding virtual-bond valence angles THETA and the spherical angles
6457 C ALPHA and OMEGA.
6458       implicit real*8 (a-h,o-z)
6459       include 'DIMENSIONS'
6460       include 'COMMON.GEO'
6461       include 'COMMON.LOCAL'
6462       include 'COMMON.VAR'
6463       include 'COMMON.INTERACT'
6464       include 'COMMON.DERIV'
6465       include 'COMMON.CHAIN'
6466       include 'COMMON.IOUNITS'
6467       include 'COMMON.NAMES'
6468       include 'COMMON.FFIELD'
6469       include 'COMMON.CONTROL'
6470       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6471      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6472       common /sccalc/ time11,time12,time112,theti,it,nlobit
6473       delta=0.02d0*pi
6474       escloc=0.0D0
6475 c     write (iout,'(a)') 'ESC'
6476       do i=loc_start,loc_end
6477         it=itype(i)
6478         if (it.eq.ntyp1) cycle
6479         if (it.eq.10) goto 1
6480         nlobit=nlob(iabs(it))
6481 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6482 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6483         theti=theta(i+1)-pipol
6484         x(1)=dtan(theti)
6485         x(2)=alph(i)
6486         x(3)=omeg(i)
6487
6488         if (x(2).gt.pi-delta) then
6489           xtemp(1)=x(1)
6490           xtemp(2)=pi-delta
6491           xtemp(3)=x(3)
6492           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6493           xtemp(2)=pi
6494           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6495           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6496      &        escloci,dersc(2))
6497           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6498      &        ddersc0(1),dersc(1))
6499           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6500      &        ddersc0(3),dersc(3))
6501           xtemp(2)=pi-delta
6502           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6503           xtemp(2)=pi
6504           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6505           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6506      &            dersc0(2),esclocbi,dersc02)
6507           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6508      &            dersc12,dersc01)
6509           call splinthet(x(2),0.5d0*delta,ss,ssd)
6510           dersc0(1)=dersc01
6511           dersc0(2)=dersc02
6512           dersc0(3)=0.0d0
6513           do k=1,3
6514             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6515           enddo
6516           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6517 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6518 c    &             esclocbi,ss,ssd
6519           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6520 c         escloci=esclocbi
6521 c         write (iout,*) escloci
6522         else if (x(2).lt.delta) then
6523           xtemp(1)=x(1)
6524           xtemp(2)=delta
6525           xtemp(3)=x(3)
6526           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6527           xtemp(2)=0.0d0
6528           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6529           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6530      &        escloci,dersc(2))
6531           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6532      &        ddersc0(1),dersc(1))
6533           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6534      &        ddersc0(3),dersc(3))
6535           xtemp(2)=delta
6536           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6537           xtemp(2)=0.0d0
6538           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6539           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6540      &            dersc0(2),esclocbi,dersc02)
6541           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6542      &            dersc12,dersc01)
6543           dersc0(1)=dersc01
6544           dersc0(2)=dersc02
6545           dersc0(3)=0.0d0
6546           call splinthet(x(2),0.5d0*delta,ss,ssd)
6547           do k=1,3
6548             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6549           enddo
6550           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6551 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6552 c    &             esclocbi,ss,ssd
6553           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6554 c         write (iout,*) escloci
6555         else
6556           call enesc(x,escloci,dersc,ddummy,.false.)
6557         endif
6558
6559         escloc=escloc+escloci
6560         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6561      &     'escloc',i,escloci
6562 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6563
6564         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6565      &   wscloc*dersc(1)
6566         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6567         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6568     1   continue
6569       enddo
6570       return
6571       end
6572 C---------------------------------------------------------------------------
6573       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6574       implicit real*8 (a-h,o-z)
6575       include 'DIMENSIONS'
6576       include 'COMMON.GEO'
6577       include 'COMMON.LOCAL'
6578       include 'COMMON.IOUNITS'
6579       common /sccalc/ time11,time12,time112,theti,it,nlobit
6580       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6581       double precision contr(maxlob,-1:1)
6582       logical mixed
6583 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6584         escloc_i=0.0D0
6585         do j=1,3
6586           dersc(j)=0.0D0
6587           if (mixed) ddersc(j)=0.0d0
6588         enddo
6589         x3=x(3)
6590
6591 C Because of periodicity of the dependence of the SC energy in omega we have
6592 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6593 C To avoid underflows, first compute & store the exponents.
6594
6595         do iii=-1,1
6596
6597           x(3)=x3+iii*dwapi
6598
6599           do j=1,nlobit
6600             do k=1,3
6601               z(k)=x(k)-censc(k,j,it)
6602             enddo
6603             do k=1,3
6604               Axk=0.0D0
6605               do l=1,3
6606                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6607               enddo
6608               Ax(k,j,iii)=Axk
6609             enddo
6610             expfac=0.0D0
6611             do k=1,3
6612               expfac=expfac+Ax(k,j,iii)*z(k)
6613             enddo
6614             contr(j,iii)=expfac
6615           enddo ! j
6616
6617         enddo ! iii
6618
6619         x(3)=x3
6620 C As in the case of ebend, we want to avoid underflows in exponentiation and
6621 C subsequent NaNs and INFs in energy calculation.
6622 C Find the largest exponent
6623         emin=contr(1,-1)
6624         do iii=-1,1
6625           do j=1,nlobit
6626             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6627           enddo
6628         enddo
6629         emin=0.5D0*emin
6630 cd      print *,'it=',it,' emin=',emin
6631
6632 C Compute the contribution to SC energy and derivatives
6633         do iii=-1,1
6634
6635           do j=1,nlobit
6636 #ifdef OSF
6637             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6638             if(adexp.ne.adexp) adexp=1.0
6639             expfac=dexp(adexp)
6640 #else
6641             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6642 #endif
6643 cd          print *,'j=',j,' expfac=',expfac
6644             escloc_i=escloc_i+expfac
6645             do k=1,3
6646               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6647             enddo
6648             if (mixed) then
6649               do k=1,3,2
6650                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6651      &            +gaussc(k,2,j,it))*expfac
6652               enddo
6653             endif
6654           enddo
6655
6656         enddo ! iii
6657
6658         dersc(1)=dersc(1)/cos(theti)**2
6659         ddersc(1)=ddersc(1)/cos(theti)**2
6660         ddersc(3)=ddersc(3)
6661
6662         escloci=-(dlog(escloc_i)-emin)
6663         do j=1,3
6664           dersc(j)=dersc(j)/escloc_i
6665         enddo
6666         if (mixed) then
6667           do j=1,3,2
6668             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6669           enddo
6670         endif
6671       return
6672       end
6673 C------------------------------------------------------------------------------
6674       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6675       implicit real*8 (a-h,o-z)
6676       include 'DIMENSIONS'
6677       include 'COMMON.GEO'
6678       include 'COMMON.LOCAL'
6679       include 'COMMON.IOUNITS'
6680       common /sccalc/ time11,time12,time112,theti,it,nlobit
6681       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6682       double precision contr(maxlob)
6683       logical mixed
6684
6685       escloc_i=0.0D0
6686
6687       do j=1,3
6688         dersc(j)=0.0D0
6689       enddo
6690
6691       do j=1,nlobit
6692         do k=1,2
6693           z(k)=x(k)-censc(k,j,it)
6694         enddo
6695         z(3)=dwapi
6696         do k=1,3
6697           Axk=0.0D0
6698           do l=1,3
6699             Axk=Axk+gaussc(l,k,j,it)*z(l)
6700           enddo
6701           Ax(k,j)=Axk
6702         enddo
6703         expfac=0.0D0
6704         do k=1,3
6705           expfac=expfac+Ax(k,j)*z(k)
6706         enddo
6707         contr(j)=expfac
6708       enddo ! j
6709
6710 C As in the case of ebend, we want to avoid underflows in exponentiation and
6711 C subsequent NaNs and INFs in energy calculation.
6712 C Find the largest exponent
6713       emin=contr(1)
6714       do j=1,nlobit
6715         if (emin.gt.contr(j)) emin=contr(j)
6716       enddo
6717       emin=0.5D0*emin
6718
6719 C Compute the contribution to SC energy and derivatives
6720
6721       dersc12=0.0d0
6722       do j=1,nlobit
6723         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6724         escloc_i=escloc_i+expfac
6725         do k=1,2
6726           dersc(k)=dersc(k)+Ax(k,j)*expfac
6727         enddo
6728         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6729      &            +gaussc(1,2,j,it))*expfac
6730         dersc(3)=0.0d0
6731       enddo
6732
6733       dersc(1)=dersc(1)/cos(theti)**2
6734       dersc12=dersc12/cos(theti)**2
6735       escloci=-(dlog(escloc_i)-emin)
6736       do j=1,2
6737         dersc(j)=dersc(j)/escloc_i
6738       enddo
6739       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6740       return
6741       end
6742 #else
6743 c----------------------------------------------------------------------------------
6744       subroutine esc(escloc)
6745 C Calculate the local energy of a side chain and its derivatives in the
6746 C corresponding virtual-bond valence angles THETA and the spherical angles
6747 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6748 C added by Urszula Kozlowska. 07/11/2007
6749 C
6750       implicit real*8 (a-h,o-z)
6751       include 'DIMENSIONS'
6752       include 'COMMON.GEO'
6753       include 'COMMON.LOCAL'
6754       include 'COMMON.VAR'
6755       include 'COMMON.SCROT'
6756       include 'COMMON.INTERACT'
6757       include 'COMMON.DERIV'
6758       include 'COMMON.CHAIN'
6759       include 'COMMON.IOUNITS'
6760       include 'COMMON.NAMES'
6761       include 'COMMON.FFIELD'
6762       include 'COMMON.CONTROL'
6763       include 'COMMON.VECTORS'
6764       double precision x_prime(3),y_prime(3),z_prime(3)
6765      &    , sumene,dsc_i,dp2_i,x(65),
6766      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6767      &    de_dxx,de_dyy,de_dzz,de_dt
6768       double precision s1_t,s1_6_t,s2_t,s2_6_t
6769       double precision
6770      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6771      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6772      & dt_dCi(3),dt_dCi1(3)
6773       common /sccalc/ time11,time12,time112,theti,it,nlobit
6774       delta=0.02d0*pi
6775       escloc=0.0D0
6776       do i=loc_start,loc_end
6777         if (itype(i).eq.ntyp1) cycle
6778         costtab(i+1) =dcos(theta(i+1))
6779         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6780         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6781         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6782         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6783         cosfac=dsqrt(cosfac2)
6784         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6785         sinfac=dsqrt(sinfac2)
6786         it=iabs(itype(i))
6787         if (it.eq.10) goto 1
6788 c
6789 C  Compute the axes of tghe local cartesian coordinates system; store in
6790 c   x_prime, y_prime and z_prime
6791 c
6792         do j=1,3
6793           x_prime(j) = 0.00
6794           y_prime(j) = 0.00
6795           z_prime(j) = 0.00
6796         enddo
6797 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6798 C     &   dc_norm(3,i+nres)
6799         do j = 1,3
6800           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6801           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6802         enddo
6803         do j = 1,3
6804           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6805         enddo
6806 c       write (2,*) "i",i
6807 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6808 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6809 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6810 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6811 c      & " xy",scalar(x_prime(1),y_prime(1)),
6812 c      & " xz",scalar(x_prime(1),z_prime(1)),
6813 c      & " yy",scalar(y_prime(1),y_prime(1)),
6814 c      & " yz",scalar(y_prime(1),z_prime(1)),
6815 c      & " zz",scalar(z_prime(1),z_prime(1))
6816 c
6817 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6818 C to local coordinate system. Store in xx, yy, zz.
6819 c
6820         xx=0.0d0
6821         yy=0.0d0
6822         zz=0.0d0
6823         do j = 1,3
6824           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6825           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6826           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6827         enddo
6828
6829         xxtab(i)=xx
6830         yytab(i)=yy
6831         zztab(i)=zz
6832 C
6833 C Compute the energy of the ith side cbain
6834 C
6835 c        write (2,*) "xx",xx," yy",yy," zz",zz
6836         it=iabs(itype(i))
6837         do j = 1,65
6838           x(j) = sc_parmin(j,it)
6839         enddo
6840 #ifdef CHECK_COORD
6841 Cc diagnostics - remove later
6842         xx1 = dcos(alph(2))
6843         yy1 = dsin(alph(2))*dcos(omeg(2))
6844         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6845         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6846      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6847      &    xx1,yy1,zz1
6848 C,"  --- ", xx_w,yy_w,zz_w
6849 c end diagnostics
6850 #endif
6851         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6852      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6853      &   + x(10)*yy*zz
6854         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6855      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6856      & + x(20)*yy*zz
6857         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6858      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6859      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6860      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6861      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6862      &  +x(40)*xx*yy*zz
6863         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6864      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6865      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6866      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6867      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6868      &  +x(60)*xx*yy*zz
6869         dsc_i   = 0.743d0+x(61)
6870         dp2_i   = 1.9d0+x(62)
6871         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6872      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6873         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6874      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6875         s1=(1+x(63))/(0.1d0 + dscp1)
6876         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6877         s2=(1+x(65))/(0.1d0 + dscp2)
6878         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6879         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6880      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6881 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6882 c     &   sumene4,
6883 c     &   dscp1,dscp2,sumene
6884 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6885         escloc = escloc + sumene
6886 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6887 c     & ,zz,xx,yy
6888 c#define DEBUG
6889 #ifdef DEBUG
6890 C
6891 C This section to check the numerical derivatives of the energy of ith side
6892 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6893 C #define DEBUG in the code to turn it on.
6894 C
6895         write (2,*) "sumene               =",sumene
6896         aincr=1.0d-7
6897         xxsave=xx
6898         xx=xx+aincr
6899         write (2,*) xx,yy,zz
6900         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6901         de_dxx_num=(sumenep-sumene)/aincr
6902         xx=xxsave
6903         write (2,*) "xx+ sumene from enesc=",sumenep
6904         yysave=yy
6905         yy=yy+aincr
6906         write (2,*) xx,yy,zz
6907         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6908         de_dyy_num=(sumenep-sumene)/aincr
6909         yy=yysave
6910         write (2,*) "yy+ sumene from enesc=",sumenep
6911         zzsave=zz
6912         zz=zz+aincr
6913         write (2,*) xx,yy,zz
6914         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6915         de_dzz_num=(sumenep-sumene)/aincr
6916         zz=zzsave
6917         write (2,*) "zz+ sumene from enesc=",sumenep
6918         costsave=cost2tab(i+1)
6919         sintsave=sint2tab(i+1)
6920         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6921         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6922         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6923         de_dt_num=(sumenep-sumene)/aincr
6924         write (2,*) " t+ sumene from enesc=",sumenep
6925         cost2tab(i+1)=costsave
6926         sint2tab(i+1)=sintsave
6927 C End of diagnostics section.
6928 #endif
6929 C
6930 C Compute the gradient of esc
6931 C
6932 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6933         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6934         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6935         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6936         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6937         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6938         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6939         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6940         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6941         pom1=(sumene3*sint2tab(i+1)+sumene1)
6942      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6943         pom2=(sumene4*cost2tab(i+1)+sumene2)
6944      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6945         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6946         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6947      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6948      &  +x(40)*yy*zz
6949         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6950         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6951      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6952      &  +x(60)*yy*zz
6953         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6954      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6955      &        +(pom1+pom2)*pom_dx
6956 #ifdef DEBUG
6957         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6958 #endif
6959 C
6960         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6961         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6962      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6963      &  +x(40)*xx*zz
6964         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6965         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6966      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6967      &  +x(59)*zz**2 +x(60)*xx*zz
6968         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6969      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6970      &        +(pom1-pom2)*pom_dy
6971 #ifdef DEBUG
6972         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6973 #endif
6974 C
6975         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6976      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6977      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6978      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6979      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6980      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6981      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6982      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6983 #ifdef DEBUG
6984         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6985 #endif
6986 C
6987         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6988      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6989      &  +pom1*pom_dt1+pom2*pom_dt2
6990 #ifdef DEBUG
6991         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6992 #endif
6993 c#undef DEBUG
6994 c
6995 C
6996        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6997        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6998        cosfac2xx=cosfac2*xx
6999        sinfac2yy=sinfac2*yy
7000        do k = 1,3
7001          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7002      &      vbld_inv(i+1)
7003          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7004      &      vbld_inv(i)
7005          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7006          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7007 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7008 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7009 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7010 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7011          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7012          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7013          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7014          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7015          dZZ_Ci1(k)=0.0d0
7016          dZZ_Ci(k)=0.0d0
7017          do j=1,3
7018            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7019      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7020            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7021      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7022          enddo
7023
7024          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7025          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7026          dZZ_XYZ(k)=vbld_inv(i+nres)*
7027      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7028 c
7029          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7030          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7031        enddo
7032
7033        do k=1,3
7034          dXX_Ctab(k,i)=dXX_Ci(k)
7035          dXX_C1tab(k,i)=dXX_Ci1(k)
7036          dYY_Ctab(k,i)=dYY_Ci(k)
7037          dYY_C1tab(k,i)=dYY_Ci1(k)
7038          dZZ_Ctab(k,i)=dZZ_Ci(k)
7039          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7040          dXX_XYZtab(k,i)=dXX_XYZ(k)
7041          dYY_XYZtab(k,i)=dYY_XYZ(k)
7042          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7043        enddo
7044
7045        do k = 1,3
7046 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7047 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7048 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7049 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7050 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7051 c     &    dt_dci(k)
7052 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7053 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7054          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7055      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7056          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7057      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7058          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7059      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7060        enddo
7061 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7062 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7063
7064 C to check gradient call subroutine check_grad
7065
7066     1 continue
7067       enddo
7068       return
7069       end
7070 c------------------------------------------------------------------------------
7071       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7072       implicit none
7073       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7074      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7075       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7076      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7077      &   + x(10)*yy*zz
7078       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7079      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7080      & + x(20)*yy*zz
7081       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7082      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7083      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7084      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7085      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7086      &  +x(40)*xx*yy*zz
7087       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7088      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7089      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7090      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7091      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7092      &  +x(60)*xx*yy*zz
7093       dsc_i   = 0.743d0+x(61)
7094       dp2_i   = 1.9d0+x(62)
7095       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7096      &          *(xx*cost2+yy*sint2))
7097       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7098      &          *(xx*cost2-yy*sint2))
7099       s1=(1+x(63))/(0.1d0 + dscp1)
7100       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7101       s2=(1+x(65))/(0.1d0 + dscp2)
7102       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7103       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7104      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7105       enesc=sumene
7106       return
7107       end
7108 #endif
7109 c------------------------------------------------------------------------------
7110       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7111 C
7112 C This procedure calculates two-body contact function g(rij) and its derivative:
7113 C
7114 C           eps0ij                                     !       x < -1
7115 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7116 C            0                                         !       x > 1
7117 C
7118 C where x=(rij-r0ij)/delta
7119 C
7120 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7121 C
7122       implicit none
7123       double precision rij,r0ij,eps0ij,fcont,fprimcont
7124       double precision x,x2,x4,delta
7125 c     delta=0.02D0*r0ij
7126 c      delta=0.2D0*r0ij
7127       x=(rij-r0ij)/delta
7128       if (x.lt.-1.0D0) then
7129         fcont=eps0ij
7130         fprimcont=0.0D0
7131       else if (x.le.1.0D0) then
7132         x2=x*x
7133         x4=x2*x2
7134         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7135         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7136       else
7137         fcont=0.0D0
7138         fprimcont=0.0D0
7139       endif
7140       return
7141       end
7142 c------------------------------------------------------------------------------
7143       subroutine splinthet(theti,delta,ss,ssder)
7144       implicit real*8 (a-h,o-z)
7145       include 'DIMENSIONS'
7146       include 'COMMON.VAR'
7147       include 'COMMON.GEO'
7148       thetup=pi-delta
7149       thetlow=delta
7150       if (theti.gt.pipol) then
7151         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7152       else
7153         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7154         ssder=-ssder
7155       endif
7156       return
7157       end
7158 c------------------------------------------------------------------------------
7159       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7160       implicit none
7161       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7162       double precision ksi,ksi2,ksi3,a1,a2,a3
7163       a1=fprim0*delta/(f1-f0)
7164       a2=3.0d0-2.0d0*a1
7165       a3=a1-2.0d0
7166       ksi=(x-x0)/delta
7167       ksi2=ksi*ksi
7168       ksi3=ksi2*ksi
7169       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7170       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7171       return
7172       end
7173 c------------------------------------------------------------------------------
7174       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7175       implicit none
7176       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7177       double precision ksi,ksi2,ksi3,a1,a2,a3
7178       ksi=(x-x0)/delta
7179       ksi2=ksi*ksi
7180       ksi3=ksi2*ksi
7181       a1=fprim0x*delta
7182       a2=3*(f1x-f0x)-2*fprim0x*delta
7183       a3=fprim0x*delta-2*(f1x-f0x)
7184       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7185       return
7186       end
7187 C-----------------------------------------------------------------------------
7188 #ifdef CRYST_TOR
7189 C-----------------------------------------------------------------------------
7190       subroutine etor(etors,edihcnstr)
7191       implicit real*8 (a-h,o-z)
7192       include 'DIMENSIONS'
7193       include 'COMMON.VAR'
7194       include 'COMMON.GEO'
7195       include 'COMMON.LOCAL'
7196       include 'COMMON.TORSION'
7197       include 'COMMON.INTERACT'
7198       include 'COMMON.DERIV'
7199       include 'COMMON.CHAIN'
7200       include 'COMMON.NAMES'
7201       include 'COMMON.IOUNITS'
7202       include 'COMMON.FFIELD'
7203       include 'COMMON.TORCNSTR'
7204       include 'COMMON.CONTROL'
7205       logical lprn
7206 C Set lprn=.true. for debugging
7207       lprn=.false.
7208 c      lprn=.true.
7209       etors=0.0D0
7210       do i=iphi_start,iphi_end
7211       etors_ii=0.0D0
7212         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7213      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7214         itori=itortyp(itype(i-2))
7215         itori1=itortyp(itype(i-1))
7216         phii=phi(i)
7217         gloci=0.0D0
7218 C Proline-Proline pair is a special case...
7219         if (itori.eq.3 .and. itori1.eq.3) then
7220           if (phii.gt.-dwapi3) then
7221             cosphi=dcos(3*phii)
7222             fac=1.0D0/(1.0D0-cosphi)
7223             etorsi=v1(1,3,3)*fac
7224             etorsi=etorsi+etorsi
7225             etors=etors+etorsi-v1(1,3,3)
7226             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7227             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7228           endif
7229           do j=1,3
7230             v1ij=v1(j+1,itori,itori1)
7231             v2ij=v2(j+1,itori,itori1)
7232             cosphi=dcos(j*phii)
7233             sinphi=dsin(j*phii)
7234             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7235             if (energy_dec) etors_ii=etors_ii+
7236      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7237             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7238           enddo
7239         else
7240           do j=1,nterm_old
7241             v1ij=v1(j,itori,itori1)
7242             v2ij=v2(j,itori,itori1)
7243             cosphi=dcos(j*phii)
7244             sinphi=dsin(j*phii)
7245             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7246             if (energy_dec) etors_ii=etors_ii+
7247      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7248             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7249           enddo
7250         endif
7251         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7252              'etor',i,etors_ii
7253         if (lprn)
7254      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7255      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7256      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7257         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7258 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7259       enddo
7260 ! 6/20/98 - dihedral angle constraints
7261       edihcnstr=0.0d0
7262       do i=1,ndih_constr
7263         itori=idih_constr(i)
7264         phii=phi(itori)
7265         difi=phii-phi0(i)
7266         if (difi.gt.drange(i)) then
7267           difi=difi-drange(i)
7268           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7269           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7270         else if (difi.lt.-drange(i)) then
7271           difi=difi+drange(i)
7272           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7273           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7274         endif
7275 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7276 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7277       enddo
7278 !      write (iout,*) 'edihcnstr',edihcnstr
7279       return
7280       end
7281 c------------------------------------------------------------------------------
7282       subroutine etor_d(etors_d)
7283       etors_d=0.0d0
7284       return
7285       end
7286 c----------------------------------------------------------------------------
7287 #else
7288       subroutine etor(etors,edihcnstr)
7289       implicit real*8 (a-h,o-z)
7290       include 'DIMENSIONS'
7291       include 'COMMON.VAR'
7292       include 'COMMON.GEO'
7293       include 'COMMON.LOCAL'
7294       include 'COMMON.TORSION'
7295       include 'COMMON.INTERACT'
7296       include 'COMMON.DERIV'
7297       include 'COMMON.CHAIN'
7298       include 'COMMON.NAMES'
7299       include 'COMMON.IOUNITS'
7300       include 'COMMON.FFIELD'
7301       include 'COMMON.TORCNSTR'
7302       include 'COMMON.CONTROL'
7303       logical lprn
7304 C Set lprn=.true. for debugging
7305       lprn=.false.
7306 c     lprn=.true.
7307       etors=0.0D0
7308       do i=iphi_start,iphi_end
7309 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7310 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7311 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7312 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7313         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7314      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7315 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7316 C For introducing the NH3+ and COO- group please check the etor_d for reference
7317 C and guidance
7318         etors_ii=0.0D0
7319          if (iabs(itype(i)).eq.20) then
7320          iblock=2
7321          else
7322          iblock=1
7323          endif
7324         itori=itortyp(itype(i-2))
7325         itori1=itortyp(itype(i-1))
7326         phii=phi(i)
7327         gloci=0.0D0
7328 C Regular cosine and sine terms
7329         do j=1,nterm(itori,itori1,iblock)
7330           v1ij=v1(j,itori,itori1,iblock)
7331           v2ij=v2(j,itori,itori1,iblock)
7332           cosphi=dcos(j*phii)
7333           sinphi=dsin(j*phii)
7334           etors=etors+v1ij*cosphi+v2ij*sinphi
7335           if (energy_dec) etors_ii=etors_ii+
7336      &                v1ij*cosphi+v2ij*sinphi
7337           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7338         enddo
7339 C Lorentz terms
7340 C                         v1
7341 C  E = SUM ----------------------------------- - v1
7342 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7343 C
7344         cosphi=dcos(0.5d0*phii)
7345         sinphi=dsin(0.5d0*phii)
7346         do j=1,nlor(itori,itori1,iblock)
7347           vl1ij=vlor1(j,itori,itori1)
7348           vl2ij=vlor2(j,itori,itori1)
7349           vl3ij=vlor3(j,itori,itori1)
7350           pom=vl2ij*cosphi+vl3ij*sinphi
7351           pom1=1.0d0/(pom*pom+1.0d0)
7352           etors=etors+vl1ij*pom1
7353           if (energy_dec) etors_ii=etors_ii+
7354      &                vl1ij*pom1
7355           pom=-pom*pom1*pom1
7356           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7357         enddo
7358 C Subtract the constant term
7359         etors=etors-v0(itori,itori1,iblock)
7360           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7361      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7362         if (lprn)
7363      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7364      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7365      &  (v1(j,itori,itori1,iblock),j=1,6),
7366      &  (v2(j,itori,itori1,iblock),j=1,6)
7367         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7368 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7369       enddo
7370 ! 6/20/98 - dihedral angle constraints
7371       edihcnstr=0.0d0
7372 c      do i=1,ndih_constr
7373       do i=idihconstr_start,idihconstr_end
7374         itori=idih_constr(i)
7375         phii=phi(itori)
7376         difi=pinorm(phii-phi0(i))
7377         if (difi.gt.drange(i)) then
7378           difi=difi-drange(i)
7379           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7380           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7381         else if (difi.lt.-drange(i)) then
7382           difi=difi+drange(i)
7383           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7384           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7385         else
7386           difi=0.0
7387         endif
7388        if (energy_dec) then
7389         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7390      &    i,itori,rad2deg*phii,
7391      &    rad2deg*phi0(i),  rad2deg*drange(i),
7392      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7393         endif
7394       enddo
7395 cd       write (iout,*) 'edihcnstr',edihcnstr
7396       return
7397       end
7398 c----------------------------------------------------------------------------
7399       subroutine etor_d(etors_d)
7400 C 6/23/01 Compute double torsional energy
7401       implicit real*8 (a-h,o-z)
7402       include 'DIMENSIONS'
7403       include 'COMMON.VAR'
7404       include 'COMMON.GEO'
7405       include 'COMMON.LOCAL'
7406       include 'COMMON.TORSION'
7407       include 'COMMON.INTERACT'
7408       include 'COMMON.DERIV'
7409       include 'COMMON.CHAIN'
7410       include 'COMMON.NAMES'
7411       include 'COMMON.IOUNITS'
7412       include 'COMMON.FFIELD'
7413       include 'COMMON.TORCNSTR'
7414       logical lprn
7415 C Set lprn=.true. for debugging
7416       lprn=.false.
7417 c     lprn=.true.
7418       etors_d=0.0D0
7419 c      write(iout,*) "a tu??"
7420       do i=iphid_start,iphid_end
7421 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7422 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7423 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7424 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7425 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7426          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7427      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7428      &  (itype(i+1).eq.ntyp1)) cycle
7429 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7430         itori=itortyp(itype(i-2))
7431         itori1=itortyp(itype(i-1))
7432         itori2=itortyp(itype(i))
7433         phii=phi(i)
7434         phii1=phi(i+1)
7435         gloci1=0.0D0
7436         gloci2=0.0D0
7437         iblock=1
7438         if (iabs(itype(i+1)).eq.20) iblock=2
7439 C Iblock=2 Proline type
7440 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7441 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7442 C        if (itype(i+1).eq.ntyp1) iblock=3
7443 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7444 C IS or IS NOT need for this
7445 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7446 C        is (itype(i-3).eq.ntyp1) ntblock=2
7447 C        ntblock is N-terminal blocking group
7448
7449 C Regular cosine and sine terms
7450         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7451 C Example of changes for NH3+ blocking group
7452 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7453 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7454           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7455           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7456           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7457           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7458           cosphi1=dcos(j*phii)
7459           sinphi1=dsin(j*phii)
7460           cosphi2=dcos(j*phii1)
7461           sinphi2=dsin(j*phii1)
7462           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7463      &     v2cij*cosphi2+v2sij*sinphi2
7464           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7465           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7466         enddo
7467         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7468           do l=1,k-1
7469             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7470             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7471             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7472             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7473             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7474             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7475             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7476             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7477             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7478      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7479             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7480      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7481             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7482      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7483           enddo
7484         enddo
7485         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7486         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7487       enddo
7488       return
7489       end
7490 #endif
7491 C----------------------------------------------------------------------------------
7492 C The rigorous attempt to derive energy function
7493       subroutine etor_kcc(etors,edihcnstr)
7494       implicit real*8 (a-h,o-z)
7495       include 'DIMENSIONS'
7496       include 'COMMON.VAR'
7497       include 'COMMON.GEO'
7498       include 'COMMON.LOCAL'
7499       include 'COMMON.TORSION'
7500       include 'COMMON.INTERACT'
7501       include 'COMMON.DERIV'
7502       include 'COMMON.CHAIN'
7503       include 'COMMON.NAMES'
7504       include 'COMMON.IOUNITS'
7505       include 'COMMON.FFIELD'
7506       include 'COMMON.TORCNSTR'
7507       include 'COMMON.CONTROL'
7508       logical lprn
7509 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7510 C Set lprn=.true. for debugging
7511       lprn=.false.
7512 c     lprn=.true.
7513 C      print *,"wchodze kcc"
7514       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7515       if (tor_mode.ne.2) then
7516       etors=0.0D0
7517       endif
7518       do i=iphi_start,iphi_end
7519 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7520 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7521 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7522 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7523         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7524      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7525         itori=itortyp_kcc(itype(i-2))
7526         itori1=itortyp_kcc(itype(i-1))
7527         phii=phi(i)
7528         glocig=0.0D0
7529         glocit1=0.0d0
7530         glocit2=0.0d0
7531         sumnonchebyshev=0.0d0
7532         sumchebyshev=0.0d0
7533 C to avoid multiple devision by 2
7534 c        theti22=0.5d0*theta(i)
7535 C theta 12 is the theta_1 /2
7536 C theta 22 is theta_2 /2
7537 c        theti12=0.5d0*theta(i-1)
7538 C and appropriate sinus function
7539         sinthet1=dsin(theta(i-1))
7540         sinthet2=dsin(theta(i))
7541         costhet1=dcos(theta(i-1))
7542         costhet2=dcos(theta(i))
7543 c Cosines of halves thetas
7544         costheti12=0.5d0*(1.0d0+costhet1)
7545         costheti22=0.5d0*(1.0d0+costhet2)
7546 C to speed up lets store its mutliplication
7547         sint1t2=sinthet2*sinthet1
7548         sint1t2n=1.0d0
7549 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7550 C +d_n*sin(n*gamma)) *
7551 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7552 C we have two sum 1) Non-Chebyshev which is with n and gamma
7553         etori=0.0d0
7554         do j=1,nterm_kcc(itori,itori1)
7555
7556           nval=nterm_kcc_Tb(itori,itori1)
7557           v1ij=v1_kcc(j,itori,itori1)
7558           v2ij=v2_kcc(j,itori,itori1)
7559 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7560 C v1ij is c_n and d_n in euation above
7561           cosphi=dcos(j*phii)
7562           sinphi=dsin(j*phii)
7563           sint1t2n1=sint1t2n
7564           sint1t2n=sint1t2n*sint1t2
7565           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7566      &        costheti12)
7567           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7568      &        v11_chyb(1,j,itori,itori1),costheti12)
7569 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7570 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7571           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7572      &        costheti22)
7573           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7574      &        v21_chyb(1,j,itori,itori1),costheti22)
7575 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7576 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7577           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7578      &        costheti12)
7579           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7580      &        v12_chyb(1,j,itori,itori1),costheti12)
7581 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7582 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7583           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7584      &        costheti22)
7585           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7586      &        v22_chyb(1,j,itori,itori1),costheti22)
7587 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7588 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7589 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7590 C          if (energy_dec) etors_ii=etors_ii+
7591 C     &                v1ij*cosphi+v2ij*sinphi
7592 C glocig is the gradient local i site in gamma
7593           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7594           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7595           etori=etori+sint1t2n*(actval1+actval2)
7596           glocig=glocig+
7597      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7598      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7599 C now gradient over theta_1
7600           glocit1=glocit1+
7601      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7602      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7603           glocit2=glocit2+
7604      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7605      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7606
7607 C now the Czebyshev polinominal sum
7608 c        do k=1,nterm_kcc_Tb(itori,itori1)
7609 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7610 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7611 C         thybt1(k)=0.0
7612 C         thybt2(k)=0.0
7613 c        enddo
7614 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7615 C     &         gradtschebyshev
7616 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7617 C     &         dcos(theti22)**2),
7618 C     &         dsin(theti22)
7619
7620 C now overal sumation
7621 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7622         enddo ! j
7623         etors=etors+etori
7624 C derivative over gamma
7625         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7626 C derivative over theta1
7627         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7628 C now derivative over theta2
7629         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7630         if (lprn)
7631      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7632      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7633       enddo
7634 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7635 ! 6/20/98 - dihedral angle constraints
7636       if (tor_mode.ne.2) then
7637       edihcnstr=0.0d0
7638 c      do i=1,ndih_constr
7639       do i=idihconstr_start,idihconstr_end
7640         itori=idih_constr(i)
7641         phii=phi(itori)
7642         difi=pinorm(phii-phi0(i))
7643         if (difi.gt.drange(i)) then
7644           difi=difi-drange(i)
7645           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7646           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7647         else if (difi.lt.-drange(i)) then
7648           difi=difi+drange(i)
7649           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7650           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7651         else
7652           difi=0.0
7653         endif
7654        enddo
7655        endif
7656       return
7657       end
7658
7659 C The rigorous attempt to derive energy function
7660       subroutine ebend_kcc(etheta,ethetacnstr)
7661
7662       implicit real*8 (a-h,o-z)
7663       include 'DIMENSIONS'
7664       include 'COMMON.VAR'
7665       include 'COMMON.GEO'
7666       include 'COMMON.LOCAL'
7667       include 'COMMON.TORSION'
7668       include 'COMMON.INTERACT'
7669       include 'COMMON.DERIV'
7670       include 'COMMON.CHAIN'
7671       include 'COMMON.NAMES'
7672       include 'COMMON.IOUNITS'
7673       include 'COMMON.FFIELD'
7674       include 'COMMON.TORCNSTR'
7675       include 'COMMON.CONTROL'
7676       logical lprn
7677       double precision thybt1(maxtermkcc)
7678 C Set lprn=.true. for debugging
7679       lprn=.false.
7680 c     lprn=.true.
7681 C      print *,"wchodze kcc"
7682       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7683       if (tor_mode.ne.2) etheta=0.0D0
7684       do i=ithet_start,ithet_end
7685 c        print *,i,itype(i-1),itype(i),itype(i-2)
7686         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7687      &  .or.itype(i).eq.ntyp1) cycle
7688          iti=itortyp_kcc(itype(i-1))
7689         sinthet=dsin(theta(i)/2.0d0)
7690         costhet=dcos(theta(i)/2.0d0)
7691          do j=1,nbend_kcc_Tb(iti)
7692           thybt1(j)=v1bend_chyb(j,iti)
7693          enddo
7694          sumth1thyb=tschebyshev
7695      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7696         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7697      &    sumth1thyb
7698         ihelp=nbend_kcc_Tb(iti)-1
7699         gradthybt1=gradtschebyshev
7700      &         (0,ihelp,thybt1(1),costhet)
7701         etheta=etheta+sumth1thyb
7702 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7703         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7704      &   gradthybt1*sinthet*(-0.5d0)
7705       enddo
7706       if (tor_mode.ne.2) then
7707       ethetacnstr=0.0d0
7708 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7709       do i=ithetaconstr_start,ithetaconstr_end
7710         itheta=itheta_constr(i)
7711         thetiii=theta(itheta)
7712         difi=pinorm(thetiii-theta_constr0(i))
7713         if (difi.gt.theta_drange(i)) then
7714           difi=difi-theta_drange(i)
7715           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7716           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7717      &    +for_thet_constr(i)*difi**3
7718         else if (difi.lt.-drange(i)) then
7719           difi=difi+drange(i)
7720           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7721           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7722      &    +for_thet_constr(i)*difi**3
7723         else
7724           difi=0.0
7725         endif
7726        if (energy_dec) then
7727         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7728      &    i,itheta,rad2deg*thetiii,
7729      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7730      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7731      &    gloc(itheta+nphi-2,icg)
7732         endif
7733       enddo
7734       endif
7735       return
7736       end
7737 c------------------------------------------------------------------------------
7738       subroutine eback_sc_corr(esccor)
7739 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7740 c        conformational states; temporarily implemented as differences
7741 c        between UNRES torsional potentials (dependent on three types of
7742 c        residues) and the torsional potentials dependent on all 20 types
7743 c        of residues computed from AM1  energy surfaces of terminally-blocked
7744 c        amino-acid residues.
7745       implicit real*8 (a-h,o-z)
7746       include 'DIMENSIONS'
7747       include 'COMMON.VAR'
7748       include 'COMMON.GEO'
7749       include 'COMMON.LOCAL'
7750       include 'COMMON.TORSION'
7751       include 'COMMON.SCCOR'
7752       include 'COMMON.INTERACT'
7753       include 'COMMON.DERIV'
7754       include 'COMMON.CHAIN'
7755       include 'COMMON.NAMES'
7756       include 'COMMON.IOUNITS'
7757       include 'COMMON.FFIELD'
7758       include 'COMMON.CONTROL'
7759       logical lprn
7760 C Set lprn=.true. for debugging
7761       lprn=.false.
7762 c      lprn=.true.
7763 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7764       esccor=0.0D0
7765       do i=itau_start,itau_end
7766         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7767         esccor_ii=0.0D0
7768         isccori=isccortyp(itype(i-2))
7769         isccori1=isccortyp(itype(i-1))
7770 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7771         phii=phi(i)
7772         do intertyp=1,3 !intertyp
7773 cc Added 09 May 2012 (Adasko)
7774 cc  Intertyp means interaction type of backbone mainchain correlation:
7775 c   1 = SC...Ca...Ca...Ca
7776 c   2 = Ca...Ca...Ca...SC
7777 c   3 = SC...Ca...Ca...SCi
7778         gloci=0.0D0
7779         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7780      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7781      &      (itype(i-1).eq.ntyp1)))
7782      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7783      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7784      &     .or.(itype(i).eq.ntyp1)))
7785      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7786      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7787      &      (itype(i-3).eq.ntyp1)))) cycle
7788         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7789         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7790      & cycle
7791        do j=1,nterm_sccor(isccori,isccori1)
7792           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7793           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7794           cosphi=dcos(j*tauangle(intertyp,i))
7795           sinphi=dsin(j*tauangle(intertyp,i))
7796           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7797           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7798         enddo
7799 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7800         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7801         if (lprn)
7802      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7803      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7804      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7805      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7806         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7807        enddo !intertyp
7808       enddo
7809
7810       return
7811       end
7812 c----------------------------------------------------------------------------
7813       subroutine multibody(ecorr)
7814 C This subroutine calculates multi-body contributions to energy following
7815 C the idea of Skolnick et al. If side chains I and J make a contact and
7816 C at the same time side chains I+1 and J+1 make a contact, an extra
7817 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7818       implicit real*8 (a-h,o-z)
7819       include 'DIMENSIONS'
7820       include 'COMMON.IOUNITS'
7821       include 'COMMON.DERIV'
7822       include 'COMMON.INTERACT'
7823       include 'COMMON.CONTACTS'
7824       double precision gx(3),gx1(3)
7825       logical lprn
7826
7827 C Set lprn=.true. for debugging
7828       lprn=.false.
7829
7830       if (lprn) then
7831         write (iout,'(a)') 'Contact function values:'
7832         do i=nnt,nct-2
7833           write (iout,'(i2,20(1x,i2,f10.5))')
7834      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7835         enddo
7836       endif
7837       ecorr=0.0D0
7838       do i=nnt,nct
7839         do j=1,3
7840           gradcorr(j,i)=0.0D0
7841           gradxorr(j,i)=0.0D0
7842         enddo
7843       enddo
7844       do i=nnt,nct-2
7845
7846         DO ISHIFT = 3,4
7847
7848         i1=i+ishift
7849         num_conti=num_cont(i)
7850         num_conti1=num_cont(i1)
7851         do jj=1,num_conti
7852           j=jcont(jj,i)
7853           do kk=1,num_conti1
7854             j1=jcont(kk,i1)
7855             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7856 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7857 cd   &                   ' ishift=',ishift
7858 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7859 C The system gains extra energy.
7860               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7861             endif   ! j1==j+-ishift
7862           enddo     ! kk
7863         enddo       ! jj
7864
7865         ENDDO ! ISHIFT
7866
7867       enddo         ! i
7868       return
7869       end
7870 c------------------------------------------------------------------------------
7871       double precision function esccorr(i,j,k,l,jj,kk)
7872       implicit real*8 (a-h,o-z)
7873       include 'DIMENSIONS'
7874       include 'COMMON.IOUNITS'
7875       include 'COMMON.DERIV'
7876       include 'COMMON.INTERACT'
7877       include 'COMMON.CONTACTS'
7878       include 'COMMON.SHIELD'
7879       double precision gx(3),gx1(3)
7880       logical lprn
7881       lprn=.false.
7882       eij=facont(jj,i)
7883       ekl=facont(kk,k)
7884 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7885 C Calculate the multi-body contribution to energy.
7886 C Calculate multi-body contributions to the gradient.
7887 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7888 cd   & k,l,(gacont(m,kk,k),m=1,3)
7889       do m=1,3
7890         gx(m) =ekl*gacont(m,jj,i)
7891         gx1(m)=eij*gacont(m,kk,k)
7892         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7893         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7894         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7895         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7896       enddo
7897       do m=i,j-1
7898         do ll=1,3
7899           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7900         enddo
7901       enddo
7902       do m=k,l-1
7903         do ll=1,3
7904           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7905         enddo
7906       enddo
7907       esccorr=-eij*ekl
7908       return
7909       end
7910 c------------------------------------------------------------------------------
7911       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7912 C This subroutine calculates multi-body contributions to hydrogen-bonding
7913       implicit real*8 (a-h,o-z)
7914       include 'DIMENSIONS'
7915       include 'COMMON.IOUNITS'
7916 #ifdef MPI
7917       include "mpif.h"
7918       parameter (max_cont=maxconts)
7919       parameter (max_dim=26)
7920       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7921       double precision zapas(max_dim,maxconts,max_fg_procs),
7922      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7923       common /przechowalnia/ zapas
7924       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7925      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7926 #endif
7927       include 'COMMON.SETUP'
7928       include 'COMMON.FFIELD'
7929       include 'COMMON.DERIV'
7930       include 'COMMON.INTERACT'
7931       include 'COMMON.CONTACTS'
7932       include 'COMMON.CONTROL'
7933       include 'COMMON.LOCAL'
7934       double precision gx(3),gx1(3),time00
7935       logical lprn,ldone
7936
7937 C Set lprn=.true. for debugging
7938       lprn=.false.
7939 #ifdef MPI
7940       n_corr=0
7941       n_corr1=0
7942       if (nfgtasks.le.1) goto 30
7943       if (lprn) then
7944         write (iout,'(a)') 'Contact function values before RECEIVE:'
7945         do i=nnt,nct-2
7946           write (iout,'(2i3,50(1x,i2,f5.2))')
7947      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7948      &    j=1,num_cont_hb(i))
7949         enddo
7950       endif
7951       call flush(iout)
7952       do i=1,ntask_cont_from
7953         ncont_recv(i)=0
7954       enddo
7955       do i=1,ntask_cont_to
7956         ncont_sent(i)=0
7957       enddo
7958 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7959 c     & ntask_cont_to
7960 C Make the list of contacts to send to send to other procesors
7961 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7962 c      call flush(iout)
7963       do i=iturn3_start,iturn3_end
7964 c        write (iout,*) "make contact list turn3",i," num_cont",
7965 c     &    num_cont_hb(i)
7966         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7967       enddo
7968       do i=iturn4_start,iturn4_end
7969 c        write (iout,*) "make contact list turn4",i," num_cont",
7970 c     &   num_cont_hb(i)
7971         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7972       enddo
7973       do ii=1,nat_sent
7974         i=iat_sent(ii)
7975 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7976 c     &    num_cont_hb(i)
7977         do j=1,num_cont_hb(i)
7978         do k=1,4
7979           jjc=jcont_hb(j,i)
7980           iproc=iint_sent_local(k,jjc,ii)
7981 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7982           if (iproc.gt.0) then
7983             ncont_sent(iproc)=ncont_sent(iproc)+1
7984             nn=ncont_sent(iproc)
7985             zapas(1,nn,iproc)=i
7986             zapas(2,nn,iproc)=jjc
7987             zapas(3,nn,iproc)=facont_hb(j,i)
7988             zapas(4,nn,iproc)=ees0p(j,i)
7989             zapas(5,nn,iproc)=ees0m(j,i)
7990             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7991             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7992             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7993             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7994             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7995             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7996             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7997             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7998             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7999             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8000             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8001             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8002             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8003             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8004             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8005             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8006             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8007             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8008             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8009             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8010             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8011           endif
8012         enddo
8013         enddo
8014       enddo
8015       if (lprn) then
8016       write (iout,*)
8017      &  "Numbers of contacts to be sent to other processors",
8018      &  (ncont_sent(i),i=1,ntask_cont_to)
8019       write (iout,*) "Contacts sent"
8020       do ii=1,ntask_cont_to
8021         nn=ncont_sent(ii)
8022         iproc=itask_cont_to(ii)
8023         write (iout,*) nn," contacts to processor",iproc,
8024      &   " of CONT_TO_COMM group"
8025         do i=1,nn
8026           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8027         enddo
8028       enddo
8029       call flush(iout)
8030       endif
8031       CorrelType=477
8032       CorrelID=fg_rank+1
8033       CorrelType1=478
8034       CorrelID1=nfgtasks+fg_rank+1
8035       ireq=0
8036 C Receive the numbers of needed contacts from other processors
8037       do ii=1,ntask_cont_from
8038         iproc=itask_cont_from(ii)
8039         ireq=ireq+1
8040         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8041      &    FG_COMM,req(ireq),IERR)
8042       enddo
8043 c      write (iout,*) "IRECV ended"
8044 c      call flush(iout)
8045 C Send the number of contacts needed by other processors
8046       do ii=1,ntask_cont_to
8047         iproc=itask_cont_to(ii)
8048         ireq=ireq+1
8049         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8050      &    FG_COMM,req(ireq),IERR)
8051       enddo
8052 c      write (iout,*) "ISEND ended"
8053 c      write (iout,*) "number of requests (nn)",ireq
8054       call flush(iout)
8055       if (ireq.gt.0)
8056      &  call MPI_Waitall(ireq,req,status_array,ierr)
8057 c      write (iout,*)
8058 c     &  "Numbers of contacts to be received from other processors",
8059 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8060 c      call flush(iout)
8061 C Receive contacts
8062       ireq=0
8063       do ii=1,ntask_cont_from
8064         iproc=itask_cont_from(ii)
8065         nn=ncont_recv(ii)
8066 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8067 c     &   " of CONT_TO_COMM group"
8068         call flush(iout)
8069         if (nn.gt.0) then
8070           ireq=ireq+1
8071           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8072      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8073 c          write (iout,*) "ireq,req",ireq,req(ireq)
8074         endif
8075       enddo
8076 C Send the contacts to processors that need them
8077       do ii=1,ntask_cont_to
8078         iproc=itask_cont_to(ii)
8079         nn=ncont_sent(ii)
8080 c        write (iout,*) nn," contacts to processor",iproc,
8081 c     &   " of CONT_TO_COMM group"
8082         if (nn.gt.0) then
8083           ireq=ireq+1
8084           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8085      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8086 c          write (iout,*) "ireq,req",ireq,req(ireq)
8087 c          do i=1,nn
8088 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8089 c          enddo
8090         endif
8091       enddo
8092 c      write (iout,*) "number of requests (contacts)",ireq
8093 c      write (iout,*) "req",(req(i),i=1,4)
8094 c      call flush(iout)
8095       if (ireq.gt.0)
8096      & call MPI_Waitall(ireq,req,status_array,ierr)
8097       do iii=1,ntask_cont_from
8098         iproc=itask_cont_from(iii)
8099         nn=ncont_recv(iii)
8100         if (lprn) then
8101         write (iout,*) "Received",nn," contacts from processor",iproc,
8102      &   " of CONT_FROM_COMM group"
8103         call flush(iout)
8104         do i=1,nn
8105           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8106         enddo
8107         call flush(iout)
8108         endif
8109         do i=1,nn
8110           ii=zapas_recv(1,i,iii)
8111 c Flag the received contacts to prevent double-counting
8112           jj=-zapas_recv(2,i,iii)
8113 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8114 c          call flush(iout)
8115           nnn=num_cont_hb(ii)+1
8116           num_cont_hb(ii)=nnn
8117           jcont_hb(nnn,ii)=jj
8118           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8119           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8120           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8121           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8122           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8123           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8124           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8125           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8126           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8127           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8128           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8129           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8130           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8131           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8132           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8133           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8134           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8135           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8136           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8137           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8138           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8139           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8140           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8141           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8142         enddo
8143       enddo
8144       call flush(iout)
8145       if (lprn) then
8146         write (iout,'(a)') 'Contact function values after receive:'
8147         do i=nnt,nct-2
8148           write (iout,'(2i3,50(1x,i3,f5.2))')
8149      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8150      &    j=1,num_cont_hb(i))
8151         enddo
8152         call flush(iout)
8153       endif
8154    30 continue
8155 #endif
8156       if (lprn) then
8157         write (iout,'(a)') 'Contact function values:'
8158         do i=nnt,nct-2
8159           write (iout,'(2i3,50(1x,i3,f5.2))')
8160      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8161      &    j=1,num_cont_hb(i))
8162         enddo
8163       endif
8164       ecorr=0.0D0
8165 C Remove the loop below after debugging !!!
8166       do i=nnt,nct
8167         do j=1,3
8168           gradcorr(j,i)=0.0D0
8169           gradxorr(j,i)=0.0D0
8170         enddo
8171       enddo
8172 C Calculate the local-electrostatic correlation terms
8173       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8174         i1=i+1
8175         num_conti=num_cont_hb(i)
8176         num_conti1=num_cont_hb(i+1)
8177         do jj=1,num_conti
8178           j=jcont_hb(jj,i)
8179           jp=iabs(j)
8180           do kk=1,num_conti1
8181             j1=jcont_hb(kk,i1)
8182             jp1=iabs(j1)
8183 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8184 c     &         ' jj=',jj,' kk=',kk
8185             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8186      &          .or. j.lt.0 .and. j1.gt.0) .and.
8187      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8188 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8189 C The system gains extra energy.
8190               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8191               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8192      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8193               n_corr=n_corr+1
8194             else if (j1.eq.j) then
8195 C Contacts I-J and I-(J+1) occur simultaneously.
8196 C The system loses extra energy.
8197 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8198             endif
8199           enddo ! kk
8200           do kk=1,num_conti
8201             j1=jcont_hb(kk,i)
8202 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8203 c    &         ' jj=',jj,' kk=',kk
8204             if (j1.eq.j+1) then
8205 C Contacts I-J and (I+1)-J occur simultaneously.
8206 C The system loses extra energy.
8207 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8208             endif ! j1==j+1
8209           enddo ! kk
8210         enddo ! jj
8211       enddo ! i
8212       return
8213       end
8214 c------------------------------------------------------------------------------
8215       subroutine add_hb_contact(ii,jj,itask)
8216       implicit real*8 (a-h,o-z)
8217       include "DIMENSIONS"
8218       include "COMMON.IOUNITS"
8219       integer max_cont
8220       integer max_dim
8221       parameter (max_cont=maxconts)
8222       parameter (max_dim=26)
8223       include "COMMON.CONTACTS"
8224       double precision zapas(max_dim,maxconts,max_fg_procs),
8225      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8226       common /przechowalnia/ zapas
8227       integer i,j,ii,jj,iproc,itask(4),nn
8228 c      write (iout,*) "itask",itask
8229       do i=1,2
8230         iproc=itask(i)
8231         if (iproc.gt.0) then
8232           do j=1,num_cont_hb(ii)
8233             jjc=jcont_hb(j,ii)
8234 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8235             if (jjc.eq.jj) then
8236               ncont_sent(iproc)=ncont_sent(iproc)+1
8237               nn=ncont_sent(iproc)
8238               zapas(1,nn,iproc)=ii
8239               zapas(2,nn,iproc)=jjc
8240               zapas(3,nn,iproc)=facont_hb(j,ii)
8241               zapas(4,nn,iproc)=ees0p(j,ii)
8242               zapas(5,nn,iproc)=ees0m(j,ii)
8243               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8244               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8245               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8246               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8247               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8248               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8249               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8250               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8251               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8252               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8253               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8254               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8255               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8256               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8257               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8258               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8259               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8260               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8261               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8262               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8263               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8264               exit
8265             endif
8266           enddo
8267         endif
8268       enddo
8269       return
8270       end
8271 c------------------------------------------------------------------------------
8272       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8273      &  n_corr1)
8274 C This subroutine calculates multi-body contributions to hydrogen-bonding
8275       implicit real*8 (a-h,o-z)
8276       include 'DIMENSIONS'
8277       include 'COMMON.IOUNITS'
8278 #ifdef MPI
8279       include "mpif.h"
8280       parameter (max_cont=maxconts)
8281       parameter (max_dim=70)
8282       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8283       double precision zapas(max_dim,maxconts,max_fg_procs),
8284      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8285       common /przechowalnia/ zapas
8286       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8287      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8288 #endif
8289       include 'COMMON.SETUP'
8290       include 'COMMON.FFIELD'
8291       include 'COMMON.DERIV'
8292       include 'COMMON.LOCAL'
8293       include 'COMMON.INTERACT'
8294       include 'COMMON.CONTACTS'
8295       include 'COMMON.CHAIN'
8296       include 'COMMON.CONTROL'
8297       include 'COMMON.SHIELD'
8298       double precision gx(3),gx1(3)
8299       integer num_cont_hb_old(maxres)
8300       logical lprn,ldone
8301       double precision eello4,eello5,eelo6,eello_turn6
8302       external eello4,eello5,eello6,eello_turn6
8303 C Set lprn=.true. for debugging
8304       lprn=.false.
8305       eturn6=0.0d0
8306 #ifdef MPI
8307       do i=1,nres
8308         num_cont_hb_old(i)=num_cont_hb(i)
8309       enddo
8310       n_corr=0
8311       n_corr1=0
8312       if (nfgtasks.le.1) goto 30
8313       if (lprn) then
8314         write (iout,'(a)') 'Contact function values before RECEIVE:'
8315         do i=nnt,nct-2
8316           write (iout,'(2i3,50(1x,i2,f5.2))')
8317      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8318      &    j=1,num_cont_hb(i))
8319         enddo
8320       endif
8321       call flush(iout)
8322       do i=1,ntask_cont_from
8323         ncont_recv(i)=0
8324       enddo
8325       do i=1,ntask_cont_to
8326         ncont_sent(i)=0
8327       enddo
8328 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8329 c     & ntask_cont_to
8330 C Make the list of contacts to send to send to other procesors
8331       do i=iturn3_start,iturn3_end
8332 c        write (iout,*) "make contact list turn3",i," num_cont",
8333 c     &    num_cont_hb(i)
8334         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8335       enddo
8336       do i=iturn4_start,iturn4_end
8337 c        write (iout,*) "make contact list turn4",i," num_cont",
8338 c     &   num_cont_hb(i)
8339         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8340       enddo
8341       do ii=1,nat_sent
8342         i=iat_sent(ii)
8343 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8344 c     &    num_cont_hb(i)
8345         do j=1,num_cont_hb(i)
8346         do k=1,4
8347           jjc=jcont_hb(j,i)
8348           iproc=iint_sent_local(k,jjc,ii)
8349 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8350           if (iproc.ne.0) then
8351             ncont_sent(iproc)=ncont_sent(iproc)+1
8352             nn=ncont_sent(iproc)
8353             zapas(1,nn,iproc)=i
8354             zapas(2,nn,iproc)=jjc
8355             zapas(3,nn,iproc)=d_cont(j,i)
8356             ind=3
8357             do kk=1,3
8358               ind=ind+1
8359               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8360             enddo
8361             do kk=1,2
8362               do ll=1,2
8363                 ind=ind+1
8364                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8365               enddo
8366             enddo
8367             do jj=1,5
8368               do kk=1,3
8369                 do ll=1,2
8370                   do mm=1,2
8371                     ind=ind+1
8372                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8373                   enddo
8374                 enddo
8375               enddo
8376             enddo
8377           endif
8378         enddo
8379         enddo
8380       enddo
8381       if (lprn) then
8382       write (iout,*)
8383      &  "Numbers of contacts to be sent to other processors",
8384      &  (ncont_sent(i),i=1,ntask_cont_to)
8385       write (iout,*) "Contacts sent"
8386       do ii=1,ntask_cont_to
8387         nn=ncont_sent(ii)
8388         iproc=itask_cont_to(ii)
8389         write (iout,*) nn," contacts to processor",iproc,
8390      &   " of CONT_TO_COMM group"
8391         do i=1,nn
8392           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8393         enddo
8394       enddo
8395       call flush(iout)
8396       endif
8397       CorrelType=477
8398       CorrelID=fg_rank+1
8399       CorrelType1=478
8400       CorrelID1=nfgtasks+fg_rank+1
8401       ireq=0
8402 C Receive the numbers of needed contacts from other processors
8403       do ii=1,ntask_cont_from
8404         iproc=itask_cont_from(ii)
8405         ireq=ireq+1
8406         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8407      &    FG_COMM,req(ireq),IERR)
8408       enddo
8409 c      write (iout,*) "IRECV ended"
8410 c      call flush(iout)
8411 C Send the number of contacts needed by other processors
8412       do ii=1,ntask_cont_to
8413         iproc=itask_cont_to(ii)
8414         ireq=ireq+1
8415         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8416      &    FG_COMM,req(ireq),IERR)
8417       enddo
8418 c      write (iout,*) "ISEND ended"
8419 c      write (iout,*) "number of requests (nn)",ireq
8420       call flush(iout)
8421       if (ireq.gt.0)
8422      &  call MPI_Waitall(ireq,req,status_array,ierr)
8423 c      write (iout,*)
8424 c     &  "Numbers of contacts to be received from other processors",
8425 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8426 c      call flush(iout)
8427 C Receive contacts
8428       ireq=0
8429       do ii=1,ntask_cont_from
8430         iproc=itask_cont_from(ii)
8431         nn=ncont_recv(ii)
8432 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8433 c     &   " of CONT_TO_COMM group"
8434         call flush(iout)
8435         if (nn.gt.0) then
8436           ireq=ireq+1
8437           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8438      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8439 c          write (iout,*) "ireq,req",ireq,req(ireq)
8440         endif
8441       enddo
8442 C Send the contacts to processors that need them
8443       do ii=1,ntask_cont_to
8444         iproc=itask_cont_to(ii)
8445         nn=ncont_sent(ii)
8446 c        write (iout,*) nn," contacts to processor",iproc,
8447 c     &   " of CONT_TO_COMM group"
8448         if (nn.gt.0) then
8449           ireq=ireq+1
8450           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8451      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8452 c          write (iout,*) "ireq,req",ireq,req(ireq)
8453 c          do i=1,nn
8454 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8455 c          enddo
8456         endif
8457       enddo
8458 c      write (iout,*) "number of requests (contacts)",ireq
8459 c      write (iout,*) "req",(req(i),i=1,4)
8460 c      call flush(iout)
8461       if (ireq.gt.0)
8462      & call MPI_Waitall(ireq,req,status_array,ierr)
8463       do iii=1,ntask_cont_from
8464         iproc=itask_cont_from(iii)
8465         nn=ncont_recv(iii)
8466         if (lprn) then
8467         write (iout,*) "Received",nn," contacts from processor",iproc,
8468      &   " of CONT_FROM_COMM group"
8469         call flush(iout)
8470         do i=1,nn
8471           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8472         enddo
8473         call flush(iout)
8474         endif
8475         do i=1,nn
8476           ii=zapas_recv(1,i,iii)
8477 c Flag the received contacts to prevent double-counting
8478           jj=-zapas_recv(2,i,iii)
8479 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8480 c          call flush(iout)
8481           nnn=num_cont_hb(ii)+1
8482           num_cont_hb(ii)=nnn
8483           jcont_hb(nnn,ii)=jj
8484           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8485           ind=3
8486           do kk=1,3
8487             ind=ind+1
8488             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8489           enddo
8490           do kk=1,2
8491             do ll=1,2
8492               ind=ind+1
8493               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8494             enddo
8495           enddo
8496           do jj=1,5
8497             do kk=1,3
8498               do ll=1,2
8499                 do mm=1,2
8500                   ind=ind+1
8501                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8502                 enddo
8503               enddo
8504             enddo
8505           enddo
8506         enddo
8507       enddo
8508       call flush(iout)
8509       if (lprn) then
8510         write (iout,'(a)') 'Contact function values after receive:'
8511         do i=nnt,nct-2
8512           write (iout,'(2i3,50(1x,i3,5f6.3))')
8513      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8514      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8515         enddo
8516         call flush(iout)
8517       endif
8518    30 continue
8519 #endif
8520       if (lprn) then
8521         write (iout,'(a)') 'Contact function values:'
8522         do i=nnt,nct-2
8523           write (iout,'(2i3,50(1x,i2,5f6.3))')
8524      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8525      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8526         enddo
8527       endif
8528       ecorr=0.0D0
8529       ecorr5=0.0d0
8530       ecorr6=0.0d0
8531 C Remove the loop below after debugging !!!
8532       do i=nnt,nct
8533         do j=1,3
8534           gradcorr(j,i)=0.0D0
8535           gradxorr(j,i)=0.0D0
8536         enddo
8537       enddo
8538 C Calculate the dipole-dipole interaction energies
8539       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8540       do i=iatel_s,iatel_e+1
8541         num_conti=num_cont_hb(i)
8542         do jj=1,num_conti
8543           j=jcont_hb(jj,i)
8544 #ifdef MOMENT
8545           call dipole(i,j,jj)
8546 #endif
8547         enddo
8548       enddo
8549       endif
8550 C Calculate the local-electrostatic correlation terms
8551 c                write (iout,*) "gradcorr5 in eello5 before loop"
8552 c                do iii=1,nres
8553 c                  write (iout,'(i5,3f10.5)')
8554 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8555 c                enddo
8556       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8557 c        write (iout,*) "corr loop i",i
8558         i1=i+1
8559         num_conti=num_cont_hb(i)
8560         num_conti1=num_cont_hb(i+1)
8561         do jj=1,num_conti
8562           j=jcont_hb(jj,i)
8563           jp=iabs(j)
8564           do kk=1,num_conti1
8565             j1=jcont_hb(kk,i1)
8566             jp1=iabs(j1)
8567 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8568 c     &         ' jj=',jj,' kk=',kk
8569 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8570             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8571      &          .or. j.lt.0 .and. j1.gt.0) .and.
8572      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8573 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8574 C The system gains extra energy.
8575               n_corr=n_corr+1
8576               sqd1=dsqrt(d_cont(jj,i))
8577               sqd2=dsqrt(d_cont(kk,i1))
8578               sred_geom = sqd1*sqd2
8579               IF (sred_geom.lt.cutoff_corr) THEN
8580                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8581      &            ekont,fprimcont)
8582 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8583 cd     &         ' jj=',jj,' kk=',kk
8584                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8585                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8586                 do l=1,3
8587                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8588                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8589                 enddo
8590                 n_corr1=n_corr1+1
8591 cd               write (iout,*) 'sred_geom=',sred_geom,
8592 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8593 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8594 cd               write (iout,*) "g_contij",g_contij
8595 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8596 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8597                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8598                 if (wcorr4.gt.0.0d0)
8599      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8600 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8601                   if (energy_dec.and.wcorr4.gt.0.0d0)
8602      1                 write (iout,'(a6,4i5,0pf7.3)')
8603      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8604 c                write (iout,*) "gradcorr5 before eello5"
8605 c                do iii=1,nres
8606 c                  write (iout,'(i5,3f10.5)')
8607 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8608 c                enddo
8609                 if (wcorr5.gt.0.0d0)
8610      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8611 c                write (iout,*) "gradcorr5 after eello5"
8612 c                do iii=1,nres
8613 c                  write (iout,'(i5,3f10.5)')
8614 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8615 c                enddo
8616                   if (energy_dec.and.wcorr5.gt.0.0d0)
8617      1                 write (iout,'(a6,4i5,0pf7.3)')
8618      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8619 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8620 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8621                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8622      &               .or. wturn6.eq.0.0d0))then
8623 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8624                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8625                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8626      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8627 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8628 cd     &            'ecorr6=',ecorr6
8629 cd                write (iout,'(4e15.5)') sred_geom,
8630 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8631 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8632 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8633                 else if (wturn6.gt.0.0d0
8634      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8635 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8636                   eturn6=eturn6+eello_turn6(i,jj,kk)
8637                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8638      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8639 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8640                 endif
8641               ENDIF
8642 1111          continue
8643             endif
8644           enddo ! kk
8645         enddo ! jj
8646       enddo ! i
8647       do i=1,nres
8648         num_cont_hb(i)=num_cont_hb_old(i)
8649       enddo
8650 c                write (iout,*) "gradcorr5 in eello5"
8651 c                do iii=1,nres
8652 c                  write (iout,'(i5,3f10.5)')
8653 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8654 c                enddo
8655       return
8656       end
8657 c------------------------------------------------------------------------------
8658       subroutine add_hb_contact_eello(ii,jj,itask)
8659       implicit real*8 (a-h,o-z)
8660       include "DIMENSIONS"
8661       include "COMMON.IOUNITS"
8662       integer max_cont
8663       integer max_dim
8664       parameter (max_cont=maxconts)
8665       parameter (max_dim=70)
8666       include "COMMON.CONTACTS"
8667       double precision zapas(max_dim,maxconts,max_fg_procs),
8668      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8669       common /przechowalnia/ zapas
8670       integer i,j,ii,jj,iproc,itask(4),nn
8671 c      write (iout,*) "itask",itask
8672       do i=1,2
8673         iproc=itask(i)
8674         if (iproc.gt.0) then
8675           do j=1,num_cont_hb(ii)
8676             jjc=jcont_hb(j,ii)
8677 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8678             if (jjc.eq.jj) then
8679               ncont_sent(iproc)=ncont_sent(iproc)+1
8680               nn=ncont_sent(iproc)
8681               zapas(1,nn,iproc)=ii
8682               zapas(2,nn,iproc)=jjc
8683               zapas(3,nn,iproc)=d_cont(j,ii)
8684               ind=3
8685               do kk=1,3
8686                 ind=ind+1
8687                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8688               enddo
8689               do kk=1,2
8690                 do ll=1,2
8691                   ind=ind+1
8692                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8693                 enddo
8694               enddo
8695               do jj=1,5
8696                 do kk=1,3
8697                   do ll=1,2
8698                     do mm=1,2
8699                       ind=ind+1
8700                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8701                     enddo
8702                   enddo
8703                 enddo
8704               enddo
8705               exit
8706             endif
8707           enddo
8708         endif
8709       enddo
8710       return
8711       end
8712 c------------------------------------------------------------------------------
8713       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8714       implicit real*8 (a-h,o-z)
8715       include 'DIMENSIONS'
8716       include 'COMMON.IOUNITS'
8717       include 'COMMON.DERIV'
8718       include 'COMMON.INTERACT'
8719       include 'COMMON.CONTACTS'
8720       include 'COMMON.SHIELD'
8721       include 'COMMON.CONTROL'
8722       double precision gx(3),gx1(3)
8723       logical lprn
8724       lprn=.false.
8725 C      print *,"wchodze",fac_shield(i),shield_mode
8726       eij=facont_hb(jj,i)
8727       ekl=facont_hb(kk,k)
8728       ees0pij=ees0p(jj,i)
8729       ees0pkl=ees0p(kk,k)
8730       ees0mij=ees0m(jj,i)
8731       ees0mkl=ees0m(kk,k)
8732       ekont=eij*ekl
8733       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8734 C*
8735 C     & fac_shield(i)**2*fac_shield(j)**2
8736 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8737 C Following 4 lines for diagnostics.
8738 cd    ees0pkl=0.0D0
8739 cd    ees0pij=1.0D0
8740 cd    ees0mkl=0.0D0
8741 cd    ees0mij=1.0D0
8742 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8743 c     & 'Contacts ',i,j,
8744 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8745 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8746 c     & 'gradcorr_long'
8747 C Calculate the multi-body contribution to energy.
8748 C      ecorr=ecorr+ekont*ees
8749 C Calculate multi-body contributions to the gradient.
8750       coeffpees0pij=coeffp*ees0pij
8751       coeffmees0mij=coeffm*ees0mij
8752       coeffpees0pkl=coeffp*ees0pkl
8753       coeffmees0mkl=coeffm*ees0mkl
8754       do ll=1,3
8755 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8756         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8757      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8758      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8759         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8760      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8761      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8762 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8763         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8764      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8765      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8766         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8767      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8768      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8769         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8770      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8771      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8772         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8773         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8774         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8775      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8776      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8777         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8778         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8779 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8780       enddo
8781 c      write (iout,*)
8782 cgrad      do m=i+1,j-1
8783 cgrad        do ll=1,3
8784 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8785 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8786 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8787 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8788 cgrad        enddo
8789 cgrad      enddo
8790 cgrad      do m=k+1,l-1
8791 cgrad        do ll=1,3
8792 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8793 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8794 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8795 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8796 cgrad        enddo
8797 cgrad      enddo
8798 c      write (iout,*) "ehbcorr",ekont*ees
8799 C      print *,ekont,ees,i,k
8800       ehbcorr=ekont*ees
8801 C now gradient over shielding
8802 C      return
8803       if (shield_mode.gt.0) then
8804        j=ees0plist(jj,i)
8805        l=ees0plist(kk,k)
8806 C        print *,i,j,fac_shield(i),fac_shield(j),
8807 C     &fac_shield(k),fac_shield(l)
8808         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8809      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8810           do ilist=1,ishield_list(i)
8811            iresshield=shield_list(ilist,i)
8812            do m=1,3
8813            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8814 C     &      *2.0
8815            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8816      &              rlocshield
8817      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8818             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8819      &+rlocshield
8820            enddo
8821           enddo
8822           do ilist=1,ishield_list(j)
8823            iresshield=shield_list(ilist,j)
8824            do m=1,3
8825            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8826 C     &     *2.0
8827            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8828      &              rlocshield
8829      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8830            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8831      &     +rlocshield
8832            enddo
8833           enddo
8834
8835           do ilist=1,ishield_list(k)
8836            iresshield=shield_list(ilist,k)
8837            do m=1,3
8838            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8839 C     &     *2.0
8840            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8841      &              rlocshield
8842      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8843            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8844      &     +rlocshield
8845            enddo
8846           enddo
8847           do ilist=1,ishield_list(l)
8848            iresshield=shield_list(ilist,l)
8849            do m=1,3
8850            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8851 C     &     *2.0
8852            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8853      &              rlocshield
8854      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8855            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8856      &     +rlocshield
8857            enddo
8858           enddo
8859 C          print *,gshieldx(m,iresshield)
8860           do m=1,3
8861             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8862      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8863             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8864      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8865             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8866      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8867             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8868      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8869
8870             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8871      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8872             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8873      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8874             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8875      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8876             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8877      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8878
8879            enddo
8880       endif
8881       endif
8882       return
8883       end
8884 #ifdef MOMENT
8885 C---------------------------------------------------------------------------
8886       subroutine dipole(i,j,jj)
8887       implicit real*8 (a-h,o-z)
8888       include 'DIMENSIONS'
8889       include 'COMMON.IOUNITS'
8890       include 'COMMON.CHAIN'
8891       include 'COMMON.FFIELD'
8892       include 'COMMON.DERIV'
8893       include 'COMMON.INTERACT'
8894       include 'COMMON.CONTACTS'
8895       include 'COMMON.TORSION'
8896       include 'COMMON.VAR'
8897       include 'COMMON.GEO'
8898       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8899      &  auxmat(2,2)
8900       iti1 = itortyp(itype(i+1))
8901       if (j.lt.nres-1) then
8902         itj1 = itype2loc(itype(j+1))
8903       else
8904         itj1=nloctyp
8905       endif
8906       do iii=1,2
8907         dipi(iii,1)=Ub2(iii,i)
8908         dipderi(iii)=Ub2der(iii,i)
8909         dipi(iii,2)=b1(iii,i+1)
8910         dipj(iii,1)=Ub2(iii,j)
8911         dipderj(iii)=Ub2der(iii,j)
8912         dipj(iii,2)=b1(iii,j+1)
8913       enddo
8914       kkk=0
8915       do iii=1,2
8916         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8917         do jjj=1,2
8918           kkk=kkk+1
8919           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8920         enddo
8921       enddo
8922       do kkk=1,5
8923         do lll=1,3
8924           mmm=0
8925           do iii=1,2
8926             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8927      &        auxvec(1))
8928             do jjj=1,2
8929               mmm=mmm+1
8930               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8931             enddo
8932           enddo
8933         enddo
8934       enddo
8935       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8936       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8937       do iii=1,2
8938         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8939       enddo
8940       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8941       do iii=1,2
8942         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8943       enddo
8944       return
8945       end
8946 #endif
8947 C---------------------------------------------------------------------------
8948       subroutine calc_eello(i,j,k,l,jj,kk)
8949 C
8950 C This subroutine computes matrices and vectors needed to calculate
8951 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8952 C
8953       implicit real*8 (a-h,o-z)
8954       include 'DIMENSIONS'
8955       include 'COMMON.IOUNITS'
8956       include 'COMMON.CHAIN'
8957       include 'COMMON.DERIV'
8958       include 'COMMON.INTERACT'
8959       include 'COMMON.CONTACTS'
8960       include 'COMMON.TORSION'
8961       include 'COMMON.VAR'
8962       include 'COMMON.GEO'
8963       include 'COMMON.FFIELD'
8964       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8965      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8966       logical lprn
8967       common /kutas/ lprn
8968 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8969 cd     & ' jj=',jj,' kk=',kk
8970 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8971 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8972 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8973       do iii=1,2
8974         do jjj=1,2
8975           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8976           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8977         enddo
8978       enddo
8979       call transpose2(aa1(1,1),aa1t(1,1))
8980       call transpose2(aa2(1,1),aa2t(1,1))
8981       do kkk=1,5
8982         do lll=1,3
8983           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8984      &      aa1tder(1,1,lll,kkk))
8985           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8986      &      aa2tder(1,1,lll,kkk))
8987         enddo
8988       enddo
8989       if (l.eq.j+1) then
8990 C parallel orientation of the two CA-CA-CA frames.
8991         if (i.gt.1) then
8992           iti=itype2loc(itype(i))
8993         else
8994           iti=nloctyp
8995         endif
8996         itk1=itype2loc(itype(k+1))
8997         itj=itype2loc(itype(j))
8998         if (l.lt.nres-1) then
8999           itl1=itype2loc(itype(l+1))
9000         else
9001           itl1=nloctyp
9002         endif
9003 C A1 kernel(j+1) A2T
9004 cd        do iii=1,2
9005 cd          write (iout,'(3f10.5,5x,3f10.5)')
9006 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9007 cd        enddo
9008         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9009      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9010      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9011 C Following matrices are needed only for 6-th order cumulants
9012         IF (wcorr6.gt.0.0d0) THEN
9013         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9014      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9015      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9016         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9017      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9018      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9019      &   ADtEAderx(1,1,1,1,1,1))
9020         lprn=.false.
9021         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9022      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9023      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9024      &   ADtEA1derx(1,1,1,1,1,1))
9025         ENDIF
9026 C End 6-th order cumulants
9027 cd        lprn=.false.
9028 cd        if (lprn) then
9029 cd        write (2,*) 'In calc_eello6'
9030 cd        do iii=1,2
9031 cd          write (2,*) 'iii=',iii
9032 cd          do kkk=1,5
9033 cd            write (2,*) 'kkk=',kkk
9034 cd            do jjj=1,2
9035 cd              write (2,'(3(2f10.5),5x)')
9036 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9037 cd            enddo
9038 cd          enddo
9039 cd        enddo
9040 cd        endif
9041         call transpose2(EUgder(1,1,k),auxmat(1,1))
9042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9043         call transpose2(EUg(1,1,k),auxmat(1,1))
9044         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9045         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9046         do iii=1,2
9047           do kkk=1,5
9048             do lll=1,3
9049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9050      &          EAEAderx(1,1,lll,kkk,iii,1))
9051             enddo
9052           enddo
9053         enddo
9054 C A1T kernel(i+1) A2
9055         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9056      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9057      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9058 C Following matrices are needed only for 6-th order cumulants
9059         IF (wcorr6.gt.0.0d0) THEN
9060         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9061      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9062      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9063         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9064      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9065      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9066      &   ADtEAderx(1,1,1,1,1,2))
9067         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9068      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9069      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9070      &   ADtEA1derx(1,1,1,1,1,2))
9071         ENDIF
9072 C End 6-th order cumulants
9073         call transpose2(EUgder(1,1,l),auxmat(1,1))
9074         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9075         call transpose2(EUg(1,1,l),auxmat(1,1))
9076         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9077         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9078         do iii=1,2
9079           do kkk=1,5
9080             do lll=1,3
9081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9082      &          EAEAderx(1,1,lll,kkk,iii,2))
9083             enddo
9084           enddo
9085         enddo
9086 C AEAb1 and AEAb2
9087 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9088 C They are needed only when the fifth- or the sixth-order cumulants are
9089 C indluded.
9090         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9091         call transpose2(AEA(1,1,1),auxmat(1,1))
9092         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9093         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9094         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9095         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9096         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9097         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9098         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9099         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9100         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9101         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9102         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9103         call transpose2(AEA(1,1,2),auxmat(1,1))
9104         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9105         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9106         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9107         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9108         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9109         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9110         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9111         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9112         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9113         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9114         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9115 C Calculate the Cartesian derivatives of the vectors.
9116         do iii=1,2
9117           do kkk=1,5
9118             do lll=1,3
9119               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9120               call matvec2(auxmat(1,1),b1(1,i),
9121      &          AEAb1derx(1,lll,kkk,iii,1,1))
9122               call matvec2(auxmat(1,1),Ub2(1,i),
9123      &          AEAb2derx(1,lll,kkk,iii,1,1))
9124               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9125      &          AEAb1derx(1,lll,kkk,iii,2,1))
9126               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9127      &          AEAb2derx(1,lll,kkk,iii,2,1))
9128               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9129               call matvec2(auxmat(1,1),b1(1,j),
9130      &          AEAb1derx(1,lll,kkk,iii,1,2))
9131               call matvec2(auxmat(1,1),Ub2(1,j),
9132      &          AEAb2derx(1,lll,kkk,iii,1,2))
9133               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9134      &          AEAb1derx(1,lll,kkk,iii,2,2))
9135               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9136      &          AEAb2derx(1,lll,kkk,iii,2,2))
9137             enddo
9138           enddo
9139         enddo
9140         ENDIF
9141 C End vectors
9142       else
9143 C Antiparallel orientation of the two CA-CA-CA frames.
9144         if (i.gt.1) then
9145           iti=itype2loc(itype(i))
9146         else
9147           iti=nloctyp
9148         endif
9149         itk1=itype2loc(itype(k+1))
9150         itl=itype2loc(itype(l))
9151         itj=itype2loc(itype(j))
9152         if (j.lt.nres-1) then
9153           itj1=itype2loc(itype(j+1))
9154         else
9155           itj1=nloctyp
9156         endif
9157 C A2 kernel(j-1)T A1T
9158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9159      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9160      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9161 C Following matrices are needed only for 6-th order cumulants
9162         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9163      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9165      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9166      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9167         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9168      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9169      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9170      &   ADtEAderx(1,1,1,1,1,1))
9171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9172      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9173      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9174      &   ADtEA1derx(1,1,1,1,1,1))
9175         ENDIF
9176 C End 6-th order cumulants
9177         call transpose2(EUgder(1,1,k),auxmat(1,1))
9178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9179         call transpose2(EUg(1,1,k),auxmat(1,1))
9180         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9181         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9182         do iii=1,2
9183           do kkk=1,5
9184             do lll=1,3
9185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9186      &          EAEAderx(1,1,lll,kkk,iii,1))
9187             enddo
9188           enddo
9189         enddo
9190 C A2T kernel(i+1)T A1
9191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9192      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9193      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9194 C Following matrices are needed only for 6-th order cumulants
9195         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9196      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9197         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9198      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9199      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9200         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9201      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9202      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9203      &   ADtEAderx(1,1,1,1,1,2))
9204         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9205      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9206      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9207      &   ADtEA1derx(1,1,1,1,1,2))
9208         ENDIF
9209 C End 6-th order cumulants
9210         call transpose2(EUgder(1,1,j),auxmat(1,1))
9211         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9212         call transpose2(EUg(1,1,j),auxmat(1,1))
9213         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9214         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9215         do iii=1,2
9216           do kkk=1,5
9217             do lll=1,3
9218               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9219      &          EAEAderx(1,1,lll,kkk,iii,2))
9220             enddo
9221           enddo
9222         enddo
9223 C AEAb1 and AEAb2
9224 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9225 C They are needed only when the fifth- or the sixth-order cumulants are
9226 C indluded.
9227         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9228      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9229         call transpose2(AEA(1,1,1),auxmat(1,1))
9230         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9231         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9232         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9233         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9234         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9235         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9236         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9237         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9238         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9239         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9240         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9241         call transpose2(AEA(1,1,2),auxmat(1,1))
9242         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9243         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9244         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9245         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9246         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9247         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9248         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9249         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9250         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9251         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9252         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9253 C Calculate the Cartesian derivatives of the vectors.
9254         do iii=1,2
9255           do kkk=1,5
9256             do lll=1,3
9257               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9258               call matvec2(auxmat(1,1),b1(1,i),
9259      &          AEAb1derx(1,lll,kkk,iii,1,1))
9260               call matvec2(auxmat(1,1),Ub2(1,i),
9261      &          AEAb2derx(1,lll,kkk,iii,1,1))
9262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9263      &          AEAb1derx(1,lll,kkk,iii,2,1))
9264               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9265      &          AEAb2derx(1,lll,kkk,iii,2,1))
9266               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9267               call matvec2(auxmat(1,1),b1(1,l),
9268      &          AEAb1derx(1,lll,kkk,iii,1,2))
9269               call matvec2(auxmat(1,1),Ub2(1,l),
9270      &          AEAb2derx(1,lll,kkk,iii,1,2))
9271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9272      &          AEAb1derx(1,lll,kkk,iii,2,2))
9273               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9274      &          AEAb2derx(1,lll,kkk,iii,2,2))
9275             enddo
9276           enddo
9277         enddo
9278         ENDIF
9279 C End vectors
9280       endif
9281       return
9282       end
9283 C---------------------------------------------------------------------------
9284       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9285      &  KK,KKderg,AKA,AKAderg,AKAderx)
9286       implicit none
9287       integer nderg
9288       logical transp
9289       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9290      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9291      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9292       integer iii,kkk,lll
9293       integer jjj,mmm
9294       logical lprn
9295       common /kutas/ lprn
9296       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9297       do iii=1,nderg
9298         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9299      &    AKAderg(1,1,iii))
9300       enddo
9301 cd      if (lprn) write (2,*) 'In kernel'
9302       do kkk=1,5
9303 cd        if (lprn) write (2,*) 'kkk=',kkk
9304         do lll=1,3
9305           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9306      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9307 cd          if (lprn) then
9308 cd            write (2,*) 'lll=',lll
9309 cd            write (2,*) 'iii=1'
9310 cd            do jjj=1,2
9311 cd              write (2,'(3(2f10.5),5x)')
9312 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9313 cd            enddo
9314 cd          endif
9315           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9316      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9317 cd          if (lprn) then
9318 cd            write (2,*) 'lll=',lll
9319 cd            write (2,*) 'iii=2'
9320 cd            do jjj=1,2
9321 cd              write (2,'(3(2f10.5),5x)')
9322 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9323 cd            enddo
9324 cd          endif
9325         enddo
9326       enddo
9327       return
9328       end
9329 C---------------------------------------------------------------------------
9330       double precision function eello4(i,j,k,l,jj,kk)
9331       implicit real*8 (a-h,o-z)
9332       include 'DIMENSIONS'
9333       include 'COMMON.IOUNITS'
9334       include 'COMMON.CHAIN'
9335       include 'COMMON.DERIV'
9336       include 'COMMON.INTERACT'
9337       include 'COMMON.CONTACTS'
9338       include 'COMMON.TORSION'
9339       include 'COMMON.VAR'
9340       include 'COMMON.GEO'
9341       double precision pizda(2,2),ggg1(3),ggg2(3)
9342 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9343 cd        eello4=0.0d0
9344 cd        return
9345 cd      endif
9346 cd      print *,'eello4:',i,j,k,l,jj,kk
9347 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9348 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9349 cold      eij=facont_hb(jj,i)
9350 cold      ekl=facont_hb(kk,k)
9351 cold      ekont=eij*ekl
9352       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9353 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9354       gcorr_loc(k-1)=gcorr_loc(k-1)
9355      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9356       if (l.eq.j+1) then
9357         gcorr_loc(l-1)=gcorr_loc(l-1)
9358      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9359       else
9360         gcorr_loc(j-1)=gcorr_loc(j-1)
9361      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9362       endif
9363       do iii=1,2
9364         do kkk=1,5
9365           do lll=1,3
9366             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9367      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9368 cd            derx(lll,kkk,iii)=0.0d0
9369           enddo
9370         enddo
9371       enddo
9372 cd      gcorr_loc(l-1)=0.0d0
9373 cd      gcorr_loc(j-1)=0.0d0
9374 cd      gcorr_loc(k-1)=0.0d0
9375 cd      eel4=1.0d0
9376 cd      write (iout,*)'Contacts have occurred for peptide groups',
9377 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9378 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9379       if (j.lt.nres-1) then
9380         j1=j+1
9381         j2=j-1
9382       else
9383         j1=j-1
9384         j2=j-2
9385       endif
9386       if (l.lt.nres-1) then
9387         l1=l+1
9388         l2=l-1
9389       else
9390         l1=l-1
9391         l2=l-2
9392       endif
9393       do ll=1,3
9394 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9395 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9396         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9397         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9398 cgrad        ghalf=0.5d0*ggg1(ll)
9399         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9400         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9401         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9402         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9403         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9404         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9405 cgrad        ghalf=0.5d0*ggg2(ll)
9406         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9407         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9408         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9409         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9410         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9411         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9412       enddo
9413 cgrad      do m=i+1,j-1
9414 cgrad        do ll=1,3
9415 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9416 cgrad        enddo
9417 cgrad      enddo
9418 cgrad      do m=k+1,l-1
9419 cgrad        do ll=1,3
9420 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9421 cgrad        enddo
9422 cgrad      enddo
9423 cgrad      do m=i+2,j2
9424 cgrad        do ll=1,3
9425 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9426 cgrad        enddo
9427 cgrad      enddo
9428 cgrad      do m=k+2,l2
9429 cgrad        do ll=1,3
9430 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9431 cgrad        enddo
9432 cgrad      enddo
9433 cd      do iii=1,nres-3
9434 cd        write (2,*) iii,gcorr_loc(iii)
9435 cd      enddo
9436       eello4=ekont*eel4
9437 cd      write (2,*) 'ekont',ekont
9438 cd      write (iout,*) 'eello4',ekont*eel4
9439       return
9440       end
9441 C---------------------------------------------------------------------------
9442       double precision function eello5(i,j,k,l,jj,kk)
9443       implicit real*8 (a-h,o-z)
9444       include 'DIMENSIONS'
9445       include 'COMMON.IOUNITS'
9446       include 'COMMON.CHAIN'
9447       include 'COMMON.DERIV'
9448       include 'COMMON.INTERACT'
9449       include 'COMMON.CONTACTS'
9450       include 'COMMON.TORSION'
9451       include 'COMMON.VAR'
9452       include 'COMMON.GEO'
9453       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9454       double precision ggg1(3),ggg2(3)
9455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9456 C                                                                              C
9457 C                            Parallel chains                                   C
9458 C                                                                              C
9459 C          o             o                   o             o                   C
9460 C         /l\           / \             \   / \           / \   /              C
9461 C        /   \         /   \             \ /   \         /   \ /               C
9462 C       j| o |l1       | o |              o| o |         | o |o                C
9463 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9464 C      \i/   \         /   \ /             /   \         /   \                 C
9465 C       o    k1             o                                                  C
9466 C         (I)          (II)                (III)          (IV)                 C
9467 C                                                                              C
9468 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9469 C                                                                              C
9470 C                            Antiparallel chains                               C
9471 C                                                                              C
9472 C          o             o                   o             o                   C
9473 C         /j\           / \             \   / \           / \   /              C
9474 C        /   \         /   \             \ /   \         /   \ /               C
9475 C      j1| o |l        | o |              o| o |         | o |o                C
9476 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9477 C      \i/   \         /   \ /             /   \         /   \                 C
9478 C       o     k1            o                                                  C
9479 C         (I)          (II)                (III)          (IV)                 C
9480 C                                                                              C
9481 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9482 C                                                                              C
9483 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9484 C                                                                              C
9485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9486 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9487 cd        eello5=0.0d0
9488 cd        return
9489 cd      endif
9490 cd      write (iout,*)
9491 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9492 cd     &   ' and',k,l
9493       itk=itype2loc(itype(k))
9494       itl=itype2loc(itype(l))
9495       itj=itype2loc(itype(j))
9496       eello5_1=0.0d0
9497       eello5_2=0.0d0
9498       eello5_3=0.0d0
9499       eello5_4=0.0d0
9500 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9501 cd     &   eel5_3_num,eel5_4_num)
9502       do iii=1,2
9503         do kkk=1,5
9504           do lll=1,3
9505             derx(lll,kkk,iii)=0.0d0
9506           enddo
9507         enddo
9508       enddo
9509 cd      eij=facont_hb(jj,i)
9510 cd      ekl=facont_hb(kk,k)
9511 cd      ekont=eij*ekl
9512 cd      write (iout,*)'Contacts have occurred for peptide groups',
9513 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9514 cd      goto 1111
9515 C Contribution from the graph I.
9516 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9517 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9518       call transpose2(EUg(1,1,k),auxmat(1,1))
9519       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9520       vv(1)=pizda(1,1)-pizda(2,2)
9521       vv(2)=pizda(1,2)+pizda(2,1)
9522       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9523      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9524 C Explicit gradient in virtual-dihedral angles.
9525       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9526      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9527      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9528       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9529       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9530       vv(1)=pizda(1,1)-pizda(2,2)
9531       vv(2)=pizda(1,2)+pizda(2,1)
9532       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9533      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9534      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9535       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9536       vv(1)=pizda(1,1)-pizda(2,2)
9537       vv(2)=pizda(1,2)+pizda(2,1)
9538       if (l.eq.j+1) then
9539         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9540      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9541      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9542       else
9543         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9544      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9545      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9546       endif
9547 C Cartesian gradient
9548       do iii=1,2
9549         do kkk=1,5
9550           do lll=1,3
9551             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9552      &        pizda(1,1))
9553             vv(1)=pizda(1,1)-pizda(2,2)
9554             vv(2)=pizda(1,2)+pizda(2,1)
9555             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9556      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9557      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9558           enddo
9559         enddo
9560       enddo
9561 c      goto 1112
9562 c1111  continue
9563 C Contribution from graph II
9564       call transpose2(EE(1,1,k),auxmat(1,1))
9565       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9566       vv(1)=pizda(1,1)+pizda(2,2)
9567       vv(2)=pizda(2,1)-pizda(1,2)
9568       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9569      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9570 C Explicit gradient in virtual-dihedral angles.
9571       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9572      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9573       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9574       vv(1)=pizda(1,1)+pizda(2,2)
9575       vv(2)=pizda(2,1)-pizda(1,2)
9576       if (l.eq.j+1) then
9577         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9578      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9579      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9580       else
9581         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9582      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9583      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9584       endif
9585 C Cartesian gradient
9586       do iii=1,2
9587         do kkk=1,5
9588           do lll=1,3
9589             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9590      &        pizda(1,1))
9591             vv(1)=pizda(1,1)+pizda(2,2)
9592             vv(2)=pizda(2,1)-pizda(1,2)
9593             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9594      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9595      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9596           enddo
9597         enddo
9598       enddo
9599 cd      goto 1112
9600 cd1111  continue
9601       if (l.eq.j+1) then
9602 cd        goto 1110
9603 C Parallel orientation
9604 C Contribution from graph III
9605         call transpose2(EUg(1,1,l),auxmat(1,1))
9606         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9607         vv(1)=pizda(1,1)-pizda(2,2)
9608         vv(2)=pizda(1,2)+pizda(2,1)
9609         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9610      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9611 C Explicit gradient in virtual-dihedral angles.
9612         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9613      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9614      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9615         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9616         vv(1)=pizda(1,1)-pizda(2,2)
9617         vv(2)=pizda(1,2)+pizda(2,1)
9618         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9619      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9620      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9621         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9622         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9623         vv(1)=pizda(1,1)-pizda(2,2)
9624         vv(2)=pizda(1,2)+pizda(2,1)
9625         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9626      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9627      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9628 C Cartesian gradient
9629         do iii=1,2
9630           do kkk=1,5
9631             do lll=1,3
9632               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9633      &          pizda(1,1))
9634               vv(1)=pizda(1,1)-pizda(2,2)
9635               vv(2)=pizda(1,2)+pizda(2,1)
9636               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9637      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9638      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9639             enddo
9640           enddo
9641         enddo
9642 cd        goto 1112
9643 C Contribution from graph IV
9644 cd1110    continue
9645         call transpose2(EE(1,1,l),auxmat(1,1))
9646         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9647         vv(1)=pizda(1,1)+pizda(2,2)
9648         vv(2)=pizda(2,1)-pizda(1,2)
9649         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9650      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9651 C Explicit gradient in virtual-dihedral angles.
9652         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9653      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9654         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9655         vv(1)=pizda(1,1)+pizda(2,2)
9656         vv(2)=pizda(2,1)-pizda(1,2)
9657         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9658      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9659      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9660 C Cartesian gradient
9661         do iii=1,2
9662           do kkk=1,5
9663             do lll=1,3
9664               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9665      &          pizda(1,1))
9666               vv(1)=pizda(1,1)+pizda(2,2)
9667               vv(2)=pizda(2,1)-pizda(1,2)
9668               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9669      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9670      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9671             enddo
9672           enddo
9673         enddo
9674       else
9675 C Antiparallel orientation
9676 C Contribution from graph III
9677 c        goto 1110
9678         call transpose2(EUg(1,1,j),auxmat(1,1))
9679         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9680         vv(1)=pizda(1,1)-pizda(2,2)
9681         vv(2)=pizda(1,2)+pizda(2,1)
9682         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9683      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9684 C Explicit gradient in virtual-dihedral angles.
9685         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9686      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9687      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9688         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9689         vv(1)=pizda(1,1)-pizda(2,2)
9690         vv(2)=pizda(1,2)+pizda(2,1)
9691         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9692      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9693      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9694         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9695         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9696         vv(1)=pizda(1,1)-pizda(2,2)
9697         vv(2)=pizda(1,2)+pizda(2,1)
9698         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9699      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9700      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9701 C Cartesian gradient
9702         do iii=1,2
9703           do kkk=1,5
9704             do lll=1,3
9705               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9706      &          pizda(1,1))
9707               vv(1)=pizda(1,1)-pizda(2,2)
9708               vv(2)=pizda(1,2)+pizda(2,1)
9709               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9710      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9711      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9712             enddo
9713           enddo
9714         enddo
9715 cd        goto 1112
9716 C Contribution from graph IV
9717 1110    continue
9718         call transpose2(EE(1,1,j),auxmat(1,1))
9719         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9720         vv(1)=pizda(1,1)+pizda(2,2)
9721         vv(2)=pizda(2,1)-pizda(1,2)
9722         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9723      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9724 C Explicit gradient in virtual-dihedral angles.
9725         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9726      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9727         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9728         vv(1)=pizda(1,1)+pizda(2,2)
9729         vv(2)=pizda(2,1)-pizda(1,2)
9730         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9731      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9732      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9733 C Cartesian gradient
9734         do iii=1,2
9735           do kkk=1,5
9736             do lll=1,3
9737               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9738      &          pizda(1,1))
9739               vv(1)=pizda(1,1)+pizda(2,2)
9740               vv(2)=pizda(2,1)-pizda(1,2)
9741               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9742      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9743      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9744             enddo
9745           enddo
9746         enddo
9747       endif
9748 1112  continue
9749       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9750 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9751 cd        write (2,*) 'ijkl',i,j,k,l
9752 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9753 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9754 cd      endif
9755 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9756 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9757 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9758 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9759       if (j.lt.nres-1) then
9760         j1=j+1
9761         j2=j-1
9762       else
9763         j1=j-1
9764         j2=j-2
9765       endif
9766       if (l.lt.nres-1) then
9767         l1=l+1
9768         l2=l-1
9769       else
9770         l1=l-1
9771         l2=l-2
9772       endif
9773 cd      eij=1.0d0
9774 cd      ekl=1.0d0
9775 cd      ekont=1.0d0
9776 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9777 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9778 C        summed up outside the subrouine as for the other subroutines
9779 C        handling long-range interactions. The old code is commented out
9780 C        with "cgrad" to keep track of changes.
9781       do ll=1,3
9782 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9783 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9784         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9785         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9786 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9787 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9788 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9789 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9790 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9791 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9792 c     &   gradcorr5ij,
9793 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9794 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9795 cgrad        ghalf=0.5d0*ggg1(ll)
9796 cd        ghalf=0.0d0
9797         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9798         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9799         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9800         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9801         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9802         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9803 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9804 cgrad        ghalf=0.5d0*ggg2(ll)
9805 cd        ghalf=0.0d0
9806         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9807         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9808         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9809         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9810         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9811         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9812       enddo
9813 cd      goto 1112
9814 cgrad      do m=i+1,j-1
9815 cgrad        do ll=1,3
9816 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9817 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9818 cgrad        enddo
9819 cgrad      enddo
9820 cgrad      do m=k+1,l-1
9821 cgrad        do ll=1,3
9822 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9823 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9824 cgrad        enddo
9825 cgrad      enddo
9826 c1112  continue
9827 cgrad      do m=i+2,j2
9828 cgrad        do ll=1,3
9829 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9830 cgrad        enddo
9831 cgrad      enddo
9832 cgrad      do m=k+2,l2
9833 cgrad        do ll=1,3
9834 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9835 cgrad        enddo
9836 cgrad      enddo
9837 cd      do iii=1,nres-3
9838 cd        write (2,*) iii,g_corr5_loc(iii)
9839 cd      enddo
9840       eello5=ekont*eel5
9841 cd      write (2,*) 'ekont',ekont
9842 cd      write (iout,*) 'eello5',ekont*eel5
9843       return
9844       end
9845 c--------------------------------------------------------------------------
9846       double precision function eello6(i,j,k,l,jj,kk)
9847       implicit real*8 (a-h,o-z)
9848       include 'DIMENSIONS'
9849       include 'COMMON.IOUNITS'
9850       include 'COMMON.CHAIN'
9851       include 'COMMON.DERIV'
9852       include 'COMMON.INTERACT'
9853       include 'COMMON.CONTACTS'
9854       include 'COMMON.TORSION'
9855       include 'COMMON.VAR'
9856       include 'COMMON.GEO'
9857       include 'COMMON.FFIELD'
9858       double precision ggg1(3),ggg2(3)
9859 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9860 cd        eello6=0.0d0
9861 cd        return
9862 cd      endif
9863 cd      write (iout,*)
9864 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9865 cd     &   ' and',k,l
9866       eello6_1=0.0d0
9867       eello6_2=0.0d0
9868       eello6_3=0.0d0
9869       eello6_4=0.0d0
9870       eello6_5=0.0d0
9871       eello6_6=0.0d0
9872 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9873 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9874       do iii=1,2
9875         do kkk=1,5
9876           do lll=1,3
9877             derx(lll,kkk,iii)=0.0d0
9878           enddo
9879         enddo
9880       enddo
9881 cd      eij=facont_hb(jj,i)
9882 cd      ekl=facont_hb(kk,k)
9883 cd      ekont=eij*ekl
9884 cd      eij=1.0d0
9885 cd      ekl=1.0d0
9886 cd      ekont=1.0d0
9887       if (l.eq.j+1) then
9888         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9889         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9890         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9891         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9892         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9893         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9894       else
9895         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9896         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9897         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9898         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9899         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9900           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9901         else
9902           eello6_5=0.0d0
9903         endif
9904         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9905       endif
9906 C If turn contributions are considered, they will be handled separately.
9907       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9908 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9909 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9910 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9911 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9912 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9913 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9914 cd      goto 1112
9915       if (j.lt.nres-1) then
9916         j1=j+1
9917         j2=j-1
9918       else
9919         j1=j-1
9920         j2=j-2
9921       endif
9922       if (l.lt.nres-1) then
9923         l1=l+1
9924         l2=l-1
9925       else
9926         l1=l-1
9927         l2=l-2
9928       endif
9929       do ll=1,3
9930 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9931 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9932 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9933 cgrad        ghalf=0.5d0*ggg1(ll)
9934 cd        ghalf=0.0d0
9935         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9936         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9937         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9938         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9939         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9940         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9941         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9942         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9943 cgrad        ghalf=0.5d0*ggg2(ll)
9944 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9945 cd        ghalf=0.0d0
9946         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9947         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9948         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9949         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9950         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9951         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9952       enddo
9953 cd      goto 1112
9954 cgrad      do m=i+1,j-1
9955 cgrad        do ll=1,3
9956 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9957 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9958 cgrad        enddo
9959 cgrad      enddo
9960 cgrad      do m=k+1,l-1
9961 cgrad        do ll=1,3
9962 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9963 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9964 cgrad        enddo
9965 cgrad      enddo
9966 cgrad1112  continue
9967 cgrad      do m=i+2,j2
9968 cgrad        do ll=1,3
9969 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9970 cgrad        enddo
9971 cgrad      enddo
9972 cgrad      do m=k+2,l2
9973 cgrad        do ll=1,3
9974 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9975 cgrad        enddo
9976 cgrad      enddo
9977 cd      do iii=1,nres-3
9978 cd        write (2,*) iii,g_corr6_loc(iii)
9979 cd      enddo
9980       eello6=ekont*eel6
9981 cd      write (2,*) 'ekont',ekont
9982 cd      write (iout,*) 'eello6',ekont*eel6
9983       return
9984       end
9985 c--------------------------------------------------------------------------
9986       double precision function eello6_graph1(i,j,k,l,imat,swap)
9987       implicit real*8 (a-h,o-z)
9988       include 'DIMENSIONS'
9989       include 'COMMON.IOUNITS'
9990       include 'COMMON.CHAIN'
9991       include 'COMMON.DERIV'
9992       include 'COMMON.INTERACT'
9993       include 'COMMON.CONTACTS'
9994       include 'COMMON.TORSION'
9995       include 'COMMON.VAR'
9996       include 'COMMON.GEO'
9997       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9998       logical swap
9999       logical lprn
10000       common /kutas/ lprn
10001 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10002 C                                                                              C
10003 C      Parallel       Antiparallel                                             C
10004 C                                                                              C
10005 C          o             o                                                     C
10006 C         /l\           /j\                                                    C
10007 C        /   \         /   \                                                   C
10008 C       /| o |         | o |\                                                  C
10009 C     \ j|/k\|  /   \  |/k\|l /                                                C
10010 C      \ /   \ /     \ /   \ /                                                 C
10011 C       o     o       o     o                                                  C
10012 C       i             i                                                        C
10013 C                                                                              C
10014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10015       itk=itype2loc(itype(k))
10016       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10017       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10018       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10019       call transpose2(EUgC(1,1,k),auxmat(1,1))
10020       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10021       vv1(1)=pizda1(1,1)-pizda1(2,2)
10022       vv1(2)=pizda1(1,2)+pizda1(2,1)
10023       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10024       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10025       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10026       s5=scalar2(vv(1),Dtobr2(1,i))
10027 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10028       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10029       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10030      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10031      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10032      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10033      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10034      & +scalar2(vv(1),Dtobr2der(1,i)))
10035       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10036       vv1(1)=pizda1(1,1)-pizda1(2,2)
10037       vv1(2)=pizda1(1,2)+pizda1(2,1)
10038       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10039       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10040       if (l.eq.j+1) then
10041         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10042      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10043      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10044      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10045      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10046       else
10047         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10048      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10049      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10050      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10051      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10052       endif
10053       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10054       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10055       vv1(1)=pizda1(1,1)-pizda1(2,2)
10056       vv1(2)=pizda1(1,2)+pizda1(2,1)
10057       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10058      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10059      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10060      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10061       do iii=1,2
10062         if (swap) then
10063           ind=3-iii
10064         else
10065           ind=iii
10066         endif
10067         do kkk=1,5
10068           do lll=1,3
10069             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10070             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10071             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10072             call transpose2(EUgC(1,1,k),auxmat(1,1))
10073             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10074      &        pizda1(1,1))
10075             vv1(1)=pizda1(1,1)-pizda1(2,2)
10076             vv1(2)=pizda1(1,2)+pizda1(2,1)
10077             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10078             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10079      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10080             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10081      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10082             s5=scalar2(vv(1),Dtobr2(1,i))
10083             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10084           enddo
10085         enddo
10086       enddo
10087       return
10088       end
10089 c----------------------------------------------------------------------------
10090       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10091       implicit real*8 (a-h,o-z)
10092       include 'DIMENSIONS'
10093       include 'COMMON.IOUNITS'
10094       include 'COMMON.CHAIN'
10095       include 'COMMON.DERIV'
10096       include 'COMMON.INTERACT'
10097       include 'COMMON.CONTACTS'
10098       include 'COMMON.TORSION'
10099       include 'COMMON.VAR'
10100       include 'COMMON.GEO'
10101       logical swap
10102       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10103      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10104       logical lprn
10105       common /kutas/ lprn
10106 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10107 C                                                                              C
10108 C      Parallel       Antiparallel                                             C
10109 C                                                                              C
10110 C          o             o                                                     C
10111 C     \   /l\           /j\   /                                                C
10112 C      \ /   \         /   \ /                                                 C
10113 C       o| o |         | o |o                                                  C
10114 C     \ j|/k\|      \  |/k\|l                                                  C
10115 C      \ /   \       \ /   \                                                   C
10116 C       o             o                                                        C
10117 C       i             i                                                        C
10118 C                                                                              C
10119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10120 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10121 C AL 7/4/01 s1 would occur in the sixth-order moment,
10122 C           but not in a cluster cumulant
10123 #ifdef MOMENT
10124       s1=dip(1,jj,i)*dip(1,kk,k)
10125 #endif
10126       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10127       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10128       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10129       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10130       call transpose2(EUg(1,1,k),auxmat(1,1))
10131       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10132       vv(1)=pizda(1,1)-pizda(2,2)
10133       vv(2)=pizda(1,2)+pizda(2,1)
10134       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10135 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10136 #ifdef MOMENT
10137       eello6_graph2=-(s1+s2+s3+s4)
10138 #else
10139       eello6_graph2=-(s2+s3+s4)
10140 #endif
10141 c      eello6_graph2=-s3
10142 C Derivatives in gamma(i-1)
10143       if (i.gt.1) then
10144 #ifdef MOMENT
10145         s1=dipderg(1,jj,i)*dip(1,kk,k)
10146 #endif
10147         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10148         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10149         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10150         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10151 #ifdef MOMENT
10152         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10153 #else
10154         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10155 #endif
10156 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10157       endif
10158 C Derivatives in gamma(k-1)
10159 #ifdef MOMENT
10160       s1=dip(1,jj,i)*dipderg(1,kk,k)
10161 #endif
10162       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10163       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10164       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10165       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10166       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10167       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10168       vv(1)=pizda(1,1)-pizda(2,2)
10169       vv(2)=pizda(1,2)+pizda(2,1)
10170       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10171 #ifdef MOMENT
10172       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10173 #else
10174       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10175 #endif
10176 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10177 C Derivatives in gamma(j-1) or gamma(l-1)
10178       if (j.gt.1) then
10179 #ifdef MOMENT
10180         s1=dipderg(3,jj,i)*dip(1,kk,k)
10181 #endif
10182         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10183         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10184         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10185         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10186         vv(1)=pizda(1,1)-pizda(2,2)
10187         vv(2)=pizda(1,2)+pizda(2,1)
10188         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10189 #ifdef MOMENT
10190         if (swap) then
10191           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10192         else
10193           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10194         endif
10195 #endif
10196         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10197 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10198       endif
10199 C Derivatives in gamma(l-1) or gamma(j-1)
10200       if (l.gt.1) then
10201 #ifdef MOMENT
10202         s1=dip(1,jj,i)*dipderg(3,kk,k)
10203 #endif
10204         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10205         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10206         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10207         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10208         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10209         vv(1)=pizda(1,1)-pizda(2,2)
10210         vv(2)=pizda(1,2)+pizda(2,1)
10211         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10212 #ifdef MOMENT
10213         if (swap) then
10214           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10215         else
10216           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10217         endif
10218 #endif
10219         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10220 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10221       endif
10222 C Cartesian derivatives.
10223       if (lprn) then
10224         write (2,*) 'In eello6_graph2'
10225         do iii=1,2
10226           write (2,*) 'iii=',iii
10227           do kkk=1,5
10228             write (2,*) 'kkk=',kkk
10229             do jjj=1,2
10230               write (2,'(3(2f10.5),5x)')
10231      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10232             enddo
10233           enddo
10234         enddo
10235       endif
10236       do iii=1,2
10237         do kkk=1,5
10238           do lll=1,3
10239 #ifdef MOMENT
10240             if (iii.eq.1) then
10241               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10242             else
10243               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10244             endif
10245 #endif
10246             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10247      &        auxvec(1))
10248             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10249             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10250      &        auxvec(1))
10251             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10252             call transpose2(EUg(1,1,k),auxmat(1,1))
10253             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10254      &        pizda(1,1))
10255             vv(1)=pizda(1,1)-pizda(2,2)
10256             vv(2)=pizda(1,2)+pizda(2,1)
10257             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10258 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10259 #ifdef MOMENT
10260             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10261 #else
10262             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10263 #endif
10264             if (swap) then
10265               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10266             else
10267               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10268             endif
10269           enddo
10270         enddo
10271       enddo
10272       return
10273       end
10274 c----------------------------------------------------------------------------
10275       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10276       implicit real*8 (a-h,o-z)
10277       include 'DIMENSIONS'
10278       include 'COMMON.IOUNITS'
10279       include 'COMMON.CHAIN'
10280       include 'COMMON.DERIV'
10281       include 'COMMON.INTERACT'
10282       include 'COMMON.CONTACTS'
10283       include 'COMMON.TORSION'
10284       include 'COMMON.VAR'
10285       include 'COMMON.GEO'
10286       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10287       logical swap
10288 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10289 C                                                                              C
10290 C      Parallel       Antiparallel                                             C
10291 C                                                                              C
10292 C          o             o                                                     C
10293 C         /l\   /   \   /j\                                                    C
10294 C        /   \ /     \ /   \                                                   C
10295 C       /| o |o       o| o |\                                                  C
10296 C       j|/k\|  /      |/k\|l /                                                C
10297 C        /   \ /       /   \ /                                                 C
10298 C       /     o       /     o                                                  C
10299 C       i             i                                                        C
10300 C                                                                              C
10301 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10302 C
10303 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10304 C           energy moment and not to the cluster cumulant.
10305       iti=itortyp(itype(i))
10306       if (j.lt.nres-1) then
10307         itj1=itype2loc(itype(j+1))
10308       else
10309         itj1=nloctyp
10310       endif
10311       itk=itype2loc(itype(k))
10312       itk1=itype2loc(itype(k+1))
10313       if (l.lt.nres-1) then
10314         itl1=itype2loc(itype(l+1))
10315       else
10316         itl1=nloctyp
10317       endif
10318 #ifdef MOMENT
10319       s1=dip(4,jj,i)*dip(4,kk,k)
10320 #endif
10321       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10322       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10323       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10324       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10325       call transpose2(EE(1,1,k),auxmat(1,1))
10326       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10327       vv(1)=pizda(1,1)+pizda(2,2)
10328       vv(2)=pizda(2,1)-pizda(1,2)
10329       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10330 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10331 cd     & "sum",-(s2+s3+s4)
10332 #ifdef MOMENT
10333       eello6_graph3=-(s1+s2+s3+s4)
10334 #else
10335       eello6_graph3=-(s2+s3+s4)
10336 #endif
10337 c      eello6_graph3=-s4
10338 C Derivatives in gamma(k-1)
10339       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10340       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10341       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10342       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10343 C Derivatives in gamma(l-1)
10344       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10345       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10346       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10347       vv(1)=pizda(1,1)+pizda(2,2)
10348       vv(2)=pizda(2,1)-pizda(1,2)
10349       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10350       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10351 C Cartesian derivatives.
10352       do iii=1,2
10353         do kkk=1,5
10354           do lll=1,3
10355 #ifdef MOMENT
10356             if (iii.eq.1) then
10357               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10358             else
10359               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10360             endif
10361 #endif
10362             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10363      &        auxvec(1))
10364             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10365             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10366      &        auxvec(1))
10367             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10368             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10369      &        pizda(1,1))
10370             vv(1)=pizda(1,1)+pizda(2,2)
10371             vv(2)=pizda(2,1)-pizda(1,2)
10372             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10373 #ifdef MOMENT
10374             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10375 #else
10376             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10377 #endif
10378             if (swap) then
10379               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10380             else
10381               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10382             endif
10383 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10384           enddo
10385         enddo
10386       enddo
10387       return
10388       end
10389 c----------------------------------------------------------------------------
10390       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10391       implicit real*8 (a-h,o-z)
10392       include 'DIMENSIONS'
10393       include 'COMMON.IOUNITS'
10394       include 'COMMON.CHAIN'
10395       include 'COMMON.DERIV'
10396       include 'COMMON.INTERACT'
10397       include 'COMMON.CONTACTS'
10398       include 'COMMON.TORSION'
10399       include 'COMMON.VAR'
10400       include 'COMMON.GEO'
10401       include 'COMMON.FFIELD'
10402       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10403      & auxvec1(2),auxmat1(2,2)
10404       logical swap
10405 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10406 C                                                                              C
10407 C      Parallel       Antiparallel                                             C
10408 C                                                                              C
10409 C          o             o                                                     C
10410 C         /l\   /   \   /j\                                                    C
10411 C        /   \ /     \ /   \                                                   C
10412 C       /| o |o       o| o |\                                                  C
10413 C     \ j|/k\|      \  |/k\|l                                                  C
10414 C      \ /   \       \ /   \                                                   C
10415 C       o     \       o     \                                                  C
10416 C       i             i                                                        C
10417 C                                                                              C
10418 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10419 C
10420 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10421 C           energy moment and not to the cluster cumulant.
10422 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10423       iti=itype2loc(itype(i))
10424       itj=itype2loc(itype(j))
10425       if (j.lt.nres-1) then
10426         itj1=itype2loc(itype(j+1))
10427       else
10428         itj1=nloctyp
10429       endif
10430       itk=itype2loc(itype(k))
10431       if (k.lt.nres-1) then
10432         itk1=itype2loc(itype(k+1))
10433       else
10434         itk1=nloctyp
10435       endif
10436       itl=itype2loc(itype(l))
10437       if (l.lt.nres-1) then
10438         itl1=itype2loc(itype(l+1))
10439       else
10440         itl1=nloctyp
10441       endif
10442 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10443 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10444 cd     & ' itl',itl,' itl1',itl1
10445 #ifdef MOMENT
10446       if (imat.eq.1) then
10447         s1=dip(3,jj,i)*dip(3,kk,k)
10448       else
10449         s1=dip(2,jj,j)*dip(2,kk,l)
10450       endif
10451 #endif
10452       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10453       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10454       if (j.eq.l+1) then
10455         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10456         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10457       else
10458         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10459         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10460       endif
10461       call transpose2(EUg(1,1,k),auxmat(1,1))
10462       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10463       vv(1)=pizda(1,1)-pizda(2,2)
10464       vv(2)=pizda(2,1)+pizda(1,2)
10465       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10466 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10467 #ifdef MOMENT
10468       eello6_graph4=-(s1+s2+s3+s4)
10469 #else
10470       eello6_graph4=-(s2+s3+s4)
10471 #endif
10472 C Derivatives in gamma(i-1)
10473       if (i.gt.1) then
10474 #ifdef MOMENT
10475         if (imat.eq.1) then
10476           s1=dipderg(2,jj,i)*dip(3,kk,k)
10477         else
10478           s1=dipderg(4,jj,j)*dip(2,kk,l)
10479         endif
10480 #endif
10481         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10482         if (j.eq.l+1) then
10483           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10484           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10485         else
10486           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10487           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10488         endif
10489         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10490         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10491 cd          write (2,*) 'turn6 derivatives'
10492 #ifdef MOMENT
10493           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10494 #else
10495           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10496 #endif
10497         else
10498 #ifdef MOMENT
10499           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10500 #else
10501           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10502 #endif
10503         endif
10504       endif
10505 C Derivatives in gamma(k-1)
10506 #ifdef MOMENT
10507       if (imat.eq.1) then
10508         s1=dip(3,jj,i)*dipderg(2,kk,k)
10509       else
10510         s1=dip(2,jj,j)*dipderg(4,kk,l)
10511       endif
10512 #endif
10513       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10514       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10515       if (j.eq.l+1) then
10516         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10517         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10518       else
10519         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10520         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10521       endif
10522       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10523       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10524       vv(1)=pizda(1,1)-pizda(2,2)
10525       vv(2)=pizda(2,1)+pizda(1,2)
10526       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10527       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10528 #ifdef MOMENT
10529         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10530 #else
10531         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10532 #endif
10533       else
10534 #ifdef MOMENT
10535         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10536 #else
10537         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10538 #endif
10539       endif
10540 C Derivatives in gamma(j-1) or gamma(l-1)
10541       if (l.eq.j+1 .and. l.gt.1) then
10542         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10543         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10544         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10545         vv(1)=pizda(1,1)-pizda(2,2)
10546         vv(2)=pizda(2,1)+pizda(1,2)
10547         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10548         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10549       else if (j.gt.1) then
10550         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10551         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10552         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10553         vv(1)=pizda(1,1)-pizda(2,2)
10554         vv(2)=pizda(2,1)+pizda(1,2)
10555         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10556         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10557           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10558         else
10559           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10560         endif
10561       endif
10562 C Cartesian derivatives.
10563       do iii=1,2
10564         do kkk=1,5
10565           do lll=1,3
10566 #ifdef MOMENT
10567             if (iii.eq.1) then
10568               if (imat.eq.1) then
10569                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10570               else
10571                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10572               endif
10573             else
10574               if (imat.eq.1) then
10575                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10576               else
10577                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10578               endif
10579             endif
10580 #endif
10581             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10582      &        auxvec(1))
10583             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10584             if (j.eq.l+1) then
10585               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10586      &          b1(1,j+1),auxvec(1))
10587               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10588             else
10589               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10590      &          b1(1,l+1),auxvec(1))
10591               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10592             endif
10593             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10594      &        pizda(1,1))
10595             vv(1)=pizda(1,1)-pizda(2,2)
10596             vv(2)=pizda(2,1)+pizda(1,2)
10597             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10598             if (swap) then
10599               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10600 #ifdef MOMENT
10601                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10602      &             -(s1+s2+s4)
10603 #else
10604                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10605      &             -(s2+s4)
10606 #endif
10607                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10608               else
10609 #ifdef MOMENT
10610                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10611 #else
10612                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10613 #endif
10614                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10615               endif
10616             else
10617 #ifdef MOMENT
10618               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10619 #else
10620               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10621 #endif
10622               if (l.eq.j+1) then
10623                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10624               else
10625                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10626               endif
10627             endif
10628           enddo
10629         enddo
10630       enddo
10631       return
10632       end
10633 c----------------------------------------------------------------------------
10634       double precision function eello_turn6(i,jj,kk)
10635       implicit real*8 (a-h,o-z)
10636       include 'DIMENSIONS'
10637       include 'COMMON.IOUNITS'
10638       include 'COMMON.CHAIN'
10639       include 'COMMON.DERIV'
10640       include 'COMMON.INTERACT'
10641       include 'COMMON.CONTACTS'
10642       include 'COMMON.TORSION'
10643       include 'COMMON.VAR'
10644       include 'COMMON.GEO'
10645       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10646      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10647      &  ggg1(3),ggg2(3)
10648       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10649      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10650 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10651 C           the respective energy moment and not to the cluster cumulant.
10652       s1=0.0d0
10653       s8=0.0d0
10654       s13=0.0d0
10655 c
10656       eello_turn6=0.0d0
10657       j=i+4
10658       k=i+1
10659       l=i+3
10660       iti=itype2loc(itype(i))
10661       itk=itype2loc(itype(k))
10662       itk1=itype2loc(itype(k+1))
10663       itl=itype2loc(itype(l))
10664       itj=itype2loc(itype(j))
10665 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10666 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10667 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10668 cd        eello6=0.0d0
10669 cd        return
10670 cd      endif
10671 cd      write (iout,*)
10672 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10673 cd     &   ' and',k,l
10674 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10675       do iii=1,2
10676         do kkk=1,5
10677           do lll=1,3
10678             derx_turn(lll,kkk,iii)=0.0d0
10679           enddo
10680         enddo
10681       enddo
10682 cd      eij=1.0d0
10683 cd      ekl=1.0d0
10684 cd      ekont=1.0d0
10685       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10686 cd      eello6_5=0.0d0
10687 cd      write (2,*) 'eello6_5',eello6_5
10688 #ifdef MOMENT
10689       call transpose2(AEA(1,1,1),auxmat(1,1))
10690       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10691       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10692       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10693 #endif
10694       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10695       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10696       s2 = scalar2(b1(1,k),vtemp1(1))
10697 #ifdef MOMENT
10698       call transpose2(AEA(1,1,2),atemp(1,1))
10699       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10700       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10701       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10702 #endif
10703       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10704       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10705       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10706 #ifdef MOMENT
10707       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10708       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10709       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10710       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10711       ss13 = scalar2(b1(1,k),vtemp4(1))
10712       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10713 #endif
10714 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10715 c      s1=0.0d0
10716 c      s2=0.0d0
10717 c      s8=0.0d0
10718 c      s12=0.0d0
10719 c      s13=0.0d0
10720       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10721 C Derivatives in gamma(i+2)
10722       s1d =0.0d0
10723       s8d =0.0d0
10724 #ifdef MOMENT
10725       call transpose2(AEA(1,1,1),auxmatd(1,1))
10726       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10727       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10728       call transpose2(AEAderg(1,1,2),atempd(1,1))
10729       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10730       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10731 #endif
10732       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10733       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10734       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10735 c      s1d=0.0d0
10736 c      s2d=0.0d0
10737 c      s8d=0.0d0
10738 c      s12d=0.0d0
10739 c      s13d=0.0d0
10740       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10741 C Derivatives in gamma(i+3)
10742 #ifdef MOMENT
10743       call transpose2(AEA(1,1,1),auxmatd(1,1))
10744       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10745       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10746       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10747 #endif
10748       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10749       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10750       s2d = scalar2(b1(1,k),vtemp1d(1))
10751 #ifdef MOMENT
10752       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10753       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10754 #endif
10755       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10756 #ifdef MOMENT
10757       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10758       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10759       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10760 #endif
10761 c      s1d=0.0d0
10762 c      s2d=0.0d0
10763 c      s8d=0.0d0
10764 c      s12d=0.0d0
10765 c      s13d=0.0d0
10766 #ifdef MOMENT
10767       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10768      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10769 #else
10770       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10771      &               -0.5d0*ekont*(s2d+s12d)
10772 #endif
10773 C Derivatives in gamma(i+4)
10774       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10775       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10776       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10777 #ifdef MOMENT
10778       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10779       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10780       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10781 #endif
10782 c      s1d=0.0d0
10783 c      s2d=0.0d0
10784 c      s8d=0.0d0
10785 C      s12d=0.0d0
10786 c      s13d=0.0d0
10787 #ifdef MOMENT
10788       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10789 #else
10790       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10791 #endif
10792 C Derivatives in gamma(i+5)
10793 #ifdef MOMENT
10794       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10795       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10796       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10797 #endif
10798       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10799       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10800       s2d = scalar2(b1(1,k),vtemp1d(1))
10801 #ifdef MOMENT
10802       call transpose2(AEA(1,1,2),atempd(1,1))
10803       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10804       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10805 #endif
10806       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10807       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10808 #ifdef MOMENT
10809       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10810       ss13d = scalar2(b1(1,k),vtemp4d(1))
10811       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10812 #endif
10813 c      s1d=0.0d0
10814 c      s2d=0.0d0
10815 c      s8d=0.0d0
10816 c      s12d=0.0d0
10817 c      s13d=0.0d0
10818 #ifdef MOMENT
10819       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10820      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10821 #else
10822       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10823      &               -0.5d0*ekont*(s2d+s12d)
10824 #endif
10825 C Cartesian derivatives
10826       do iii=1,2
10827         do kkk=1,5
10828           do lll=1,3
10829 #ifdef MOMENT
10830             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10831             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10832             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10833 #endif
10834             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10835             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10836      &          vtemp1d(1))
10837             s2d = scalar2(b1(1,k),vtemp1d(1))
10838 #ifdef MOMENT
10839             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10840             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10841             s8d = -(atempd(1,1)+atempd(2,2))*
10842      &           scalar2(cc(1,1,itl),vtemp2(1))
10843 #endif
10844             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10845      &           auxmatd(1,1))
10846             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10847             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10848 c      s1d=0.0d0
10849 c      s2d=0.0d0
10850 c      s8d=0.0d0
10851 c      s12d=0.0d0
10852 c      s13d=0.0d0
10853 #ifdef MOMENT
10854             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10855      &        - 0.5d0*(s1d+s2d)
10856 #else
10857             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10858      &        - 0.5d0*s2d
10859 #endif
10860 #ifdef MOMENT
10861             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10862      &        - 0.5d0*(s8d+s12d)
10863 #else
10864             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10865      &        - 0.5d0*s12d
10866 #endif
10867           enddo
10868         enddo
10869       enddo
10870 #ifdef MOMENT
10871       do kkk=1,5
10872         do lll=1,3
10873           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10874      &      achuj_tempd(1,1))
10875           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10876           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10877           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10878           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10879           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10880      &      vtemp4d(1))
10881           ss13d = scalar2(b1(1,k),vtemp4d(1))
10882           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10883           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10884         enddo
10885       enddo
10886 #endif
10887 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10888 cd     &  16*eel_turn6_num
10889 cd      goto 1112
10890       if (j.lt.nres-1) then
10891         j1=j+1
10892         j2=j-1
10893       else
10894         j1=j-1
10895         j2=j-2
10896       endif
10897       if (l.lt.nres-1) then
10898         l1=l+1
10899         l2=l-1
10900       else
10901         l1=l-1
10902         l2=l-2
10903       endif
10904       do ll=1,3
10905 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10906 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10907 cgrad        ghalf=0.5d0*ggg1(ll)
10908 cd        ghalf=0.0d0
10909         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10910         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10911         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10912      &    +ekont*derx_turn(ll,2,1)
10913         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10914         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10915      &    +ekont*derx_turn(ll,4,1)
10916         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10917         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10918         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10919 cgrad        ghalf=0.5d0*ggg2(ll)
10920 cd        ghalf=0.0d0
10921         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10922      &    +ekont*derx_turn(ll,2,2)
10923         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10924         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10925      &    +ekont*derx_turn(ll,4,2)
10926         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10927         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10928         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10929       enddo
10930 cd      goto 1112
10931 cgrad      do m=i+1,j-1
10932 cgrad        do ll=1,3
10933 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10934 cgrad        enddo
10935 cgrad      enddo
10936 cgrad      do m=k+1,l-1
10937 cgrad        do ll=1,3
10938 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10939 cgrad        enddo
10940 cgrad      enddo
10941 cgrad1112  continue
10942 cgrad      do m=i+2,j2
10943 cgrad        do ll=1,3
10944 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10945 cgrad        enddo
10946 cgrad      enddo
10947 cgrad      do m=k+2,l2
10948 cgrad        do ll=1,3
10949 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10950 cgrad        enddo
10951 cgrad      enddo
10952 cd      do iii=1,nres-3
10953 cd        write (2,*) iii,g_corr6_loc(iii)
10954 cd      enddo
10955       eello_turn6=ekont*eel_turn6
10956 cd      write (2,*) 'ekont',ekont
10957 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10958       return
10959       end
10960
10961 C-----------------------------------------------------------------------------
10962       double precision function scalar(u,v)
10963 !DIR$ INLINEALWAYS scalar
10964 #ifndef OSF
10965 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10966 #endif
10967       implicit none
10968       double precision u(3),v(3)
10969 cd      double precision sc
10970 cd      integer i
10971 cd      sc=0.0d0
10972 cd      do i=1,3
10973 cd        sc=sc+u(i)*v(i)
10974 cd      enddo
10975 cd      scalar=sc
10976
10977       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10978       return
10979       end
10980 crc-------------------------------------------------
10981       SUBROUTINE MATVEC2(A1,V1,V2)
10982 !DIR$ INLINEALWAYS MATVEC2
10983 #ifndef OSF
10984 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10985 #endif
10986       implicit real*8 (a-h,o-z)
10987       include 'DIMENSIONS'
10988       DIMENSION A1(2,2),V1(2),V2(2)
10989 c      DO 1 I=1,2
10990 c        VI=0.0
10991 c        DO 3 K=1,2
10992 c    3     VI=VI+A1(I,K)*V1(K)
10993 c        Vaux(I)=VI
10994 c    1 CONTINUE
10995
10996       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10997       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10998
10999       v2(1)=vaux1
11000       v2(2)=vaux2
11001       END
11002 C---------------------------------------
11003       SUBROUTINE MATMAT2(A1,A2,A3)
11004 #ifndef OSF
11005 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11006 #endif
11007       implicit real*8 (a-h,o-z)
11008       include 'DIMENSIONS'
11009       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11010 c      DIMENSION AI3(2,2)
11011 c        DO  J=1,2
11012 c          A3IJ=0.0
11013 c          DO K=1,2
11014 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11015 c          enddo
11016 c          A3(I,J)=A3IJ
11017 c       enddo
11018 c      enddo
11019
11020       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11021       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11022       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11023       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11024
11025       A3(1,1)=AI3_11
11026       A3(2,1)=AI3_21
11027       A3(1,2)=AI3_12
11028       A3(2,2)=AI3_22
11029       END
11030
11031 c-------------------------------------------------------------------------
11032       double precision function scalar2(u,v)
11033 !DIR$ INLINEALWAYS scalar2
11034       implicit none
11035       double precision u(2),v(2)
11036       double precision sc
11037       integer i
11038       scalar2=u(1)*v(1)+u(2)*v(2)
11039       return
11040       end
11041
11042 C-----------------------------------------------------------------------------
11043
11044       subroutine transpose2(a,at)
11045 !DIR$ INLINEALWAYS transpose2
11046 #ifndef OSF
11047 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11048 #endif
11049       implicit none
11050       double precision a(2,2),at(2,2)
11051       at(1,1)=a(1,1)
11052       at(1,2)=a(2,1)
11053       at(2,1)=a(1,2)
11054       at(2,2)=a(2,2)
11055       return
11056       end
11057 c--------------------------------------------------------------------------
11058       subroutine transpose(n,a,at)
11059       implicit none
11060       integer n,i,j
11061       double precision a(n,n),at(n,n)
11062       do i=1,n
11063         do j=1,n
11064           at(j,i)=a(i,j)
11065         enddo
11066       enddo
11067       return
11068       end
11069 C---------------------------------------------------------------------------
11070       subroutine prodmat3(a1,a2,kk,transp,prod)
11071 !DIR$ INLINEALWAYS prodmat3
11072 #ifndef OSF
11073 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11074 #endif
11075       implicit none
11076       integer i,j
11077       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11078       logical transp
11079 crc      double precision auxmat(2,2),prod_(2,2)
11080
11081       if (transp) then
11082 crc        call transpose2(kk(1,1),auxmat(1,1))
11083 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11084 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11085
11086            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11087      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11088            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11089      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11090            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11091      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11092            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11093      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11094
11095       else
11096 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11097 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11098
11099            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11100      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11101            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11102      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11103            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11104      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11105            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11106      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11107
11108       endif
11109 c      call transpose2(a2(1,1),a2t(1,1))
11110
11111 crc      print *,transp
11112 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11113 crc      print *,((prod(i,j),i=1,2),j=1,2)
11114
11115       return
11116       end
11117 CCC----------------------------------------------
11118       subroutine Eliptransfer(eliptran)
11119       implicit real*8 (a-h,o-z)
11120       include 'DIMENSIONS'
11121       include 'COMMON.GEO'
11122       include 'COMMON.VAR'
11123       include 'COMMON.LOCAL'
11124       include 'COMMON.CHAIN'
11125       include 'COMMON.DERIV'
11126       include 'COMMON.NAMES'
11127       include 'COMMON.INTERACT'
11128       include 'COMMON.IOUNITS'
11129       include 'COMMON.CALC'
11130       include 'COMMON.CONTROL'
11131       include 'COMMON.SPLITELE'
11132       include 'COMMON.SBRIDGE'
11133 C this is done by Adasko
11134 C      print *,"wchodze"
11135 C structure of box:
11136 C      water
11137 C--bordliptop-- buffore starts
11138 C--bufliptop--- here true lipid starts
11139 C      lipid
11140 C--buflipbot--- lipid ends buffore starts
11141 C--bordlipbot--buffore ends
11142       eliptran=0.0
11143       do i=ilip_start,ilip_end
11144 C       do i=1,1
11145         if (itype(i).eq.ntyp1) cycle
11146
11147         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11148         if (positi.le.0.0) positi=positi+boxzsize
11149 C        print *,i
11150 C first for peptide groups
11151 c for each residue check if it is in lipid or lipid water border area
11152        if ((positi.gt.bordlipbot)
11153      &.and.(positi.lt.bordliptop)) then
11154 C the energy transfer exist
11155         if (positi.lt.buflipbot) then
11156 C what fraction I am in
11157          fracinbuf=1.0d0-
11158      &        ((positi-bordlipbot)/lipbufthick)
11159 C lipbufthick is thickenes of lipid buffore
11160          sslip=sscalelip(fracinbuf)
11161          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11162          eliptran=eliptran+sslip*pepliptran
11163          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11164          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11165 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11166
11167 C        print *,"doing sccale for lower part"
11168 C         print *,i,sslip,fracinbuf,ssgradlip
11169         elseif (positi.gt.bufliptop) then
11170          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11171          sslip=sscalelip(fracinbuf)
11172          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11173          eliptran=eliptran+sslip*pepliptran
11174          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11175          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11176 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11177 C          print *, "doing sscalefor top part"
11178 C         print *,i,sslip,fracinbuf,ssgradlip
11179         else
11180          eliptran=eliptran+pepliptran
11181 C         print *,"I am in true lipid"
11182         endif
11183 C       else
11184 C       eliptran=elpitran+0.0 ! I am in water
11185        endif
11186        enddo
11187 C       print *, "nic nie bylo w lipidzie?"
11188 C now multiply all by the peptide group transfer factor
11189 C       eliptran=eliptran*pepliptran
11190 C now the same for side chains
11191 CV       do i=1,1
11192        do i=ilip_start,ilip_end
11193         if (itype(i).eq.ntyp1) cycle
11194         positi=(mod(c(3,i+nres),boxzsize))
11195         if (positi.le.0) positi=positi+boxzsize
11196 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11197 c for each residue check if it is in lipid or lipid water border area
11198 C       respos=mod(c(3,i+nres),boxzsize)
11199 C       print *,positi,bordlipbot,buflipbot
11200        if ((positi.gt.bordlipbot)
11201      & .and.(positi.lt.bordliptop)) then
11202 C the energy transfer exist
11203         if (positi.lt.buflipbot) then
11204          fracinbuf=1.0d0-
11205      &     ((positi-bordlipbot)/lipbufthick)
11206 C lipbufthick is thickenes of lipid buffore
11207          sslip=sscalelip(fracinbuf)
11208          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11209          eliptran=eliptran+sslip*liptranene(itype(i))
11210          gliptranx(3,i)=gliptranx(3,i)
11211      &+ssgradlip*liptranene(itype(i))
11212          gliptranc(3,i-1)= gliptranc(3,i-1)
11213      &+ssgradlip*liptranene(itype(i))
11214 C         print *,"doing sccale for lower part"
11215         elseif (positi.gt.bufliptop) then
11216          fracinbuf=1.0d0-
11217      &((bordliptop-positi)/lipbufthick)
11218          sslip=sscalelip(fracinbuf)
11219          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11220          eliptran=eliptran+sslip*liptranene(itype(i))
11221          gliptranx(3,i)=gliptranx(3,i)
11222      &+ssgradlip*liptranene(itype(i))
11223          gliptranc(3,i-1)= gliptranc(3,i-1)
11224      &+ssgradlip*liptranene(itype(i))
11225 C          print *, "doing sscalefor top part",sslip,fracinbuf
11226         else
11227          eliptran=eliptran+liptranene(itype(i))
11228 C         print *,"I am in true lipid"
11229         endif
11230         endif ! if in lipid or buffor
11231 C       else
11232 C       eliptran=elpitran+0.0 ! I am in water
11233        enddo
11234        return
11235        end
11236 C---------------------------------------------------------
11237 C AFM soubroutine for constant force
11238        subroutine AFMforce(Eafmforce)
11239        implicit real*8 (a-h,o-z)
11240       include 'DIMENSIONS'
11241       include 'COMMON.GEO'
11242       include 'COMMON.VAR'
11243       include 'COMMON.LOCAL'
11244       include 'COMMON.CHAIN'
11245       include 'COMMON.DERIV'
11246       include 'COMMON.NAMES'
11247       include 'COMMON.INTERACT'
11248       include 'COMMON.IOUNITS'
11249       include 'COMMON.CALC'
11250       include 'COMMON.CONTROL'
11251       include 'COMMON.SPLITELE'
11252       include 'COMMON.SBRIDGE'
11253       real*8 diffafm(3)
11254       dist=0.0d0
11255       Eafmforce=0.0d0
11256       do i=1,3
11257       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11258       dist=dist+diffafm(i)**2
11259       enddo
11260       dist=dsqrt(dist)
11261       Eafmforce=-forceAFMconst*(dist-distafminit)
11262       do i=1,3
11263       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11264       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11265       enddo
11266 C      print *,'AFM',Eafmforce
11267       return
11268       end
11269 C---------------------------------------------------------
11270 C AFM subroutine with pseudoconstant velocity
11271        subroutine AFMvel(Eafmforce)
11272        implicit real*8 (a-h,o-z)
11273       include 'DIMENSIONS'
11274       include 'COMMON.GEO'
11275       include 'COMMON.VAR'
11276       include 'COMMON.LOCAL'
11277       include 'COMMON.CHAIN'
11278       include 'COMMON.DERIV'
11279       include 'COMMON.NAMES'
11280       include 'COMMON.INTERACT'
11281       include 'COMMON.IOUNITS'
11282       include 'COMMON.CALC'
11283       include 'COMMON.CONTROL'
11284       include 'COMMON.SPLITELE'
11285       include 'COMMON.SBRIDGE'
11286       real*8 diffafm(3)
11287 C Only for check grad COMMENT if not used for checkgrad
11288 C      totT=3.0d0
11289 C--------------------------------------------------------
11290 C      print *,"wchodze"
11291       dist=0.0d0
11292       Eafmforce=0.0d0
11293       do i=1,3
11294       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11295       dist=dist+diffafm(i)**2
11296       enddo
11297       dist=dsqrt(dist)
11298       Eafmforce=0.5d0*forceAFMconst
11299      & *(distafminit+totTafm*velAFMconst-dist)**2
11300 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11301       do i=1,3
11302       gradafm(i,afmend-1)=-forceAFMconst*
11303      &(distafminit+totTafm*velAFMconst-dist)
11304      &*diffafm(i)/dist
11305       gradafm(i,afmbeg-1)=forceAFMconst*
11306      &(distafminit+totTafm*velAFMconst-dist)
11307      &*diffafm(i)/dist
11308       enddo
11309 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11310       return
11311       end
11312 C-----------------------------------------------------------
11313 C first for shielding is setting of function of side-chains
11314        subroutine set_shield_fac
11315       implicit real*8 (a-h,o-z)
11316       include 'DIMENSIONS'
11317       include 'COMMON.CHAIN'
11318       include 'COMMON.DERIV'
11319       include 'COMMON.IOUNITS'
11320       include 'COMMON.SHIELD'
11321       include 'COMMON.INTERACT'
11322 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11323       double precision div77_81/0.974996043d0/,
11324      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11325
11326 C the vector between center of side_chain and peptide group
11327        double precision pep_side(3),long,side_calf(3),
11328      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11329      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11330 C the line belowe needs to be changed for FGPROC>1
11331       do i=1,nres-1
11332       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11333       ishield_list(i)=0
11334 Cif there two consequtive dummy atoms there is no peptide group between them
11335 C the line below has to be changed for FGPROC>1
11336       VolumeTotal=0.0
11337       do k=1,nres
11338        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11339        dist_pep_side=0.0
11340        dist_side_calf=0.0
11341        do j=1,3
11342 C first lets set vector conecting the ithe side-chain with kth side-chain
11343       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11344 C      pep_side(j)=2.0d0
11345 C and vector conecting the side-chain with its proper calfa
11346       side_calf(j)=c(j,k+nres)-c(j,k)
11347 C      side_calf(j)=2.0d0
11348       pept_group(j)=c(j,i)-c(j,i+1)
11349 C lets have their lenght
11350       dist_pep_side=pep_side(j)**2+dist_pep_side
11351       dist_side_calf=dist_side_calf+side_calf(j)**2
11352       dist_pept_group=dist_pept_group+pept_group(j)**2
11353       enddo
11354        dist_pep_side=dsqrt(dist_pep_side)
11355        dist_pept_group=dsqrt(dist_pept_group)
11356        dist_side_calf=dsqrt(dist_side_calf)
11357       do j=1,3
11358         pep_side_norm(j)=pep_side(j)/dist_pep_side
11359         side_calf_norm(j)=dist_side_calf
11360       enddo
11361 C now sscale fraction
11362        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11363 C       print *,buff_shield,"buff"
11364 C now sscale
11365         if (sh_frac_dist.le.0.0) cycle
11366 C If we reach here it means that this side chain reaches the shielding sphere
11367 C Lets add him to the list for gradient
11368         ishield_list(i)=ishield_list(i)+1
11369 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11370 C this list is essential otherwise problem would be O3
11371         shield_list(ishield_list(i),i)=k
11372 C Lets have the sscale value
11373         if (sh_frac_dist.gt.1.0) then
11374          scale_fac_dist=1.0d0
11375          do j=1,3
11376          sh_frac_dist_grad(j)=0.0d0
11377          enddo
11378         else
11379          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11380      &                   *(2.0*sh_frac_dist-3.0d0)
11381          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11382      &                  /dist_pep_side/buff_shield*0.5
11383 C remember for the final gradient multiply sh_frac_dist_grad(j)
11384 C for side_chain by factor -2 !
11385          do j=1,3
11386          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11387 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11388 C     &                    sh_frac_dist_grad(j)
11389          enddo
11390         endif
11391 C        if ((i.eq.3).and.(k.eq.2)) then
11392 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11393 C     & ,"TU"
11394 C        endif
11395
11396 C this is what is now we have the distance scaling now volume...
11397       short=short_r_sidechain(itype(k))
11398       long=long_r_sidechain(itype(k))
11399       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11400 C now costhet_grad
11401 C       costhet=0.0d0
11402        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11403 C       costhet_fac=0.0d0
11404        do j=1,3
11405          costhet_grad(j)=costhet_fac*pep_side(j)
11406        enddo
11407 C remember for the final gradient multiply costhet_grad(j)
11408 C for side_chain by factor -2 !
11409 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11410 C pep_side0pept_group is vector multiplication
11411       pep_side0pept_group=0.0
11412       do j=1,3
11413       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11414       enddo
11415       cosalfa=(pep_side0pept_group/
11416      & (dist_pep_side*dist_side_calf))
11417       fac_alfa_sin=1.0-cosalfa**2
11418       fac_alfa_sin=dsqrt(fac_alfa_sin)
11419       rkprim=fac_alfa_sin*(long-short)+short
11420 C now costhet_grad
11421        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11422        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11423
11424        do j=1,3
11425          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11426      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11427      &*(long-short)/fac_alfa_sin*cosalfa/
11428      &((dist_pep_side*dist_side_calf))*
11429      &((side_calf(j))-cosalfa*
11430      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11431
11432         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11433      &*(long-short)/fac_alfa_sin*cosalfa
11434      &/((dist_pep_side*dist_side_calf))*
11435      &(pep_side(j)-
11436      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11437        enddo
11438
11439       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11440      &                    /VSolvSphere_div
11441      &                    *wshield
11442 C now the gradient...
11443 C grad_shield is gradient of Calfa for peptide groups
11444 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11445 C     &               costhet,cosphi
11446 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11447 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11448       do j=1,3
11449       grad_shield(j,i)=grad_shield(j,i)
11450 C gradient po skalowaniu
11451      &                +(sh_frac_dist_grad(j)
11452 C  gradient po costhet
11453      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11454      &-scale_fac_dist*(cosphi_grad_long(j))
11455      &/(1.0-cosphi) )*div77_81
11456      &*VofOverlap
11457 C grad_shield_side is Cbeta sidechain gradient
11458       grad_shield_side(j,ishield_list(i),i)=
11459      &        (sh_frac_dist_grad(j)*-2.0d0
11460      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11461      &       +scale_fac_dist*(cosphi_grad_long(j))
11462      &        *2.0d0/(1.0-cosphi))
11463      &        *div77_81*VofOverlap
11464
11465        grad_shield_loc(j,ishield_list(i),i)=
11466      &   scale_fac_dist*cosphi_grad_loc(j)
11467      &        *2.0d0/(1.0-cosphi)
11468      &        *div77_81*VofOverlap
11469       enddo
11470       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11471       enddo
11472       fac_shield(i)=VolumeTotal*div77_81+div4_81
11473 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11474       enddo
11475       return
11476       end
11477 C--------------------------------------------------------------------------
11478       double precision function tschebyshev(m,n,x,y)
11479       implicit none
11480       include "DIMENSIONS"
11481       integer i,m,n
11482       double precision x(n),y,yy(0:maxvar),aux
11483 c Tschebyshev polynomial. Note that the first term is omitted
11484 c m=0: the constant term is included
11485 c m=1: the constant term is not included
11486       yy(0)=1.0d0
11487       yy(1)=y
11488       do i=2,n
11489         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11490       enddo
11491       aux=0.0d0
11492       do i=m,n
11493         aux=aux+x(i)*yy(i)
11494       enddo
11495       tschebyshev=aux
11496       return
11497       end
11498 C--------------------------------------------------------------------------
11499       double precision function gradtschebyshev(m,n,x,y)
11500       implicit none
11501       include "DIMENSIONS"
11502       integer i,m,n
11503       double precision x(n+1),y,yy(0:maxvar),aux
11504 c Tschebyshev polynomial. Note that the first term is omitted
11505 c m=0: the constant term is included
11506 c m=1: the constant term is not included
11507       yy(0)=1.0d0
11508       yy(1)=2.0d0*y
11509       do i=2,n
11510         yy(i)=2*y*yy(i-1)-yy(i-2)
11511       enddo
11512       aux=0.0d0
11513       do i=m,n
11514         aux=aux+x(i+1)*yy(i)*(i+1)
11515 C        print *, x(i+1),yy(i),i
11516       enddo
11517       gradtschebyshev=aux
11518       return
11519       end
11520 C------------------------------------------------------------------------
11521 C first for shielding is setting of function of side-chains
11522        subroutine set_shield_fac2
11523       implicit real*8 (a-h,o-z)
11524       include 'DIMENSIONS'
11525       include 'COMMON.CHAIN'
11526       include 'COMMON.DERIV'
11527       include 'COMMON.IOUNITS'
11528       include 'COMMON.SHIELD'
11529       include 'COMMON.INTERACT'
11530 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11531       double precision div77_81/0.974996043d0/,
11532      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11533
11534 C the vector between center of side_chain and peptide group
11535        double precision pep_side(3),long,side_calf(3),
11536      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11537      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11538 C the line belowe needs to be changed for FGPROC>1
11539       do i=1,nres-1
11540       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11541       ishield_list(i)=0
11542 Cif there two consequtive dummy atoms there is no peptide group between them
11543 C the line below has to be changed for FGPROC>1
11544       VolumeTotal=0.0
11545       do k=1,nres
11546        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11547        dist_pep_side=0.0
11548        dist_side_calf=0.0
11549        do j=1,3
11550 C first lets set vector conecting the ithe side-chain with kth side-chain
11551       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11552 C      pep_side(j)=2.0d0
11553 C and vector conecting the side-chain with its proper calfa
11554       side_calf(j)=c(j,k+nres)-c(j,k)
11555 C      side_calf(j)=2.0d0
11556       pept_group(j)=c(j,i)-c(j,i+1)
11557 C lets have their lenght
11558       dist_pep_side=pep_side(j)**2+dist_pep_side
11559       dist_side_calf=dist_side_calf+side_calf(j)**2
11560       dist_pept_group=dist_pept_group+pept_group(j)**2
11561       enddo
11562        dist_pep_side=dsqrt(dist_pep_side)
11563        dist_pept_group=dsqrt(dist_pept_group)
11564        dist_side_calf=dsqrt(dist_side_calf)
11565       do j=1,3
11566         pep_side_norm(j)=pep_side(j)/dist_pep_side
11567         side_calf_norm(j)=dist_side_calf
11568       enddo
11569 C now sscale fraction
11570        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11571 C       print *,buff_shield,"buff"
11572 C now sscale
11573         if (sh_frac_dist.le.0.0) cycle
11574 C If we reach here it means that this side chain reaches the shielding sphere
11575 C Lets add him to the list for gradient
11576         ishield_list(i)=ishield_list(i)+1
11577 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11578 C this list is essential otherwise problem would be O3
11579         shield_list(ishield_list(i),i)=k
11580 C Lets have the sscale value
11581         if (sh_frac_dist.gt.1.0) then
11582          scale_fac_dist=1.0d0
11583          do j=1,3
11584          sh_frac_dist_grad(j)=0.0d0
11585          enddo
11586         else
11587          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11588      &                   *(2.0d0*sh_frac_dist-3.0d0)
11589          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11590      &                  /dist_pep_side/buff_shield*0.5d0
11591 C remember for the final gradient multiply sh_frac_dist_grad(j)
11592 C for side_chain by factor -2 !
11593          do j=1,3
11594          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11595 C         sh_frac_dist_grad(j)=0.0d0
11596 C         scale_fac_dist=1.0d0
11597 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11598 C     &                    sh_frac_dist_grad(j)
11599          enddo
11600         endif
11601 C this is what is now we have the distance scaling now volume...
11602       short=short_r_sidechain(itype(k))
11603       long=long_r_sidechain(itype(k))
11604       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11605       sinthet=short/dist_pep_side*costhet
11606 C now costhet_grad
11607 C       costhet=0.6d0
11608 C       sinthet=0.8
11609        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11610 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11611 C     &             -short/dist_pep_side**2/costhet)
11612 C       costhet_fac=0.0d0
11613        do j=1,3
11614          costhet_grad(j)=costhet_fac*pep_side(j)
11615        enddo
11616 C remember for the final gradient multiply costhet_grad(j)
11617 C for side_chain by factor -2 !
11618 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11619 C pep_side0pept_group is vector multiplication
11620       pep_side0pept_group=0.0d0
11621       do j=1,3
11622       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11623       enddo
11624       cosalfa=(pep_side0pept_group/
11625      & (dist_pep_side*dist_side_calf))
11626       fac_alfa_sin=1.0d0-cosalfa**2
11627       fac_alfa_sin=dsqrt(fac_alfa_sin)
11628       rkprim=fac_alfa_sin*(long-short)+short
11629 C      rkprim=short
11630
11631 C now costhet_grad
11632        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11633 C       cosphi=0.6
11634        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11635        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11636      &      dist_pep_side**2)
11637 C       sinphi=0.8
11638        do j=1,3
11639          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11640      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11641      &*(long-short)/fac_alfa_sin*cosalfa/
11642      &((dist_pep_side*dist_side_calf))*
11643      &((side_calf(j))-cosalfa*
11644      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11645 C       cosphi_grad_long(j)=0.0d0
11646         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11647      &*(long-short)/fac_alfa_sin*cosalfa
11648      &/((dist_pep_side*dist_side_calf))*
11649      &(pep_side(j)-
11650      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11651 C       cosphi_grad_loc(j)=0.0d0
11652        enddo
11653 C      print *,sinphi,sinthet
11654       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11655      &                    /VSolvSphere_div
11656 C     &                    *wshield
11657 C now the gradient...
11658       do j=1,3
11659       grad_shield(j,i)=grad_shield(j,i)
11660 C gradient po skalowaniu
11661      &                +(sh_frac_dist_grad(j)*VofOverlap
11662 C  gradient po costhet
11663      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11664      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11665      &       sinphi/sinthet*costhet*costhet_grad(j)
11666      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11667      & )*wshield
11668 C grad_shield_side is Cbeta sidechain gradient
11669       grad_shield_side(j,ishield_list(i),i)=
11670      &        (sh_frac_dist_grad(j)*-2.0d0
11671      &        *VofOverlap
11672      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11673      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11674      &       sinphi/sinthet*costhet*costhet_grad(j)
11675      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11676      &       )*wshield
11677
11678        grad_shield_loc(j,ishield_list(i),i)=
11679      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11680      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11681      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11682      &        ))
11683      &        *wshield
11684       enddo
11685       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11686       enddo
11687       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11688 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11689       enddo
11690       return
11691       end
11692 C-----------------------------------------------------------------------
11693 C-----------------------------------------------------------
11694 C This subroutine is to mimic the histone like structure but as well can be
11695 C utilizet to nanostructures (infinit) small modification has to be used to
11696 C make it finite (z gradient at the ends has to be changes as well as the x,y
11697 C gradient has to be modified at the ends
11698 C The energy function is Kihara potential
11699 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11700 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11701 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11702 C simple Kihara potential
11703       subroutine calctube(Etube)
11704        implicit real*8 (a-h,o-z)
11705       include 'DIMENSIONS'
11706       include 'COMMON.GEO'
11707       include 'COMMON.VAR'
11708       include 'COMMON.LOCAL'
11709       include 'COMMON.CHAIN'
11710       include 'COMMON.DERIV'
11711       include 'COMMON.NAMES'
11712       include 'COMMON.INTERACT'
11713       include 'COMMON.IOUNITS'
11714       include 'COMMON.CALC'
11715       include 'COMMON.CONTROL'
11716       include 'COMMON.SPLITELE'
11717       include 'COMMON.SBRIDGE'
11718       double precision tub_r,vectube(3),enetube(maxres*2)
11719       Etube=0.0d0
11720       do i=1,2*nres
11721         enetube(i)=0.0d0
11722       enddo
11723 C first we calculate the distance from tube center
11724 C first sugare-phosphate group for NARES this would be peptide group
11725 C for UNRES
11726       do i=1,nres
11727 C lets ommit dummy atoms for now
11728        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11729 C now calculate distance from center of tube and direction vectors
11730       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11731           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11732       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11733           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11734       vectube(1)=vectube(1)-tubecenter(1)
11735       vectube(2)=vectube(2)-tubecenter(2)
11736
11737 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11738 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11739
11740 C as the tube is infinity we do not calculate the Z-vector use of Z
11741 C as chosen axis
11742       vectube(3)=0.0d0
11743 C now calculte the distance
11744        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11745 C now normalize vector
11746       vectube(1)=vectube(1)/tub_r
11747       vectube(2)=vectube(2)/tub_r
11748 C calculte rdiffrence between r and r0
11749       rdiff=tub_r-tubeR0
11750 C and its 6 power
11751       rdiff6=rdiff**6.0d0
11752 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11753        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11754 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11755 C       print *,rdiff,rdiff6,pep_aa_tube
11756 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11757 C now we calculate gradient
11758        fac=(-12.0d0*pep_aa_tube/rdiff6+
11759      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11760 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11761 C     &rdiff,fac
11762
11763 C now direction of gg_tube vector
11764         do j=1,3
11765         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11766         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11767         enddo
11768         enddo
11769 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11770         do i=1,nres
11771 C Lets not jump over memory as we use many times iti
11772          iti=itype(i)
11773 C lets ommit dummy atoms for now
11774          if ((iti.eq.ntyp1)
11775 C in UNRES uncomment the line below as GLY has no side-chain...
11776 C      .or.(iti.eq.10)
11777      &   ) cycle
11778           vectube(1)=c(1,i+nres)
11779           vectube(1)=mod(vectube(1),boxxsize)
11780           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11781           vectube(2)=c(2,i+nres)
11782           vectube(2)=mod(vectube(2),boxxsize)
11783           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11784
11785       vectube(1)=vectube(1)-tubecenter(1)
11786       vectube(2)=vectube(2)-tubecenter(2)
11787
11788 C as the tube is infinity we do not calculate the Z-vector use of Z
11789 C as chosen axis
11790       vectube(3)=0.0d0
11791 C now calculte the distance
11792        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11793 C now normalize vector
11794       vectube(1)=vectube(1)/tub_r
11795       vectube(2)=vectube(2)/tub_r
11796 C calculte rdiffrence between r and r0
11797       rdiff=tub_r-tubeR0
11798 C and its 6 power
11799       rdiff6=rdiff**6.0d0
11800 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11801        sc_aa_tube=sc_aa_tube_par(iti)
11802        sc_bb_tube=sc_bb_tube_par(iti)
11803        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11804 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11805 C now we calculate gradient
11806        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11807      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11808 C now direction of gg_tube vector
11809          do j=1,3
11810           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11811           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11812          enddo
11813         enddo
11814         do i=1,2*nres
11815           Etube=Etube+enetube(i)
11816         enddo
11817 C        print *,"ETUBE", etube
11818         return
11819         end
11820 C TO DO 1) add to total energy
11821 C       2) add to gradient summation
11822 C       3) add reading parameters (AND of course oppening of PARAM file)
11823 C       4) add reading the center of tube
11824 C       5) add COMMONs
11825 C       6) add to zerograd
11826
11827 C-----------------------------------------------------------------------
11828 C-----------------------------------------------------------
11829 C This subroutine is to mimic the histone like structure but as well can be
11830 C utilizet to nanostructures (infinit) small modification has to be used to
11831 C make it finite (z gradient at the ends has to be changes as well as the x,y
11832 C gradient has to be modified at the ends
11833 C The energy function is Kihara potential
11834 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11835 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11836 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11837 C simple Kihara potential
11838       subroutine calctube2(Etube)
11839        implicit real*8 (a-h,o-z)
11840       include 'DIMENSIONS'
11841       include 'COMMON.GEO'
11842       include 'COMMON.VAR'
11843       include 'COMMON.LOCAL'
11844       include 'COMMON.CHAIN'
11845       include 'COMMON.DERIV'
11846       include 'COMMON.NAMES'
11847       include 'COMMON.INTERACT'
11848       include 'COMMON.IOUNITS'
11849       include 'COMMON.CALC'
11850       include 'COMMON.CONTROL'
11851       include 'COMMON.SPLITELE'
11852       include 'COMMON.SBRIDGE'
11853       double precision tub_r,vectube(3),enetube(maxres*2)
11854       Etube=0.0d0
11855       do i=1,2*nres
11856         enetube(i)=0.0d0
11857       enddo
11858 C first we calculate the distance from tube center
11859 C first sugare-phosphate group for NARES this would be peptide group
11860 C for UNRES
11861       do i=1,nres
11862 C lets ommit dummy atoms for now
11863        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11864 C now calculate distance from center of tube and direction vectors
11865       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11866           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11867       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11868           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11869       vectube(1)=vectube(1)-tubecenter(1)
11870       vectube(2)=vectube(2)-tubecenter(2)
11871
11872 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11873 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11874
11875 C as the tube is infinity we do not calculate the Z-vector use of Z
11876 C as chosen axis
11877       vectube(3)=0.0d0
11878 C now calculte the distance
11879        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11880 C now normalize vector
11881       vectube(1)=vectube(1)/tub_r
11882       vectube(2)=vectube(2)/tub_r
11883 C calculte rdiffrence between r and r0
11884       rdiff=tub_r-tubeR0
11885 C and its 6 power
11886       rdiff6=rdiff**6.0d0
11887 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11888        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11889 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11890 C       print *,rdiff,rdiff6,pep_aa_tube
11891 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11892 C now we calculate gradient
11893        fac=(-12.0d0*pep_aa_tube/rdiff6+
11894      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11895 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11896 C     &rdiff,fac
11897
11898 C now direction of gg_tube vector
11899         do j=1,3
11900         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11901         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11902         enddo
11903         enddo
11904 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11905         do i=1,nres
11906 C Lets not jump over memory as we use many times iti
11907          iti=itype(i)
11908 C lets ommit dummy atoms for now
11909          if ((iti.eq.ntyp1)
11910 C in UNRES uncomment the line below as GLY has no side-chain...
11911      &      .or.(iti.eq.10)
11912      &   ) cycle
11913           vectube(1)=c(1,i+nres)
11914           vectube(1)=mod(vectube(1),boxxsize)
11915           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11916           vectube(2)=c(2,i+nres)
11917           vectube(2)=mod(vectube(2),boxxsize)
11918           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11919
11920       vectube(1)=vectube(1)-tubecenter(1)
11921       vectube(2)=vectube(2)-tubecenter(2)
11922 C THIS FRAGMENT MAKES TUBE FINITE
11923         positi=(mod(c(3,i+nres),boxzsize))
11924         if (positi.le.0) positi=positi+boxzsize
11925 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11926 c for each residue check if it is in lipid or lipid water border area
11927 C       respos=mod(c(3,i+nres),boxzsize)
11928        print *,positi,bordtubebot,buftubebot,bordtubetop
11929        if ((positi.gt.bordtubebot)
11930      & .and.(positi.lt.bordtubetop)) then
11931 C the energy transfer exist
11932         if (positi.lt.buftubebot) then
11933          fracinbuf=1.0d0-
11934      &     ((positi-bordtubebot)/tubebufthick)
11935 C lipbufthick is thickenes of lipid buffore
11936          sstube=sscalelip(fracinbuf)
11937          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
11938          print *,ssgradtube, sstube,tubetranene(itype(i))
11939          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
11940          gg_tube_SC(3,i)=gg_tube_SC(3,i)
11941      &+ssgradtube*tubetranene(itype(i))
11942          gg_tube(3,i-1)= gg_tube(3,i-1)
11943      &+ssgradtube*tubetranene(itype(i))
11944 C         print *,"doing sccale for lower part"
11945         elseif (positi.gt.buftubetop) then
11946          fracinbuf=1.0d0-
11947      &((bordtubetop-positi)/tubebufthick)
11948          sstube=sscalelip(fracinbuf)
11949          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
11950          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
11951 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
11952 C     &+ssgradtube*tubetranene(itype(i))
11953 C         gg_tube(3,i-1)= gg_tube(3,i-1)
11954 C     &+ssgradtube*tubetranene(itype(i))
11955 C          print *, "doing sscalefor top part",sslip,fracinbuf
11956         else
11957          sstube=1.0d0
11958          ssgradtube=0.0d0
11959          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
11960 C         print *,"I am in true lipid"
11961         endif
11962         else
11963 C          sstube=0.0d0
11964 C          ssgradtube=0.0d0
11965         cycle
11966         endif ! if in lipid or buffor
11967 CEND OF FINITE FRAGMENT
11968 C as the tube is infinity we do not calculate the Z-vector use of Z
11969 C as chosen axis
11970       vectube(3)=0.0d0
11971 C now calculte the distance
11972        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11973 C now normalize vector
11974       vectube(1)=vectube(1)/tub_r
11975       vectube(2)=vectube(2)/tub_r
11976 C calculte rdiffrence between r and r0
11977       rdiff=tub_r-tubeR0
11978 C and its 6 power
11979       rdiff6=rdiff**6.0d0
11980 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11981        sc_aa_tube=sc_aa_tube_par(iti)
11982        sc_bb_tube=sc_bb_tube_par(iti)
11983        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
11984      &                 *sstube+enetube(i+nres)
11985 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11986 C now we calculate gradient
11987        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11988      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
11989 C now direction of gg_tube vector
11990          do j=1,3
11991           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11992           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11993          enddo
11994          gg_tube_SC(3,i)=gg_tube_SC(3,i)
11995      &+ssgradtube*enetube(i+nres)/sstube
11996          gg_tube(3,i-1)= gg_tube(3,i-1)
11997      &+ssgradtube*enetube(i+nres)/sstube
11998
11999         enddo
12000         do i=1,2*nres
12001           Etube=Etube+enetube(i)
12002         enddo
12003 C        print *,"ETUBE", etube
12004         return
12005         end
12006 C TO DO 1) add to total energy
12007 C       2) add to gradient summation
12008 C       3) add reading parameters (AND of course oppening of PARAM file)
12009 C       4) add reading the center of tube
12010 C       5) add COMMONs
12011 C       6) add to zerograd
12012