source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.gt.0) then
 146        call set_shield_fac
 147       endif
 148 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 149       if (ipot.lt.6) then
 150 #ifdef SPLITELE
 151          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 152      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 153      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 154      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 155 #else
 156          if (welec.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 #endif
 161             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 162          else
 163             ees=0.0d0
 164             evdw1=0.0d0
 165             eel_loc=0.0d0
 166             eello_turn3=0.0d0
 167             eello_turn4=0.0d0
 168          endif
 169       else
 170         write (iout,*) "Soft-spheer ELEC potential"
 171 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 172 c     &   eello_turn4)
 173       endif
 174 c      print *,"Processor",myrank," computed UELEC"
 175 C
 176 C Calculate excluded-volume interaction energy between peptide groups
 177 C and side chains.
 178 C
 179       if (ipot.lt.6) then
 180        if(wscp.gt.0d0) then
 181         call escp(evdw2,evdw2_14)
 182        else
 183         evdw2=0
 184         evdw2_14=0
 185        endif
 186       else
 187 c        write (iout,*) "Soft-sphere SCP potential"
 188         call escp_soft_sphere(evdw2,evdw2_14)
 189       endif
 190 c
 191 c Calculate the bond-stretching energy
 192 c
 193       call ebond(estr)
 194 C
 195 C Calculate the disulfide-bridge and other energy and the contributions
 196 C from other distance constraints.
 197 cd    print *,'Calling EHPB'
 198       call edis(ehpb)
 199 cd    print *,'EHPB exitted succesfully.'
 200 C
 201 C Calculate the virtual-bond-angle energy.
 202 C
 203       if (wang.gt.0d0) then
 204        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 205         call ebend(ebe,ethetacnstr)
 206         endif
 207 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 208 C energy function
 209        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 210          call ebend_kcc(ebe,ethetacnstr)
 211         endif
 212       else
 213         ebe=0
 214         ethetacnstr=0
 215       endif
 216 c      print *,"Processor",myrank," computed UB"
 217 C
 218 C Calculate the SC local energy.
 219 C
 220 C      print *,"TU DOCHODZE?"
 221       call esc(escloc)
 222 c      print *,"Processor",myrank," computed USC"
 223 C
 224 C Calculate the virtual-bond torsional energy.
 225 C
 226 cd    print *,'nterm=',nterm
 227 C      print *,"tor",tor_mode
 228       if (wtor.gt.0) then
 229        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 230        call etor(etors,edihcnstr)
 231        endif
 232 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 233 C energy function
 234        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 235        call etor_kcc(etors,edihcnstr)
 236        endif
 237       else
 238        etors=0
 239        edihcnstr=0
 240       endif
 241 c      print *,"Processor",myrank," computed Utor"
 242 C
 243 C 6/23/01 Calculate double-torsional energy
 244 C
 245       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 246        call etor_d(etors_d)
 247       else
 248        etors_d=0
 249       endif
 250 c      print *,"Processor",myrank," computed Utord"
 251 C
 252 C 21/5/07 Calculate local sicdechain correlation energy
 253 C
 254       if (wsccor.gt.0.0d0) then
 255         call eback_sc_corr(esccor)
 256       else
 257         esccor=0.0d0
 258       endif
 259 C      print *,"PRZED MULIt"
 260 c      print *,"Processor",myrank," computed Usccorr"
 261 C
 262 C 12/1/95 Multi-body terms
 263 C
 264       n_corr=0
 265       n_corr1=0
 266       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 267      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 268          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 269 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 270 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 271       else
 272          ecorr=0.0d0
 273          ecorr5=0.0d0
 274          ecorr6=0.0d0
 275          eturn6=0.0d0
 276       endif
 277       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 278          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 279 cd         write (iout,*) "multibody_hb ecorr",ecorr
 280       endif
 281 c      print *,"Processor",myrank," computed Ucorr"
 282 C
 283 C If performing constraint dynamics, call the constraint energy
 284 C  after the equilibration time
 285       if(usampl.and.totT.gt.eq_time) then
 286          call EconstrQ
 287          call Econstr_back
 288       else
 289          Uconst=0.0d0
 290          Uconst_back=0.0d0
 291       endif
 292 C 01/27/2015 added by adasko
 293 C the energy component below is energy transfer into lipid environment
 294 C based on partition function
 295 C      print *,"przed lipidami"
 296       if (wliptran.gt.0) then
 297         call Eliptransfer(eliptran)
 298       endif
 299 C      print *,"za lipidami"
 300       if (AFMlog.gt.0) then
 301         call AFMforce(Eafmforce)
 302       else if (selfguide.gt.0) then
 303         call AFMvel(Eafmforce)
 304       endif
 305 #ifdef TIMING
 306       time_enecalc=time_enecalc+MPI_Wtime()-time00
 307 #endif
 308 c      print *,"Processor",myrank," computed Uconstr"
 309 #ifdef TIMING
 310       time00=MPI_Wtime()
 311 #endif
 312 c
 313 C Sum the energies
 314 C
 315       energia(1)=evdw
 316 #ifdef SCP14
 317       energia(2)=evdw2-evdw2_14
 318       energia(18)=evdw2_14
 319 #else
 320       energia(2)=evdw2
 321       energia(18)=0.0d0
 322 #endif
 323 #ifdef SPLITELE
 324       energia(3)=ees
 325       energia(16)=evdw1
 326 #else
 327       energia(3)=ees+evdw1
 328       energia(16)=0.0d0
 329 #endif
 330       energia(4)=ecorr
 331       energia(5)=ecorr5
 332       energia(6)=ecorr6
 333       energia(7)=eel_loc
 334       energia(8)=eello_turn3
 335       energia(9)=eello_turn4
 336       energia(10)=eturn6
 337       energia(11)=ebe
 338       energia(12)=escloc
 339       energia(13)=etors
 340       energia(14)=etors_d
 341       energia(15)=ehpb
 342       energia(19)=edihcnstr
 343       energia(17)=estr
 344       energia(20)=Uconst+Uconst_back
 345       energia(21)=esccor
 346       energia(22)=eliptran
 347       energia(23)=Eafmforce
 348       energia(24)=ethetacnstr
 349 c    Here are the energies showed per procesor if the are more processors
 350 c    per molecule then we sum it up in sum_energy subroutine
 351 c      print *," Processor",myrank," calls SUM_ENERGY"
 352       call sum_energy(energia,.true.)
 353       if (dyn_ss) call dyn_set_nss
 354 c      print *," Processor",myrank," left SUM_ENERGY"
 355 #ifdef TIMING
 356       time_sumene=time_sumene+MPI_Wtime()-time00
 357 #endif
 358       return
 359       end
 360 c-------------------------------------------------------------------------------
 361       subroutine sum_energy(energia,reduce)
 362       implicit real*8 (a-h,o-z)
 363       include 'DIMENSIONS'
 364 #ifndef ISNAN
 365       external proc_proc
 366 #ifdef WINPGI
 367 cMS$ATTRIBUTES C ::  proc_proc
 368 #endif
 369 #endif
 370 #ifdef MPI
 371       include "mpif.h"
 372 #endif
 373       include 'COMMON.SETUP'
 374       include 'COMMON.IOUNITS'
 375       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 376       include 'COMMON.FFIELD'
 377       include 'COMMON.DERIV'
 378       include 'COMMON.INTERACT'
 379       include 'COMMON.SBRIDGE'
 380       include 'COMMON.CHAIN'
 381       include 'COMMON.VAR'
 382       include 'COMMON.CONTROL'
 383       include 'COMMON.TIME1'
 384       logical reduce
 385 #ifdef MPI
 386       if (nfgtasks.gt.1 .and. reduce) then
 387 #ifdef DEBUG
 388         write (iout,*) "energies before REDUCE"
 389         call enerprint(energia)
 390         call flush(iout)
 391 #endif
 392         do i=0,n_ene
 393           enebuff(i)=energia(i)
 394         enddo
 395         time00=MPI_Wtime()
 396         call MPI_Barrier(FG_COMM,IERR)
 397         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 398         time00=MPI_Wtime()
 399         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 400      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 401 #ifdef DEBUG
 402         write (iout,*) "energies after REDUCE"
 403         call enerprint(energia)
 404         call flush(iout)
 405 #endif
 406         time_Reduce=time_Reduce+MPI_Wtime()-time00
 407       endif
 408       if (fg_rank.eq.0) then
 409 #endif
 410       evdw=energia(1)
 411 #ifdef SCP14
 412       evdw2=energia(2)+energia(18)
 413       evdw2_14=energia(18)
 414 #else
 415       evdw2=energia(2)
 416 #endif
 417 #ifdef SPLITELE
 418       ees=energia(3)
 419       evdw1=energia(16)
 420 #else
 421       ees=energia(3)
 422       evdw1=0.0d0
 423 #endif
 424       ecorr=energia(4)
 425       ecorr5=energia(5)
 426       ecorr6=energia(6)
 427       eel_loc=energia(7)
 428       eello_turn3=energia(8)
 429       eello_turn4=energia(9)
 430       eturn6=energia(10)
 431       ebe=energia(11)
 432       escloc=energia(12)
 433       etors=energia(13)
 434       etors_d=energia(14)
 435       ehpb=energia(15)
 436       edihcnstr=energia(19)
 437       estr=energia(17)
 438       Uconst=energia(20)
 439       esccor=energia(21)
 440       eliptran=energia(22)
 441       Eafmforce=energia(23)
 442       ethetacnstr=energia(24)
 443 #ifdef SPLITELE
 444       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 445      & +wang*ebe+wtor*etors+wscloc*escloc
 446      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 447      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 448      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 449      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 450      & +ethetacnstr
 451 #else
 452       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 453      & +wang*ebe+wtor*etors+wscloc*escloc
 454      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 455      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 456      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 457      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 458      & +Eafmforce
 459      & +ethetacnstr
 460 #endif
 461       energia(0)=etot
 462 c detecting NaNQ
 463 #ifdef ISNAN
 464 #ifdef AIX
 465       if (isnan(etot).ne.0) energia(0)=1.0d+99
 466 #else
 467       if (isnan(etot)) energia(0)=1.0d+99
 468 #endif
 469 #else
 470       i=0
 471 #ifdef WINPGI
 472       idumm=proc_proc(etot,i)
 473 #else
 474       call proc_proc(etot,i)
 475 #endif
 476       if(i.eq.1)energia(0)=1.0d+99
 477 #endif
 478 #ifdef MPI
 479       endif
 480 #endif
 481       return
 482       end
 483 c-------------------------------------------------------------------------------
 484       subroutine sum_gradient
 485       implicit real*8 (a-h,o-z)
 486       include 'DIMENSIONS'
 487 #ifndef ISNAN
 488       external proc_proc
 489 #ifdef WINPGI
 490 cMS$ATTRIBUTES C ::  proc_proc
 491 #endif
 492 #endif
 493 #ifdef MPI
 494       include 'mpif.h'
 495 #endif
 496       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 497      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 498      & ,gloc_scbuf(3,-1:maxres)
 499       include 'COMMON.SETUP'
 500       include 'COMMON.IOUNITS'
 501       include 'COMMON.FFIELD'
 502       include 'COMMON.DERIV'
 503       include 'COMMON.INTERACT'
 504       include 'COMMON.SBRIDGE'
 505       include 'COMMON.CHAIN'
 506       include 'COMMON.VAR'
 507       include 'COMMON.CONTROL'
 508       include 'COMMON.TIME1'
 509       include 'COMMON.MAXGRAD'
 510       include 'COMMON.SCCOR'
 511 #ifdef TIMING
 512       time01=MPI_Wtime()
 513 #endif
 514 #ifdef DEBUG
 515       write (iout,*) "sum_gradient gvdwc, gvdwx"
 516       do i=1,nres
 517         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 518      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 519       enddo
 520       call flush(iout)
 521 #endif
 522 #ifdef MPI
 523 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 524         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 525      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 526 #endif
 527 C
 528 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 529 C            in virtual-bond-vector coordinates
 530 C
 531 #ifdef DEBUG
 532 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 533 c      do i=1,nres-1
 534 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 535 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 536 c      enddo
 537 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 538 c      do i=1,nres-1
 539 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 540 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 541 c      enddo
 542       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 543       do i=1,nres
 544         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 545      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 546      &   g_corr5_loc(i)
 547       enddo
 548       call flush(iout)
 549 #endif
 550 #ifdef SPLITELE
 551       do i=0,nct
 552         do j=1,3
 553           gradbufc(j,i)=wsc*gvdwc(j,i)+
 554      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 555      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 556      &                wel_loc*gel_loc_long(j,i)+
 557      &                wcorr*gradcorr_long(j,i)+
 558      &                wcorr5*gradcorr5_long(j,i)+
 559      &                wcorr6*gradcorr6_long(j,i)+
 560      &                wturn6*gcorr6_turn_long(j,i)+
 561      &                wstrain*ghpbc(j,i)
 562      &                +wliptran*gliptranc(j,i)
 563      &                +gradafm(j,i)
 564      &                 +welec*gshieldc(j,i)
 565      &                 +wcorr*gshieldc_ec(j,i)
 566      &                 +wturn3*gshieldc_t3(j,i)
 567      &                 +wturn4*gshieldc_t4(j,i)
 568      &                 +wel_loc*gshieldc_ll(j,i)
 569
 570
 571         enddo
 572       enddo
 573 #else
 574       do i=0,nct
 575         do j=1,3
 576           gradbufc(j,i)=wsc*gvdwc(j,i)+
 577      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 578      &                welec*gelc_long(j,i)+
 579      &                wbond*gradb(j,i)+
 580      &                wel_loc*gel_loc_long(j,i)+
 581      &                wcorr*gradcorr_long(j,i)+
 582      &                wcorr5*gradcorr5_long(j,i)+
 583      &                wcorr6*gradcorr6_long(j,i)+
 584      &                wturn6*gcorr6_turn_long(j,i)+
 585      &                wstrain*ghpbc(j,i)
 586      &                +wliptran*gliptranc(j,i)
 587      &                +gradafm(j,i)
 588      &                 +welec*gshieldc(j,i)
 589      &                 +wcorr*gshieldc_ec(j,i)
 590      &                 +wturn4*gshieldc_t4(j,i)
 591      &                 +wel_loc*gshieldc_ll(j,i)
 592
 593
 594         enddo
 595       enddo
 596 #endif
 597 #ifdef MPI
 598       if (nfgtasks.gt.1) then
 599       time00=MPI_Wtime()
 600 #ifdef DEBUG
 601       write (iout,*) "gradbufc before allreduce"
 602       do i=1,nres
 603         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 604       enddo
 605       call flush(iout)
 606 #endif
 607       do i=0,nres
 608         do j=1,3
 609           gradbufc_sum(j,i)=gradbufc(j,i)
 610         enddo
 611       enddo
 612 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 613 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 614 c      time_reduce=time_reduce+MPI_Wtime()-time00
 615 #ifdef DEBUG
 616 c      write (iout,*) "gradbufc_sum after allreduce"
 617 c      do i=1,nres
 618 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 619 c      enddo
 620 c      call flush(iout)
 621 #endif
 622 #ifdef TIMING
 623 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 624 #endif
 625       do i=nnt,nres
 626         do k=1,3
 627           gradbufc(k,i)=0.0d0
 628         enddo
 629       enddo
 630 #ifdef DEBUG
 631       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 632       write (iout,*) (i," jgrad_start",jgrad_start(i),
 633      &                  " jgrad_end  ",jgrad_end(i),
 634      &                  i=igrad_start,igrad_end)
 635 #endif
 636 c
 637 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 638 c do not parallelize this part.
 639 c
 640 c      do i=igrad_start,igrad_end
 641 c        do j=jgrad_start(i),jgrad_end(i)
 642 c          do k=1,3
 643 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 644 c          enddo
 645 c        enddo
 646 c      enddo
 647       do j=1,3
 648         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 649       enddo
 650       do i=nres-2,-1,-1
 651         do j=1,3
 652           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 653         enddo
 654       enddo
 655 #ifdef DEBUG
 656       write (iout,*) "gradbufc after summing"
 657       do i=1,nres
 658         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 659       enddo
 660       call flush(iout)
 661 #endif
 662       else
 663 #endif
 664 #ifdef DEBUG
 665       write (iout,*) "gradbufc"
 666       do i=1,nres
 667         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 668       enddo
 669       call flush(iout)
 670 #endif
 671       do i=-1,nres
 672         do j=1,3
 673           gradbufc_sum(j,i)=gradbufc(j,i)
 674           gradbufc(j,i)=0.0d0
 675         enddo
 676       enddo
 677       do j=1,3
 678         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 679       enddo
 680       do i=nres-2,-1,-1
 681         do j=1,3
 682           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 683         enddo
 684       enddo
 685 c      do i=nnt,nres-1
 686 c        do k=1,3
 687 c          gradbufc(k,i)=0.0d0
 688 c        enddo
 689 c        do j=i+1,nres
 690 c          do k=1,3
 691 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 692 c          enddo
 693 c        enddo
 694 c      enddo
 695 #ifdef DEBUG
 696       write (iout,*) "gradbufc after summing"
 697       do i=1,nres
 698         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 699       enddo
 700       call flush(iout)
 701 #endif
 702 #ifdef MPI
 703       endif
 704 #endif
 705       do k=1,3
 706         gradbufc(k,nres)=0.0d0
 707       enddo
 708       do i=-1,nct
 709         do j=1,3
 710 #ifdef SPLITELE
 711 C          print *,gradbufc(1,13)
 712 C          print *,welec*gelc(1,13)
 713 C          print *,wel_loc*gel_loc(1,13)
 714 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 715 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 716 C          print *,wel_loc*gel_loc_long(1,13)
 717 C          print *,gradafm(1,13),"AFM"
 718           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 719      &                wel_loc*gel_loc(j,i)+
 720      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 721      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 722      &                wel_loc*gel_loc_long(j,i)+
 723      &                wcorr*gradcorr_long(j,i)+
 724      &                wcorr5*gradcorr5_long(j,i)+
 725      &                wcorr6*gradcorr6_long(j,i)+
 726      &                wturn6*gcorr6_turn_long(j,i))+
 727      &                wbond*gradb(j,i)+
 728      &                wcorr*gradcorr(j,i)+
 729      &                wturn3*gcorr3_turn(j,i)+
 730      &                wturn4*gcorr4_turn(j,i)+
 731      &                wcorr5*gradcorr5(j,i)+
 732      &                wcorr6*gradcorr6(j,i)+
 733      &                wturn6*gcorr6_turn(j,i)+
 734      &                wsccor*gsccorc(j,i)
 735      &               +wscloc*gscloc(j,i)
 736      &               +wliptran*gliptranc(j,i)
 737      &                +gradafm(j,i)
 738      &                 +welec*gshieldc(j,i)
 739      &                 +welec*gshieldc_loc(j,i)
 740      &                 +wcorr*gshieldc_ec(j,i)
 741      &                 +wcorr*gshieldc_loc_ec(j,i)
 742      &                 +wturn3*gshieldc_t3(j,i)
 743      &                 +wturn3*gshieldc_loc_t3(j,i)
 744      &                 +wturn4*gshieldc_t4(j,i)
 745      &                 +wturn4*gshieldc_loc_t4(j,i)
 746      &                 +wel_loc*gshieldc_ll(j,i)
 747      &                 +wel_loc*gshieldc_loc_ll(j,i)
 748
 749
 750
 751
 752
 753
 754 #else
 755           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 756      &                wel_loc*gel_loc(j,i)+
 757      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 758      &                welec*gelc_long(j,i)+
 759      &                wel_loc*gel_loc_long(j,i)+
 760      &                wcorr*gcorr_long(j,i)+
 761      &                wcorr5*gradcorr5_long(j,i)+
 762      &                wcorr6*gradcorr6_long(j,i)+
 763      &                wturn6*gcorr6_turn_long(j,i))+
 764      &                wbond*gradb(j,i)+
 765      &                wcorr*gradcorr(j,i)+
 766      &                wturn3*gcorr3_turn(j,i)+
 767      &                wturn4*gcorr4_turn(j,i)+
 768      &                wcorr5*gradcorr5(j,i)+
 769      &                wcorr6*gradcorr6(j,i)+
 770      &                wturn6*gcorr6_turn(j,i)+
 771      &                wsccor*gsccorc(j,i)
 772      &               +wscloc*gscloc(j,i)
 773      &               +wliptran*gliptranc(j,i)
 774      &                +gradafm(j,i)
 775      &                 +welec*gshieldc(j,i)
 776      &                 +welec*gshieldc_loc(j,i)
 777      &                 +wcorr*gshieldc_ec(j,i)
 778      &                 +wcorr*gshieldc_loc_ec(j,i)
 779      &                 +wturn3*gshieldc_t3(j,i)
 780      &                 +wturn3*gshieldc_loc_t3(j,i)
 781      &                 +wturn4*gshieldc_t4(j,i)
 782      &                 +wturn4*gshieldc_loc_t4(j,i)
 783      &                 +wel_loc*gshieldc_ll(j,i)
 784      &                 +wel_loc*gshieldc_loc_ll(j,i)
 785
 786
 787
 788
 789
 790 #endif
 791           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 792      &                  wbond*gradbx(j,i)+
 793      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 794      &                  wsccor*gsccorx(j,i)
 795      &                 +wscloc*gsclocx(j,i)
 796      &                 +wliptran*gliptranx(j,i)
 797      &                 +welec*gshieldx(j,i)
 798      &                 +wcorr*gshieldx_ec(j,i)
 799      &                 +wturn3*gshieldx_t3(j,i)
 800      &                 +wturn4*gshieldx_t4(j,i)
 801      &                 +wel_loc*gshieldx_ll(j,i)
 802
 803
 804
 805         enddo
 806       enddo
 807 #ifdef DEBUG
 808       write (iout,*) "gloc before adding corr"
 809       do i=1,4*nres
 810         write (iout,*) i,gloc(i,icg)
 811       enddo
 812 #endif
 813       do i=1,nres-3
 814         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 815      &   +wcorr5*g_corr5_loc(i)
 816      &   +wcorr6*g_corr6_loc(i)
 817      &   +wturn4*gel_loc_turn4(i)
 818      &   +wturn3*gel_loc_turn3(i)
 819      &   +wturn6*gel_loc_turn6(i)
 820      &   +wel_loc*gel_loc_loc(i)
 821       enddo
 822 #ifdef DEBUG
 823       write (iout,*) "gloc after adding corr"
 824       do i=1,4*nres
 825         write (iout,*) i,gloc(i,icg)
 826       enddo
 827 #endif
 828 #ifdef MPI
 829       if (nfgtasks.gt.1) then
 830         do j=1,3
 831           do i=1,nres
 832             gradbufc(j,i)=gradc(j,i,icg)
 833             gradbufx(j,i)=gradx(j,i,icg)
 834           enddo
 835         enddo
 836         do i=1,4*nres
 837           glocbuf(i)=gloc(i,icg)
 838         enddo
 839 c#define DEBUG
 840 #ifdef DEBUG
 841       write (iout,*) "gloc_sc before reduce"
 842       do i=1,nres
 843        do j=1,1
 844         write (iout,*) i,j,gloc_sc(j,i,icg)
 845        enddo
 846       enddo
 847 #endif
 848 c#undef DEBUG
 849         do i=1,nres
 850          do j=1,3
 851           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 852          enddo
 853         enddo
 854         time00=MPI_Wtime()
 855         call MPI_Barrier(FG_COMM,IERR)
 856         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 857         time00=MPI_Wtime()
 858         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 859      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 860         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 861      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 862         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 863      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 864         time_reduce=time_reduce+MPI_Wtime()-time00
 865         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 866      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 867         time_reduce=time_reduce+MPI_Wtime()-time00
 868 c#define DEBUG
 869 #ifdef DEBUG
 870       write (iout,*) "gloc_sc after reduce"
 871       do i=1,nres
 872        do j=1,1
 873         write (iout,*) i,j,gloc_sc(j,i,icg)
 874        enddo
 875       enddo
 876 #endif
 877 c#undef DEBUG
 878 #ifdef DEBUG
 879       write (iout,*) "gloc after reduce"
 880       do i=1,4*nres
 881         write (iout,*) i,gloc(i,icg)
 882       enddo
 883 #endif
 884       endif
 885 #endif
 886       if (gnorm_check) then
 887 c
 888 c Compute the maximum elements of the gradient
 889 c
 890       gvdwc_max=0.0d0
 891       gvdwc_scp_max=0.0d0
 892       gelc_max=0.0d0
 893       gvdwpp_max=0.0d0
 894       gradb_max=0.0d0
 895       ghpbc_max=0.0d0
 896       gradcorr_max=0.0d0
 897       gel_loc_max=0.0d0
 898       gcorr3_turn_max=0.0d0
 899       gcorr4_turn_max=0.0d0
 900       gradcorr5_max=0.0d0
 901       gradcorr6_max=0.0d0
 902       gcorr6_turn_max=0.0d0
 903       gsccorc_max=0.0d0
 904       gscloc_max=0.0d0
 905       gvdwx_max=0.0d0
 906       gradx_scp_max=0.0d0
 907       ghpbx_max=0.0d0
 908       gradxorr_max=0.0d0
 909       gsccorx_max=0.0d0
 910       gsclocx_max=0.0d0
 911       do i=1,nct
 912         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 913         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 914         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 915         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 916      &   gvdwc_scp_max=gvdwc_scp_norm
 917         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 918         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 919         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 920         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 921         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 922         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 923         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 924         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 925         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 926         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 927         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 928         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 929         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 930      &    gcorr3_turn(1,i)))
 931         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 932      &    gcorr3_turn_max=gcorr3_turn_norm
 933         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 934      &    gcorr4_turn(1,i)))
 935         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 936      &    gcorr4_turn_max=gcorr4_turn_norm
 937         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 938         if (gradcorr5_norm.gt.gradcorr5_max)
 939      &    gradcorr5_max=gradcorr5_norm
 940         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 941         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 942         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 943      &    gcorr6_turn(1,i)))
 944         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 945      &    gcorr6_turn_max=gcorr6_turn_norm
 946         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 947         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 948         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 949         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 950         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 951         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 952         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 953         if (gradx_scp_norm.gt.gradx_scp_max)
 954      &    gradx_scp_max=gradx_scp_norm
 955         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 956         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 957         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 958         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 959         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 960         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 961         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 962         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 963       enddo
 964       if (gradout) then
 965 #ifdef AIX
 966         open(istat,file=statname,position="append")
 967 #else
 968         open(istat,file=statname,access="append")
 969 #endif
 970         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 971      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 972      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 973      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 974      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 975      &     gsccorx_max,gsclocx_max
 976         close(istat)
 977         if (gvdwc_max.gt.1.0d4) then
 978           write (iout,*) "gvdwc gvdwx gradb gradbx"
 979           do i=nnt,nct
 980             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 981      &        gradb(j,i),gradbx(j,i),j=1,3)
 982           enddo
 983           call pdbout(0.0d0,'cipiszcze',iout)
 984           call flush(iout)
 985         endif
 986       endif
 987       endif
 988 #ifdef DEBUG
 989       write (iout,*) "gradc gradx gloc"
 990       do i=1,nres
 991         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 992      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 993       enddo
 994 #endif
 995 #ifdef TIMING
 996       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 997 #endif
 998       return
 999       end
1000 c-------------------------------------------------------------------------------
1001       subroutine rescale_weights(t_bath)
1002       implicit real*8 (a-h,o-z)
1003       include 'DIMENSIONS'
1004       include 'COMMON.IOUNITS'
1005       include 'COMMON.FFIELD'
1006       include 'COMMON.SBRIDGE'
1007       double precision kfac /2.4d0/
1008       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1009 c      facT=temp0/t_bath
1010 c      facT=2*temp0/(t_bath+temp0)
1011       if (rescale_mode.eq.0) then
1012         facT=1.0d0
1013         facT2=1.0d0
1014         facT3=1.0d0
1015         facT4=1.0d0
1016         facT5=1.0d0
1017       else if (rescale_mode.eq.1) then
1018         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1019         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1020         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1021         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1022         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1023       else if (rescale_mode.eq.2) then
1024         x=t_bath/temp0
1025         x2=x*x
1026         x3=x2*x
1027         x4=x3*x
1028         x5=x4*x
1029         facT=licznik/dlog(dexp(x)+dexp(-x))
1030         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1031         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1032         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1033         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1034       else
1035         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1036         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1037 #ifdef MPI
1038        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1039 #endif
1040        stop 555
1041       endif
1042       welec=weights(3)*fact
1043       wcorr=weights(4)*fact3
1044       wcorr5=weights(5)*fact4
1045       wcorr6=weights(6)*fact5
1046       wel_loc=weights(7)*fact2
1047       wturn3=weights(8)*fact2
1048       wturn4=weights(9)*fact3
1049       wturn6=weights(10)*fact5
1050       wtor=weights(13)*fact
1051       wtor_d=weights(14)*fact2
1052       wsccor=weights(21)*fact
1053
1054       return
1055       end
1056 C------------------------------------------------------------------------
1057       subroutine enerprint(energia)
1058       implicit real*8 (a-h,o-z)
1059       include 'DIMENSIONS'
1060       include 'COMMON.IOUNITS'
1061       include 'COMMON.FFIELD'
1062       include 'COMMON.SBRIDGE'
1063       include 'COMMON.MD'
1064       double precision energia(0:n_ene)
1065       etot=energia(0)
1066       evdw=energia(1)
1067       evdw2=energia(2)
1068 #ifdef SCP14
1069       evdw2=energia(2)+energia(18)
1070 #else
1071       evdw2=energia(2)
1072 #endif
1073       ees=energia(3)
1074 #ifdef SPLITELE
1075       evdw1=energia(16)
1076 #endif
1077       ecorr=energia(4)
1078       ecorr5=energia(5)
1079       ecorr6=energia(6)
1080       eel_loc=energia(7)
1081       eello_turn3=energia(8)
1082       eello_turn4=energia(9)
1083       eello_turn6=energia(10)
1084       ebe=energia(11)
1085       escloc=energia(12)
1086       etors=energia(13)
1087       etors_d=energia(14)
1088       ehpb=energia(15)
1089       edihcnstr=energia(19)
1090       estr=energia(17)
1091       Uconst=energia(20)
1092       esccor=energia(21)
1093       eliptran=energia(22)
1094       Eafmforce=energia(23)
1095       ethetacnstr=energia(24)
1096 #ifdef SPLITELE
1097       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1098      &  estr,wbond,ebe,wang,
1099      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1100      &  ecorr,wcorr,
1101      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1102      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1103      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1104      &  etot
1105    10 format (/'Virtual-chain energies:'//
1106      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1107      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1108      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1109      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1110      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1111      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1112      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1113      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1114      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1115      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1116      & ' (SS bridges & dist. cnstr.)'/
1117      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1118      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1119      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1121      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1122      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1123      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1124      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1125      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1126      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1127      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1128      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1129      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1130      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1131      & 'ETOT=  ',1pE16.6,' (total)')
1132
1133 #else
1134       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1135      &  estr,wbond,ebe,wang,
1136      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1137      &  ecorr,wcorr,
1138      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1139      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1140      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1141      &  etot
1142    10 format (/'Virtual-chain energies:'//
1143      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1144      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1145      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1146      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1147      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1148      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1149      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1150      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1151      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1152      & ' (SS bridges & dist. cnstr.)'/
1153      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1154      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1155      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1156      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1157      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1158      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1159      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1160      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1161      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1162      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1163      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1164      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1165      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1166      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1167      & 'ETOT=  ',1pE16.6,' (total)')
1168 #endif
1169       return
1170       end
1171 C-----------------------------------------------------------------------
1172       subroutine elj(evdw)
1173 C
1174 C This subroutine calculates the interaction energy of nonbonded side chains
1175 C assuming the LJ potential of interaction.
1176 C
1177       implicit real*8 (a-h,o-z)
1178       include 'DIMENSIONS'
1179       parameter (accur=1.0d-10)
1180       include 'COMMON.GEO'
1181       include 'COMMON.VAR'
1182       include 'COMMON.LOCAL'
1183       include 'COMMON.CHAIN'
1184       include 'COMMON.DERIV'
1185       include 'COMMON.INTERACT'
1186       include 'COMMON.TORSION'
1187       include 'COMMON.SBRIDGE'
1188       include 'COMMON.NAMES'
1189       include 'COMMON.IOUNITS'
1190       include 'COMMON.CONTACTS'
1191       dimension gg(3)
1192 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1193       evdw=0.0D0
1194       do i=iatsc_s,iatsc_e
1195         itypi=iabs(itype(i))
1196         if (itypi.eq.ntyp1) cycle
1197         itypi1=iabs(itype(i+1))
1198         xi=c(1,nres+i)
1199         yi=c(2,nres+i)
1200         zi=c(3,nres+i)
1201 C Change 12/1/95
1202         num_conti=0
1203 C
1204 C Calculate SC interaction energy.
1205 C
1206         do iint=1,nint_gr(i)
1207 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1208 cd   &                  'iend=',iend(i,iint)
1209           do j=istart(i,iint),iend(i,iint)
1210             itypj=iabs(itype(j))
1211             if (itypj.eq.ntyp1) cycle
1212             xj=c(1,nres+j)-xi
1213             yj=c(2,nres+j)-yi
1214             zj=c(3,nres+j)-zi
1215 C Change 12/1/95 to calculate four-body interactions
1216             rij=xj*xj+yj*yj+zj*zj
1217             rrij=1.0D0/rij
1218 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1219             eps0ij=eps(itypi,itypj)
1220             fac=rrij**expon2
1221 C have you changed here?
1222             e1=fac*fac*aa
1223             e2=fac*bb
1224             evdwij=e1+e2
1225 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1226 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1227 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1228 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1229 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1230 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1231             evdw=evdw+evdwij
1232 C
1233 C Calculate the components of the gradient in DC and X
1234 C
1235             fac=-rrij*(e1+evdwij)
1236             gg(1)=xj*fac
1237             gg(2)=yj*fac
1238             gg(3)=zj*fac
1239             do k=1,3
1240               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1241               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1242               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1243               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1244             enddo
1245 cgrad            do k=i,j-1
1246 cgrad              do l=1,3
1247 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1248 cgrad              enddo
1249 cgrad            enddo
1250 C
1251 C 12/1/95, revised on 5/20/97
1252 C
1253 C Calculate the contact function. The ith column of the array JCONT will
1254 C contain the numbers of atoms that make contacts with the atom I (of numbers
1255 C greater than I). The arrays FACONT and GACONT will contain the values of
1256 C the contact function and its derivative.
1257 C
1258 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1259 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1260 C Uncomment next line, if the correlation interactions are contact function only
1261             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1262               rij=dsqrt(rij)
1263               sigij=sigma(itypi,itypj)
1264               r0ij=rs0(itypi,itypj)
1265 C
1266 C Check whether the SC's are not too far to make a contact.
1267 C
1268               rcut=1.5d0*r0ij
1269               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1270 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1271 C
1272               if (fcont.gt.0.0D0) then
1273 C If the SC-SC distance if close to sigma, apply spline.
1274 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1275 cAdam &             fcont1,fprimcont1)
1276 cAdam           fcont1=1.0d0-fcont1
1277 cAdam           if (fcont1.gt.0.0d0) then
1278 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1279 cAdam             fcont=fcont*fcont1
1280 cAdam           endif
1281 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1282 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1283 cga             do k=1,3
1284 cga               gg(k)=gg(k)*eps0ij
1285 cga             enddo
1286 cga             eps0ij=-evdwij*eps0ij
1287 C Uncomment for AL's type of SC correlation interactions.
1288 cadam           eps0ij=-evdwij
1289                 num_conti=num_conti+1
1290                 jcont(num_conti,i)=j
1291                 facont(num_conti,i)=fcont*eps0ij
1292                 fprimcont=eps0ij*fprimcont/rij
1293                 fcont=expon*fcont
1294 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1295 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1296 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1297 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1298                 gacont(1,num_conti,i)=-fprimcont*xj
1299                 gacont(2,num_conti,i)=-fprimcont*yj
1300                 gacont(3,num_conti,i)=-fprimcont*zj
1301 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1302 cd              write (iout,'(2i3,3f10.5)')
1303 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1304               endif
1305             endif
1306           enddo      ! j
1307         enddo        ! iint
1308 C Change 12/1/95
1309         num_cont(i)=num_conti
1310       enddo          ! i
1311       do i=1,nct
1312         do j=1,3
1313           gvdwc(j,i)=expon*gvdwc(j,i)
1314           gvdwx(j,i)=expon*gvdwx(j,i)
1315         enddo
1316       enddo
1317 C******************************************************************************
1318 C
1319 C                              N O T E !!!
1320 C
1321 C To save time, the factor of EXPON has been extracted from ALL components
1322 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1323 C use!
1324 C
1325 C******************************************************************************
1326       return
1327       end
1328 C-----------------------------------------------------------------------------
1329       subroutine eljk(evdw)
1330 C
1331 C This subroutine calculates the interaction energy of nonbonded side chains
1332 C assuming the LJK potential of interaction.
1333 C
1334       implicit real*8 (a-h,o-z)
1335       include 'DIMENSIONS'
1336       include 'COMMON.GEO'
1337       include 'COMMON.VAR'
1338       include 'COMMON.LOCAL'
1339       include 'COMMON.CHAIN'
1340       include 'COMMON.DERIV'
1341       include 'COMMON.INTERACT'
1342       include 'COMMON.IOUNITS'
1343       include 'COMMON.NAMES'
1344       dimension gg(3)
1345       logical scheck
1346 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1347       evdw=0.0D0
1348       do i=iatsc_s,iatsc_e
1349         itypi=iabs(itype(i))
1350         if (itypi.eq.ntyp1) cycle
1351         itypi1=iabs(itype(i+1))
1352         xi=c(1,nres+i)
1353         yi=c(2,nres+i)
1354         zi=c(3,nres+i)
1355 C
1356 C Calculate SC interaction energy.
1357 C
1358         do iint=1,nint_gr(i)
1359           do j=istart(i,iint),iend(i,iint)
1360             itypj=iabs(itype(j))
1361             if (itypj.eq.ntyp1) cycle
1362             xj=c(1,nres+j)-xi
1363             yj=c(2,nres+j)-yi
1364             zj=c(3,nres+j)-zi
1365             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1366             fac_augm=rrij**expon
1367             e_augm=augm(itypi,itypj)*fac_augm
1368             r_inv_ij=dsqrt(rrij)
1369             rij=1.0D0/r_inv_ij
1370             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1371             fac=r_shift_inv**expon
1372 C have you changed here?
1373             e1=fac*fac*aa
1374             e2=fac*bb
1375             evdwij=e_augm+e1+e2
1376 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1379 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1380 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1381 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1382 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1383             evdw=evdw+evdwij
1384 C
1385 C Calculate the components of the gradient in DC and X
1386 C
1387             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1388             gg(1)=xj*fac
1389             gg(2)=yj*fac
1390             gg(3)=zj*fac
1391             do k=1,3
1392               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1393               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1394               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1395               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1396             enddo
1397 cgrad            do k=i,j-1
1398 cgrad              do l=1,3
1399 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1400 cgrad              enddo
1401 cgrad            enddo
1402           enddo      ! j
1403         enddo        ! iint
1404       enddo          ! i
1405       do i=1,nct
1406         do j=1,3
1407           gvdwc(j,i)=expon*gvdwc(j,i)
1408           gvdwx(j,i)=expon*gvdwx(j,i)
1409         enddo
1410       enddo
1411       return
1412       end
1413 C-----------------------------------------------------------------------------
1414       subroutine ebp(evdw)
1415 C
1416 C This subroutine calculates the interaction energy of nonbonded side chains
1417 C assuming the Berne-Pechukas potential of interaction.
1418 C
1419       implicit real*8 (a-h,o-z)
1420       include 'DIMENSIONS'
1421       include 'COMMON.GEO'
1422       include 'COMMON.VAR'
1423       include 'COMMON.LOCAL'
1424       include 'COMMON.CHAIN'
1425       include 'COMMON.DERIV'
1426       include 'COMMON.NAMES'
1427       include 'COMMON.INTERACT'
1428       include 'COMMON.IOUNITS'
1429       include 'COMMON.CALC'
1430       common /srutu/ icall
1431 c     double precision rrsave(maxdim)
1432       logical lprn
1433       evdw=0.0D0
1434 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1435       evdw=0.0D0
1436 c     if (icall.eq.0) then
1437 c       lprn=.true.
1438 c     else
1439         lprn=.false.
1440 c     endif
1441       ind=0
1442       do i=iatsc_s,iatsc_e
1443         itypi=iabs(itype(i))
1444         if (itypi.eq.ntyp1) cycle
1445         itypi1=iabs(itype(i+1))
1446         xi=c(1,nres+i)
1447         yi=c(2,nres+i)
1448         zi=c(3,nres+i)
1449         dxi=dc_norm(1,nres+i)
1450         dyi=dc_norm(2,nres+i)
1451         dzi=dc_norm(3,nres+i)
1452 c        dsci_inv=dsc_inv(itypi)
1453         dsci_inv=vbld_inv(i+nres)
1454 C
1455 C Calculate SC interaction energy.
1456 C
1457         do iint=1,nint_gr(i)
1458           do j=istart(i,iint),iend(i,iint)
1459             ind=ind+1
1460             itypj=iabs(itype(j))
1461             if (itypj.eq.ntyp1) cycle
1462 c            dscj_inv=dsc_inv(itypj)
1463             dscj_inv=vbld_inv(j+nres)
1464             chi1=chi(itypi,itypj)
1465             chi2=chi(itypj,itypi)
1466             chi12=chi1*chi2
1467             chip1=chip(itypi)
1468             chip2=chip(itypj)
1469             chip12=chip1*chip2
1470             alf1=alp(itypi)
1471             alf2=alp(itypj)
1472             alf12=0.5D0*(alf1+alf2)
1473 C For diagnostics only!!!
1474 c           chi1=0.0D0
1475 c           chi2=0.0D0
1476 c           chi12=0.0D0
1477 c           chip1=0.0D0
1478 c           chip2=0.0D0
1479 c           chip12=0.0D0
1480 c           alf1=0.0D0
1481 c           alf2=0.0D0
1482 c           alf12=0.0D0
1483             xj=c(1,nres+j)-xi
1484             yj=c(2,nres+j)-yi
1485             zj=c(3,nres+j)-zi
1486             dxj=dc_norm(1,nres+j)
1487             dyj=dc_norm(2,nres+j)
1488             dzj=dc_norm(3,nres+j)
1489             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1490 cd          if (icall.eq.0) then
1491 cd            rrsave(ind)=rrij
1492 cd          else
1493 cd            rrij=rrsave(ind)
1494 cd          endif
1495             rij=dsqrt(rrij)
1496 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1497             call sc_angular
1498 C Calculate whole angle-dependent part of epsilon and contributions
1499 C to its derivatives
1500 C have you changed here?
1501             fac=(rrij*sigsq)**expon2
1502             e1=fac*fac*aa
1503             e2=fac*bb
1504             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1505             eps2der=evdwij*eps3rt
1506             eps3der=evdwij*eps2rt
1507             evdwij=evdwij*eps2rt*eps3rt
1508             evdw=evdw+evdwij
1509             if (lprn) then
1510             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1511             epsi=bb**2/aa
1512 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1513 cd     &        restyp(itypi),i,restyp(itypj),j,
1514 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1515 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1516 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1517 cd     &        evdwij
1518             endif
1519 C Calculate gradient components.
1520             e1=e1*eps1*eps2rt**2*eps3rt**2
1521             fac=-expon*(e1+evdwij)
1522             sigder=fac/sigsq
1523             fac=rrij*fac
1524 C Calculate radial part of the gradient
1525             gg(1)=xj*fac
1526             gg(2)=yj*fac
1527             gg(3)=zj*fac
1528 C Calculate the angular part of the gradient and sum add the contributions
1529 C to the appropriate components of the Cartesian gradient.
1530             call sc_grad
1531           enddo      ! j
1532         enddo        ! iint
1533       enddo          ! i
1534 c     stop
1535       return
1536       end
1537 C-----------------------------------------------------------------------------
1538       subroutine egb(evdw)
1539 C
1540 C This subroutine calculates the interaction energy of nonbonded side chains
1541 C assuming the Gay-Berne potential of interaction.
1542 C
1543       implicit real*8 (a-h,o-z)
1544       include 'DIMENSIONS'
1545       include 'COMMON.GEO'
1546       include 'COMMON.VAR'
1547       include 'COMMON.LOCAL'
1548       include 'COMMON.CHAIN'
1549       include 'COMMON.DERIV'
1550       include 'COMMON.NAMES'
1551       include 'COMMON.INTERACT'
1552       include 'COMMON.IOUNITS'
1553       include 'COMMON.CALC'
1554       include 'COMMON.CONTROL'
1555       include 'COMMON.SPLITELE'
1556       include 'COMMON.SBRIDGE'
1557       logical lprn
1558       integer xshift,yshift,zshift
1559
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       lprn=.false.
1565 c     if (icall.eq.0) lprn=.false.
1566       ind=0
1567 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1568 C we have the original box)
1569 C      do xshift=-1,1
1570 C      do yshift=-1,1
1571 C      do zshift=-1,1
1572       do i=iatsc_s,iatsc_e
1573         itypi=iabs(itype(i))
1574         if (itypi.eq.ntyp1) cycle
1575         itypi1=iabs(itype(i+1))
1576         xi=c(1,nres+i)
1577         yi=c(2,nres+i)
1578         zi=c(3,nres+i)
1579 C Return atom into box, boxxsize is size of box in x dimension
1580 c  134   continue
1581 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1582 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1583 C Condition for being inside the proper box
1584 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1585 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1586 c        go to 134
1587 c        endif
1588 c  135   continue
1589 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1590 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1591 C Condition for being inside the proper box
1592 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1593 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1594 c        go to 135
1595 c        endif
1596 c  136   continue
1597 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1598 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1599 C Condition for being inside the proper box
1600 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1601 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1602 c        go to 136
1603 c        endif
1604           xi=mod(xi,boxxsize)
1605           if (xi.lt.0) xi=xi+boxxsize
1606           yi=mod(yi,boxysize)
1607           if (yi.lt.0) yi=yi+boxysize
1608           zi=mod(zi,boxzsize)
1609           if (zi.lt.0) zi=zi+boxzsize
1610 C define scaling factor for lipids
1611
1612 C        if (positi.le.0) positi=positi+boxzsize
1613 C        print *,i
1614 C first for peptide groups
1615 c for each residue check if it is in lipid or lipid water border area
1616        if ((zi.gt.bordlipbot)
1617      &.and.(zi.lt.bordliptop)) then
1618 C the energy transfer exist
1619         if (zi.lt.buflipbot) then
1620 C what fraction I am in
1621          fracinbuf=1.0d0-
1622      &        ((zi-bordlipbot)/lipbufthick)
1623 C lipbufthick is thickenes of lipid buffore
1624          sslipi=sscalelip(fracinbuf)
1625          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1626         elseif (zi.gt.bufliptop) then
1627          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1628          sslipi=sscalelip(fracinbuf)
1629          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1630         else
1631          sslipi=1.0d0
1632          ssgradlipi=0.0
1633         endif
1634        else
1635          sslipi=0.0d0
1636          ssgradlipi=0.0
1637        endif
1638
1639 C          xi=xi+xshift*boxxsize
1640 C          yi=yi+yshift*boxysize
1641 C          zi=zi+zshift*boxzsize
1642
1643         dxi=dc_norm(1,nres+i)
1644         dyi=dc_norm(2,nres+i)
1645         dzi=dc_norm(3,nres+i)
1646 c        dsci_inv=dsc_inv(itypi)
1647         dsci_inv=vbld_inv(i+nres)
1648 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1649 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1650 C
1651 C Calculate SC interaction energy.
1652 C
1653         do iint=1,nint_gr(i)
1654           do j=istart(i,iint),iend(i,iint)
1655             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1656
1657 c              write(iout,*) "PRZED ZWYKLE", evdwij
1658               call dyn_ssbond_ene(i,j,evdwij)
1659 c              write(iout,*) "PO ZWYKLE", evdwij
1660
1661               evdw=evdw+evdwij
1662               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1663      &                        'evdw',i,j,evdwij,' ss'
1664 C triple bond artifac removal
1665              do k=j+1,iend(i,iint)
1666 C search over all next residues
1667               if (dyn_ss_mask(k)) then
1668 C check if they are cysteins
1669 C              write(iout,*) 'k=',k
1670
1671 c              write(iout,*) "PRZED TRI", evdwij
1672                evdwij_przed_tri=evdwij
1673               call triple_ssbond_ene(i,j,k,evdwij)
1674 c               if(evdwij_przed_tri.ne.evdwij) then
1675 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1676 c               endif
1677
1678 c              write(iout,*) "PO TRI", evdwij
1679 C call the energy function that removes the artifical triple disulfide
1680 C bond the soubroutine is located in ssMD.F
1681               evdw=evdw+evdwij
1682               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1683      &                        'evdw',i,j,evdwij,'tss'
1684               endif!dyn_ss_mask(k)
1685              enddo! k
1686             ELSE
1687             ind=ind+1
1688             itypj=iabs(itype(j))
1689             if (itypj.eq.ntyp1) cycle
1690 c            dscj_inv=dsc_inv(itypj)
1691             dscj_inv=vbld_inv(j+nres)
1692 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1693 c     &       1.0d0/vbld(j+nres)
1694 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1695             sig0ij=sigma(itypi,itypj)
1696             chi1=chi(itypi,itypj)
1697             chi2=chi(itypj,itypi)
1698             chi12=chi1*chi2
1699             chip1=chip(itypi)
1700             chip2=chip(itypj)
1701             chip12=chip1*chip2
1702             alf1=alp(itypi)
1703             alf2=alp(itypj)
1704             alf12=0.5D0*(alf1+alf2)
1705 C For diagnostics only!!!
1706 c           chi1=0.0D0
1707 c           chi2=0.0D0
1708 c           chi12=0.0D0
1709 c           chip1=0.0D0
1710 c           chip2=0.0D0
1711 c           chip12=0.0D0
1712 c           alf1=0.0D0
1713 c           alf2=0.0D0
1714 c           alf12=0.0D0
1715             xj=c(1,nres+j)
1716             yj=c(2,nres+j)
1717             zj=c(3,nres+j)
1718 C Return atom J into box the original box
1719 c  137   continue
1720 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1721 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1722 C Condition for being inside the proper box
1723 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1724 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1725 c        go to 137
1726 c        endif
1727 c  138   continue
1728 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1729 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1730 C Condition for being inside the proper box
1731 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1732 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1733 c        go to 138
1734 c        endif
1735 c  139   continue
1736 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1737 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1738 C Condition for being inside the proper box
1739 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1740 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1741 c        go to 139
1742 c        endif
1743           xj=mod(xj,boxxsize)
1744           if (xj.lt.0) xj=xj+boxxsize
1745           yj=mod(yj,boxysize)
1746           if (yj.lt.0) yj=yj+boxysize
1747           zj=mod(zj,boxzsize)
1748           if (zj.lt.0) zj=zj+boxzsize
1749        if ((zj.gt.bordlipbot)
1750      &.and.(zj.lt.bordliptop)) then
1751 C the energy transfer exist
1752         if (zj.lt.buflipbot) then
1753 C what fraction I am in
1754          fracinbuf=1.0d0-
1755      &        ((zj-bordlipbot)/lipbufthick)
1756 C lipbufthick is thickenes of lipid buffore
1757          sslipj=sscalelip(fracinbuf)
1758          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1759         elseif (zj.gt.bufliptop) then
1760          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1761          sslipj=sscalelip(fracinbuf)
1762          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1763         else
1764          sslipj=1.0d0
1765          ssgradlipj=0.0
1766         endif
1767        else
1768          sslipj=0.0d0
1769          ssgradlipj=0.0
1770        endif
1771       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1772      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1773       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1774      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1775 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1776 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1777 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1778 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1779       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1780       xj_safe=xj
1781       yj_safe=yj
1782       zj_safe=zj
1783       subchap=0
1784       do xshift=-1,1
1785       do yshift=-1,1
1786       do zshift=-1,1
1787           xj=xj_safe+xshift*boxxsize
1788           yj=yj_safe+yshift*boxysize
1789           zj=zj_safe+zshift*boxzsize
1790           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1791           if(dist_temp.lt.dist_init) then
1792             dist_init=dist_temp
1793             xj_temp=xj
1794             yj_temp=yj
1795             zj_temp=zj
1796             subchap=1
1797           endif
1798        enddo
1799        enddo
1800        enddo
1801        if (subchap.eq.1) then
1802           xj=xj_temp-xi
1803           yj=yj_temp-yi
1804           zj=zj_temp-zi
1805        else
1806           xj=xj_safe-xi
1807           yj=yj_safe-yi
1808           zj=zj_safe-zi
1809        endif
1810             dxj=dc_norm(1,nres+j)
1811             dyj=dc_norm(2,nres+j)
1812             dzj=dc_norm(3,nres+j)
1813 C            xj=xj-xi
1814 C            yj=yj-yi
1815 C            zj=zj-zi
1816 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1817 c            write (iout,*) "j",j," dc_norm",
1818 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1819             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1820             rij=dsqrt(rrij)
1821             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1822             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1823
1824 c            write (iout,'(a7,4f8.3)')
1825 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1826             if (sss.gt.0.0d0) then
1827 C Calculate angle-dependent terms of energy and contributions to their
1828 C derivatives.
1829             call sc_angular
1830             sigsq=1.0D0/sigsq
1831             sig=sig0ij*dsqrt(sigsq)
1832             rij_shift=1.0D0/rij-sig+sig0ij
1833 c for diagnostics; uncomment
1834 c            rij_shift=1.2*sig0ij
1835 C I hate to put IF's in the loops, but here don't have another choice!!!!
1836             if (rij_shift.le.0.0D0) then
1837               evdw=1.0D20
1838 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1839 cd     &        restyp(itypi),i,restyp(itypj),j,
1840 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1841               return
1842             endif
1843             sigder=-sig*sigsq
1844 c---------------------------------------------------------------
1845             rij_shift=1.0D0/rij_shift
1846             fac=rij_shift**expon
1847 C here to start with
1848 C            if (c(i,3).gt.
1849             faclip=fac
1850             e1=fac*fac*aa
1851             e2=fac*bb
1852             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1853             eps2der=evdwij*eps3rt
1854             eps3der=evdwij*eps2rt
1855 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1856 C     &((sslipi+sslipj)/2.0d0+
1857 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1858 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1859 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1860             evdwij=evdwij*eps2rt*eps3rt
1861             evdw=evdw+evdwij*sss
1862             if (lprn) then
1863             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1864             epsi=bb**2/aa
1865             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1866      &        restyp(itypi),i,restyp(itypj),j,
1867      &        epsi,sigm,chi1,chi2,chip1,chip2,
1868      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1869      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1870      &        evdwij
1871             endif
1872
1873             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1874      &                        'evdw',i,j,evdwij
1875
1876 C Calculate gradient components.
1877             e1=e1*eps1*eps2rt**2*eps3rt**2
1878             fac=-expon*(e1+evdwij)*rij_shift
1879             sigder=fac*sigder
1880             fac=rij*fac
1881 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1882 c     &      evdwij,fac,sigma(itypi,itypj),expon
1883             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1884 c            fac=0.0d0
1885 C Calculate the radial part of the gradient
1886             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1887      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1888      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1889      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1890             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1891             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1892 C            gg_lipi(3)=0.0d0
1893 C            gg_lipj(3)=0.0d0
1894             gg(1)=xj*fac
1895             gg(2)=yj*fac
1896             gg(3)=zj*fac
1897 C Calculate angular part of the gradient.
1898             call sc_grad
1899             endif
1900             ENDIF    ! dyn_ss
1901           enddo      ! j
1902         enddo        ! iint
1903       enddo          ! i
1904 C      enddo          ! zshift
1905 C      enddo          ! yshift
1906 C      enddo          ! xshift
1907 c      write (iout,*) "Number of loop steps in EGB:",ind
1908 cccc      energy_dec=.false.
1909       return
1910       end
1911 C-----------------------------------------------------------------------------
1912       subroutine egbv(evdw)
1913 C
1914 C This subroutine calculates the interaction energy of nonbonded side chains
1915 C assuming the Gay-Berne-Vorobjev potential of interaction.
1916 C
1917       implicit real*8 (a-h,o-z)
1918       include 'DIMENSIONS'
1919       include 'COMMON.GEO'
1920       include 'COMMON.VAR'
1921       include 'COMMON.LOCAL'
1922       include 'COMMON.CHAIN'
1923       include 'COMMON.DERIV'
1924       include 'COMMON.NAMES'
1925       include 'COMMON.INTERACT'
1926       include 'COMMON.IOUNITS'
1927       include 'COMMON.CALC'
1928       common /srutu/ icall
1929       logical lprn
1930       evdw=0.0D0
1931 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1932       evdw=0.0D0
1933       lprn=.false.
1934 c     if (icall.eq.0) lprn=.true.
1935       ind=0
1936       do i=iatsc_s,iatsc_e
1937         itypi=iabs(itype(i))
1938         if (itypi.eq.ntyp1) cycle
1939         itypi1=iabs(itype(i+1))
1940         xi=c(1,nres+i)
1941         yi=c(2,nres+i)
1942         zi=c(3,nres+i)
1943           xi=mod(xi,boxxsize)
1944           if (xi.lt.0) xi=xi+boxxsize
1945           yi=mod(yi,boxysize)
1946           if (yi.lt.0) yi=yi+boxysize
1947           zi=mod(zi,boxzsize)
1948           if (zi.lt.0) zi=zi+boxzsize
1949 C define scaling factor for lipids
1950
1951 C        if (positi.le.0) positi=positi+boxzsize
1952 C        print *,i
1953 C first for peptide groups
1954 c for each residue check if it is in lipid or lipid water border area
1955        if ((zi.gt.bordlipbot)
1956      &.and.(zi.lt.bordliptop)) then
1957 C the energy transfer exist
1958         if (zi.lt.buflipbot) then
1959 C what fraction I am in
1960          fracinbuf=1.0d0-
1961      &        ((zi-bordlipbot)/lipbufthick)
1962 C lipbufthick is thickenes of lipid buffore
1963          sslipi=sscalelip(fracinbuf)
1964          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1965         elseif (zi.gt.bufliptop) then
1966          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1967          sslipi=sscalelip(fracinbuf)
1968          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1969         else
1970          sslipi=1.0d0
1971          ssgradlipi=0.0
1972         endif
1973        else
1974          sslipi=0.0d0
1975          ssgradlipi=0.0
1976        endif
1977
1978         dxi=dc_norm(1,nres+i)
1979         dyi=dc_norm(2,nres+i)
1980         dzi=dc_norm(3,nres+i)
1981 c        dsci_inv=dsc_inv(itypi)
1982         dsci_inv=vbld_inv(i+nres)
1983 C
1984 C Calculate SC interaction energy.
1985 C
1986         do iint=1,nint_gr(i)
1987           do j=istart(i,iint),iend(i,iint)
1988             ind=ind+1
1989             itypj=iabs(itype(j))
1990             if (itypj.eq.ntyp1) cycle
1991 c            dscj_inv=dsc_inv(itypj)
1992             dscj_inv=vbld_inv(j+nres)
1993             sig0ij=sigma(itypi,itypj)
1994             r0ij=r0(itypi,itypj)
1995             chi1=chi(itypi,itypj)
1996             chi2=chi(itypj,itypi)
1997             chi12=chi1*chi2
1998             chip1=chip(itypi)
1999             chip2=chip(itypj)
2000             chip12=chip1*chip2
2001             alf1=alp(itypi)
2002             alf2=alp(itypj)
2003             alf12=0.5D0*(alf1+alf2)
2004 C For diagnostics only!!!
2005 c           chi1=0.0D0
2006 c           chi2=0.0D0
2007 c           chi12=0.0D0
2008 c           chip1=0.0D0
2009 c           chip2=0.0D0
2010 c           chip12=0.0D0
2011 c           alf1=0.0D0
2012 c           alf2=0.0D0
2013 c           alf12=0.0D0
2014 C            xj=c(1,nres+j)-xi
2015 C            yj=c(2,nres+j)-yi
2016 C            zj=c(3,nres+j)-zi
2017           xj=mod(xj,boxxsize)
2018           if (xj.lt.0) xj=xj+boxxsize
2019           yj=mod(yj,boxysize)
2020           if (yj.lt.0) yj=yj+boxysize
2021           zj=mod(zj,boxzsize)
2022           if (zj.lt.0) zj=zj+boxzsize
2023        if ((zj.gt.bordlipbot)
2024      &.and.(zj.lt.bordliptop)) then
2025 C the energy transfer exist
2026         if (zj.lt.buflipbot) then
2027 C what fraction I am in
2028          fracinbuf=1.0d0-
2029      &        ((zj-bordlipbot)/lipbufthick)
2030 C lipbufthick is thickenes of lipid buffore
2031          sslipj=sscalelip(fracinbuf)
2032          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2033         elseif (zj.gt.bufliptop) then
2034          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2035          sslipj=sscalelip(fracinbuf)
2036          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2037         else
2038          sslipj=1.0d0
2039          ssgradlipj=0.0
2040         endif
2041        else
2042          sslipj=0.0d0
2043          ssgradlipj=0.0
2044        endif
2045       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2046      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2047       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2048      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2049 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2050 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2051       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2052       xj_safe=xj
2053       yj_safe=yj
2054       zj_safe=zj
2055       subchap=0
2056       do xshift=-1,1
2057       do yshift=-1,1
2058       do zshift=-1,1
2059           xj=xj_safe+xshift*boxxsize
2060           yj=yj_safe+yshift*boxysize
2061           zj=zj_safe+zshift*boxzsize
2062           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2063           if(dist_temp.lt.dist_init) then
2064             dist_init=dist_temp
2065             xj_temp=xj
2066             yj_temp=yj
2067             zj_temp=zj
2068             subchap=1
2069           endif
2070        enddo
2071        enddo
2072        enddo
2073        if (subchap.eq.1) then
2074           xj=xj_temp-xi
2075           yj=yj_temp-yi
2076           zj=zj_temp-zi
2077        else
2078           xj=xj_safe-xi
2079           yj=yj_safe-yi
2080           zj=zj_safe-zi
2081        endif
2082             dxj=dc_norm(1,nres+j)
2083             dyj=dc_norm(2,nres+j)
2084             dzj=dc_norm(3,nres+j)
2085             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2086             rij=dsqrt(rrij)
2087 C Calculate angle-dependent terms of energy and contributions to their
2088 C derivatives.
2089             call sc_angular
2090             sigsq=1.0D0/sigsq
2091             sig=sig0ij*dsqrt(sigsq)
2092             rij_shift=1.0D0/rij-sig+r0ij
2093 C I hate to put IF's in the loops, but here don't have another choice!!!!
2094             if (rij_shift.le.0.0D0) then
2095               evdw=1.0D20
2096               return
2097             endif
2098             sigder=-sig*sigsq
2099 c---------------------------------------------------------------
2100             rij_shift=1.0D0/rij_shift
2101             fac=rij_shift**expon
2102             e1=fac*fac*aa
2103             e2=fac*bb
2104             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2105             eps2der=evdwij*eps3rt
2106             eps3der=evdwij*eps2rt
2107             fac_augm=rrij**expon
2108             e_augm=augm(itypi,itypj)*fac_augm
2109             evdwij=evdwij*eps2rt*eps3rt
2110             evdw=evdw+evdwij+e_augm
2111             if (lprn) then
2112             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2113             epsi=bb**2/aa
2114             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2115      &        restyp(itypi),i,restyp(itypj),j,
2116      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2117      &        chi1,chi2,chip1,chip2,
2118      &        eps1,eps2rt**2,eps3rt**2,
2119      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2120      &        evdwij+e_augm
2121             endif
2122 C Calculate gradient components.
2123             e1=e1*eps1*eps2rt**2*eps3rt**2
2124             fac=-expon*(e1+evdwij)*rij_shift
2125             sigder=fac*sigder
2126             fac=rij*fac-2*expon*rrij*e_augm
2127             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2128 C Calculate the radial part of the gradient
2129             gg(1)=xj*fac
2130             gg(2)=yj*fac
2131             gg(3)=zj*fac
2132 C Calculate angular part of the gradient.
2133             call sc_grad
2134           enddo      ! j
2135         enddo        ! iint
2136       enddo          ! i
2137       end
2138 C-----------------------------------------------------------------------------
2139       subroutine sc_angular
2140 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2141 C om12. Called by ebp, egb, and egbv.
2142       implicit none
2143       include 'COMMON.CALC'
2144       include 'COMMON.IOUNITS'
2145       erij(1)=xj*rij
2146       erij(2)=yj*rij
2147       erij(3)=zj*rij
2148       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2149       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2150       om12=dxi*dxj+dyi*dyj+dzi*dzj
2151       chiom12=chi12*om12
2152 C Calculate eps1(om12) and its derivative in om12
2153       faceps1=1.0D0-om12*chiom12
2154       faceps1_inv=1.0D0/faceps1
2155       eps1=dsqrt(faceps1_inv)
2156 C Following variable is eps1*deps1/dom12
2157       eps1_om12=faceps1_inv*chiom12
2158 c diagnostics only
2159 c      faceps1_inv=om12
2160 c      eps1=om12
2161 c      eps1_om12=1.0d0
2162 c      write (iout,*) "om12",om12," eps1",eps1
2163 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2164 C and om12.
2165       om1om2=om1*om2
2166       chiom1=chi1*om1
2167       chiom2=chi2*om2
2168       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2169       sigsq=1.0D0-facsig*faceps1_inv
2170       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2171       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2172       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2173 c diagnostics only
2174 c      sigsq=1.0d0
2175 c      sigsq_om1=0.0d0
2176 c      sigsq_om2=0.0d0
2177 c      sigsq_om12=0.0d0
2178 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2179 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2180 c     &    " eps1",eps1
2181 C Calculate eps2 and its derivatives in om1, om2, and om12.
2182       chipom1=chip1*om1
2183       chipom2=chip2*om2
2184       chipom12=chip12*om12
2185       facp=1.0D0-om12*chipom12
2186       facp_inv=1.0D0/facp
2187       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2188 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2189 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2190 C Following variable is the square root of eps2
2191       eps2rt=1.0D0-facp1*facp_inv
2192 C Following three variables are the derivatives of the square root of eps
2193 C in om1, om2, and om12.
2194       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2195       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2196       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2197 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2198       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2199 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2200 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2201 c     &  " eps2rt_om12",eps2rt_om12
2202 C Calculate whole angle-dependent part of epsilon and contributions
2203 C to its derivatives
2204       return
2205       end
2206 C----------------------------------------------------------------------------
2207       subroutine sc_grad
2208       implicit real*8 (a-h,o-z)
2209       include 'DIMENSIONS'
2210       include 'COMMON.CHAIN'
2211       include 'COMMON.DERIV'
2212       include 'COMMON.CALC'
2213       include 'COMMON.IOUNITS'
2214       double precision dcosom1(3),dcosom2(3)
2215 cc      print *,'sss=',sss
2216       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2217       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2218       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2219      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2220 c diagnostics only
2221 c      eom1=0.0d0
2222 c      eom2=0.0d0
2223 c      eom12=evdwij*eps1_om12
2224 c end diagnostics
2225 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2226 c     &  " sigder",sigder
2227 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2228 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2229       do k=1,3
2230         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2231         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2232       enddo
2233       do k=1,3
2234         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2235       enddo
2236 c      write (iout,*) "gg",(gg(k),k=1,3)
2237       do k=1,3
2238         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2239      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2240      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2241         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2242      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2243      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2244 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2245 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2246 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2247 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2248       enddo
2249 C
2250 C Calculate the components of the gradient in DC and X
2251 C
2252 cgrad      do k=i,j-1
2253 cgrad        do l=1,3
2254 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2255 cgrad        enddo
2256 cgrad      enddo
2257       do l=1,3
2258         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2259         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2260       enddo
2261       return
2262       end
2263 C-----------------------------------------------------------------------
2264       subroutine e_softsphere(evdw)
2265 C
2266 C This subroutine calculates the interaction energy of nonbonded side chains
2267 C assuming the LJ potential of interaction.
2268 C
2269       implicit real*8 (a-h,o-z)
2270       include 'DIMENSIONS'
2271       parameter (accur=1.0d-10)
2272       include 'COMMON.GEO'
2273       include 'COMMON.VAR'
2274       include 'COMMON.LOCAL'
2275       include 'COMMON.CHAIN'
2276       include 'COMMON.DERIV'
2277       include 'COMMON.INTERACT'
2278       include 'COMMON.TORSION'
2279       include 'COMMON.SBRIDGE'
2280       include 'COMMON.NAMES'
2281       include 'COMMON.IOUNITS'
2282       include 'COMMON.CONTACTS'
2283       dimension gg(3)
2284 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2285       evdw=0.0D0
2286       do i=iatsc_s,iatsc_e
2287         itypi=iabs(itype(i))
2288         if (itypi.eq.ntyp1) cycle
2289         itypi1=iabs(itype(i+1))
2290         xi=c(1,nres+i)
2291         yi=c(2,nres+i)
2292         zi=c(3,nres+i)
2293 C
2294 C Calculate SC interaction energy.
2295 C
2296         do iint=1,nint_gr(i)
2297 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2298 cd   &                  'iend=',iend(i,iint)
2299           do j=istart(i,iint),iend(i,iint)
2300             itypj=iabs(itype(j))
2301             if (itypj.eq.ntyp1) cycle
2302             xj=c(1,nres+j)-xi
2303             yj=c(2,nres+j)-yi
2304             zj=c(3,nres+j)-zi
2305             rij=xj*xj+yj*yj+zj*zj
2306 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2307             r0ij=r0(itypi,itypj)
2308             r0ijsq=r0ij*r0ij
2309 c            print *,i,j,r0ij,dsqrt(rij)
2310             if (rij.lt.r0ijsq) then
2311               evdwij=0.25d0*(rij-r0ijsq)**2
2312               fac=rij-r0ijsq
2313             else
2314               evdwij=0.0d0
2315               fac=0.0d0
2316             endif
2317             evdw=evdw+evdwij
2318 C
2319 C Calculate the components of the gradient in DC and X
2320 C
2321             gg(1)=xj*fac
2322             gg(2)=yj*fac
2323             gg(3)=zj*fac
2324             do k=1,3
2325               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2326               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2327               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2328               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2329             enddo
2330 cgrad            do k=i,j-1
2331 cgrad              do l=1,3
2332 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2333 cgrad              enddo
2334 cgrad            enddo
2335           enddo ! j
2336         enddo ! iint
2337       enddo ! i
2338       return
2339       end
2340 C--------------------------------------------------------------------------
2341       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2342      &              eello_turn4)
2343 C
2344 C Soft-sphere potential of p-p interaction
2345 C
2346       implicit real*8 (a-h,o-z)
2347       include 'DIMENSIONS'
2348       include 'COMMON.CONTROL'
2349       include 'COMMON.IOUNITS'
2350       include 'COMMON.GEO'
2351       include 'COMMON.VAR'
2352       include 'COMMON.LOCAL'
2353       include 'COMMON.CHAIN'
2354       include 'COMMON.DERIV'
2355       include 'COMMON.INTERACT'
2356       include 'COMMON.CONTACTS'
2357       include 'COMMON.TORSION'
2358       include 'COMMON.VECTORS'
2359       include 'COMMON.FFIELD'
2360       dimension ggg(3)
2361 C      write(iout,*) 'In EELEC_soft_sphere'
2362       ees=0.0D0
2363       evdw1=0.0D0
2364       eel_loc=0.0d0
2365       eello_turn3=0.0d0
2366       eello_turn4=0.0d0
2367       ind=0
2368       do i=iatel_s,iatel_e
2369         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2370         dxi=dc(1,i)
2371         dyi=dc(2,i)
2372         dzi=dc(3,i)
2373         xmedi=c(1,i)+0.5d0*dxi
2374         ymedi=c(2,i)+0.5d0*dyi
2375         zmedi=c(3,i)+0.5d0*dzi
2376           xmedi=mod(xmedi,boxxsize)
2377           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2378           ymedi=mod(ymedi,boxysize)
2379           if (ymedi.lt.0) ymedi=ymedi+boxysize
2380           zmedi=mod(zmedi,boxzsize)
2381           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2382         num_conti=0
2383 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2384         do j=ielstart(i),ielend(i)
2385           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2386           ind=ind+1
2387           iteli=itel(i)
2388           itelj=itel(j)
2389           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2390           r0ij=rpp(iteli,itelj)
2391           r0ijsq=r0ij*r0ij
2392           dxj=dc(1,j)
2393           dyj=dc(2,j)
2394           dzj=dc(3,j)
2395           xj=c(1,j)+0.5D0*dxj
2396           yj=c(2,j)+0.5D0*dyj
2397           zj=c(3,j)+0.5D0*dzj
2398           xj=mod(xj,boxxsize)
2399           if (xj.lt.0) xj=xj+boxxsize
2400           yj=mod(yj,boxysize)
2401           if (yj.lt.0) yj=yj+boxysize
2402           zj=mod(zj,boxzsize)
2403           if (zj.lt.0) zj=zj+boxzsize
2404       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2405       xj_safe=xj
2406       yj_safe=yj
2407       zj_safe=zj
2408       isubchap=0
2409       do xshift=-1,1
2410       do yshift=-1,1
2411       do zshift=-1,1
2412           xj=xj_safe+xshift*boxxsize
2413           yj=yj_safe+yshift*boxysize
2414           zj=zj_safe+zshift*boxzsize
2415           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2416           if(dist_temp.lt.dist_init) then
2417             dist_init=dist_temp
2418             xj_temp=xj
2419             yj_temp=yj
2420             zj_temp=zj
2421             isubchap=1
2422           endif
2423        enddo
2424        enddo
2425        enddo
2426        if (isubchap.eq.1) then
2427           xj=xj_temp-xmedi
2428           yj=yj_temp-ymedi
2429           zj=zj_temp-zmedi
2430        else
2431           xj=xj_safe-xmedi
2432           yj=yj_safe-ymedi
2433           zj=zj_safe-zmedi
2434        endif
2435           rij=xj*xj+yj*yj+zj*zj
2436             sss=sscale(sqrt(rij))
2437             sssgrad=sscagrad(sqrt(rij))
2438           if (rij.lt.r0ijsq) then
2439             evdw1ij=0.25d0*(rij-r0ijsq)**2
2440             fac=rij-r0ijsq
2441           else
2442             evdw1ij=0.0d0
2443             fac=0.0d0
2444           endif
2445           evdw1=evdw1+evdw1ij*sss
2446 C
2447 C Calculate contributions to the Cartesian gradient.
2448 C
2449           ggg(1)=fac*xj*sssgrad
2450           ggg(2)=fac*yj*sssgrad
2451           ggg(3)=fac*zj*sssgrad
2452           do k=1,3
2453             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2454             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2455           enddo
2456 *
2457 * Loop over residues i+1 thru j-1.
2458 *
2459 cgrad          do k=i+1,j-1
2460 cgrad            do l=1,3
2461 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2462 cgrad            enddo
2463 cgrad          enddo
2464         enddo ! j
2465       enddo   ! i
2466 cgrad      do i=nnt,nct-1
2467 cgrad        do k=1,3
2468 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2469 cgrad        enddo
2470 cgrad        do j=i+1,nct-1
2471 cgrad          do k=1,3
2472 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2473 cgrad          enddo
2474 cgrad        enddo
2475 cgrad      enddo
2476       return
2477       end
2478 c------------------------------------------------------------------------------
2479       subroutine vec_and_deriv
2480       implicit real*8 (a-h,o-z)
2481       include 'DIMENSIONS'
2482 #ifdef MPI
2483       include 'mpif.h'
2484 #endif
2485       include 'COMMON.IOUNITS'
2486       include 'COMMON.GEO'
2487       include 'COMMON.VAR'
2488       include 'COMMON.LOCAL'
2489       include 'COMMON.CHAIN'
2490       include 'COMMON.VECTORS'
2491       include 'COMMON.SETUP'
2492       include 'COMMON.TIME1'
2493       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2494 C Compute the local reference systems. For reference system (i), the
2495 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2496 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2497 #ifdef PARVEC
2498       do i=ivec_start,ivec_end
2499 #else
2500       do i=1,nres-1
2501 #endif
2502           if (i.eq.nres-1) then
2503 C Case of the last full residue
2504 C Compute the Z-axis
2505             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2506             costh=dcos(pi-theta(nres))
2507             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2508             do k=1,3
2509               uz(k,i)=fac*uz(k,i)
2510             enddo
2511 C Compute the derivatives of uz
2512             uzder(1,1,1)= 0.0d0
2513             uzder(2,1,1)=-dc_norm(3,i-1)
2514             uzder(3,1,1)= dc_norm(2,i-1)
2515             uzder(1,2,1)= dc_norm(3,i-1)
2516             uzder(2,2,1)= 0.0d0
2517             uzder(3,2,1)=-dc_norm(1,i-1)
2518             uzder(1,3,1)=-dc_norm(2,i-1)
2519             uzder(2,3,1)= dc_norm(1,i-1)
2520             uzder(3,3,1)= 0.0d0
2521             uzder(1,1,2)= 0.0d0
2522             uzder(2,1,2)= dc_norm(3,i)
2523             uzder(3,1,2)=-dc_norm(2,i)
2524             uzder(1,2,2)=-dc_norm(3,i)
2525             uzder(2,2,2)= 0.0d0
2526             uzder(3,2,2)= dc_norm(1,i)
2527             uzder(1,3,2)= dc_norm(2,i)
2528             uzder(2,3,2)=-dc_norm(1,i)
2529             uzder(3,3,2)= 0.0d0
2530 C Compute the Y-axis
2531             facy=fac
2532             do k=1,3
2533               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2534             enddo
2535 C Compute the derivatives of uy
2536             do j=1,3
2537               do k=1,3
2538                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2539      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2540                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2541               enddo
2542               uyder(j,j,1)=uyder(j,j,1)-costh
2543               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2544             enddo
2545             do j=1,2
2546               do k=1,3
2547                 do l=1,3
2548                   uygrad(l,k,j,i)=uyder(l,k,j)
2549                   uzgrad(l,k,j,i)=uzder(l,k,j)
2550                 enddo
2551               enddo
2552             enddo
2553             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2554             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2555             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2556             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2557           else
2558 C Other residues
2559 C Compute the Z-axis
2560             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2561             costh=dcos(pi-theta(i+2))
2562             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2563             do k=1,3
2564               uz(k,i)=fac*uz(k,i)
2565             enddo
2566 C Compute the derivatives of uz
2567             uzder(1,1,1)= 0.0d0
2568             uzder(2,1,1)=-dc_norm(3,i+1)
2569             uzder(3,1,1)= dc_norm(2,i+1)
2570             uzder(1,2,1)= dc_norm(3,i+1)
2571             uzder(2,2,1)= 0.0d0
2572             uzder(3,2,1)=-dc_norm(1,i+1)
2573             uzder(1,3,1)=-dc_norm(2,i+1)
2574             uzder(2,3,1)= dc_norm(1,i+1)
2575             uzder(3,3,1)= 0.0d0
2576             uzder(1,1,2)= 0.0d0
2577             uzder(2,1,2)= dc_norm(3,i)
2578             uzder(3,1,2)=-dc_norm(2,i)
2579             uzder(1,2,2)=-dc_norm(3,i)
2580             uzder(2,2,2)= 0.0d0
2581             uzder(3,2,2)= dc_norm(1,i)
2582             uzder(1,3,2)= dc_norm(2,i)
2583             uzder(2,3,2)=-dc_norm(1,i)
2584             uzder(3,3,2)= 0.0d0
2585 C Compute the Y-axis
2586             facy=fac
2587             do k=1,3
2588               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2589             enddo
2590 C Compute the derivatives of uy
2591             do j=1,3
2592               do k=1,3
2593                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2594      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2595                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2596               enddo
2597               uyder(j,j,1)=uyder(j,j,1)-costh
2598               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2599             enddo
2600             do j=1,2
2601               do k=1,3
2602                 do l=1,3
2603                   uygrad(l,k,j,i)=uyder(l,k,j)
2604                   uzgrad(l,k,j,i)=uzder(l,k,j)
2605                 enddo
2606               enddo
2607             enddo
2608             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2609             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2610             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2611             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2612           endif
2613       enddo
2614       do i=1,nres-1
2615         vbld_inv_temp(1)=vbld_inv(i+1)
2616         if (i.lt.nres-1) then
2617           vbld_inv_temp(2)=vbld_inv(i+2)
2618           else
2619           vbld_inv_temp(2)=vbld_inv(i)
2620           endif
2621         do j=1,2
2622           do k=1,3
2623             do l=1,3
2624               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2625               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2626             enddo
2627           enddo
2628         enddo
2629       enddo
2630 #if defined(PARVEC) && defined(MPI)
2631       if (nfgtasks1.gt.1) then
2632         time00=MPI_Wtime()
2633 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2634 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2635 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2636         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2637      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2638      &   FG_COMM1,IERR)
2639         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2640      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2641      &   FG_COMM1,IERR)
2642         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2643      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2644      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2645         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2646      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2647      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2648         time_gather=time_gather+MPI_Wtime()-time00
2649       endif
2650 c      if (fg_rank.eq.0) then
2651 c        write (iout,*) "Arrays UY and UZ"
2652 c        do i=1,nres-1
2653 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2654 c     &     (uz(k,i),k=1,3)
2655 c        enddo
2656 c      endif
2657 #endif
2658       return
2659       end
2660 C-----------------------------------------------------------------------------
2661       subroutine check_vecgrad
2662       implicit real*8 (a-h,o-z)
2663       include 'DIMENSIONS'
2664       include 'COMMON.IOUNITS'
2665       include 'COMMON.GEO'
2666       include 'COMMON.VAR'
2667       include 'COMMON.LOCAL'
2668       include 'COMMON.CHAIN'
2669       include 'COMMON.VECTORS'
2670       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2671       dimension uyt(3,maxres),uzt(3,maxres)
2672       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2673       double precision delta /1.0d-7/
2674       call vec_and_deriv
2675 cd      do i=1,nres
2676 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2677 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2678 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2679 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2680 cd     &     (dc_norm(if90,i),if90=1,3)
2681 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2682 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2683 cd          write(iout,'(a)')
2684 cd      enddo
2685       do i=1,nres
2686         do j=1,2
2687           do k=1,3
2688             do l=1,3
2689               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2690               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2691             enddo
2692           enddo
2693         enddo
2694       enddo
2695       call vec_and_deriv
2696       do i=1,nres
2697         do j=1,3
2698           uyt(j,i)=uy(j,i)
2699           uzt(j,i)=uz(j,i)
2700         enddo
2701       enddo
2702       do i=1,nres
2703 cd        write (iout,*) 'i=',i
2704         do k=1,3
2705           erij(k)=dc_norm(k,i)
2706         enddo
2707         do j=1,3
2708           do k=1,3
2709             dc_norm(k,i)=erij(k)
2710           enddo
2711           dc_norm(j,i)=dc_norm(j,i)+delta
2712 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2713 c          do k=1,3
2714 c            dc_norm(k,i)=dc_norm(k,i)/fac
2715 c          enddo
2716 c          write (iout,*) (dc_norm(k,i),k=1,3)
2717 c          write (iout,*) (erij(k),k=1,3)
2718           call vec_and_deriv
2719           do k=1,3
2720             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2721             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2722             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2723             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2724           enddo
2725 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2726 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2727 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2728         enddo
2729         do k=1,3
2730           dc_norm(k,i)=erij(k)
2731         enddo
2732 cd        do k=1,3
2733 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2734 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2735 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2736 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2737 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2738 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2739 cd          write (iout,'(a)')
2740 cd        enddo
2741       enddo
2742       return
2743       end
2744 C--------------------------------------------------------------------------
2745       subroutine set_matrices
2746       implicit real*8 (a-h,o-z)
2747       include 'DIMENSIONS'
2748 #ifdef MPI
2749       include "mpif.h"
2750       include "COMMON.SETUP"
2751       integer IERR
2752       integer status(MPI_STATUS_SIZE)
2753 #endif
2754       include 'COMMON.IOUNITS'
2755       include 'COMMON.GEO'
2756       include 'COMMON.VAR'
2757       include 'COMMON.LOCAL'
2758       include 'COMMON.CHAIN'
2759       include 'COMMON.DERIV'
2760       include 'COMMON.INTERACT'
2761       include 'COMMON.CONTACTS'
2762       include 'COMMON.TORSION'
2763       include 'COMMON.VECTORS'
2764       include 'COMMON.FFIELD'
2765       double precision auxvec(2),auxmat(2,2)
2766 C
2767 C Compute the virtual-bond-torsional-angle dependent quantities needed
2768 C to calculate the el-loc multibody terms of various order.
2769 C
2770 c      write(iout,*) 'nphi=',nphi,nres
2771 #ifdef PARMAT
2772       do i=ivec_start+2,ivec_end+2
2773 #else
2774       do i=3,nres+1
2775 #endif
2776 #ifdef NEWCORR
2777         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2778           iti = itortyp(itype(i-2))
2779         else
2780           iti=ntortyp+1
2781         endif
2782 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2783         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2784           iti1 = itortyp(itype(i-1))
2785         else
2786           iti1=ntortyp+1
2787         endif
2788 c        write(iout,*),i
2789         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2790      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2791      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2792         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2793      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2794      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2795 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2796 c     &*(cos(theta(i)/2.0)
2797         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2798      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2799      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2800 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2801 c     &*(cos(theta(i)/2.0)
2802         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2803      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2804      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2805 c        if (ggb1(1,i).eq.0.0d0) then
2806 c        write(iout,*) 'i=',i,ggb1(1,i),
2807 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2808 c     &bnew1(2,1,iti)*cos(theta(i)),
2809 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2810 c        endif
2811         b1(2,i-2)=bnew1(1,2,iti)
2812         gtb1(2,i-2)=0.0
2813         b2(2,i-2)=bnew2(1,2,iti)
2814         gtb2(2,i-2)=0.0
2815         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2816         EE(1,2,i-2)=eeold(1,2,iti)
2817         EE(2,1,i-2)=eeold(2,1,iti)
2818         EE(2,2,i-2)=eeold(2,2,iti)
2819         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2820         gtEE(1,2,i-2)=0.0d0
2821         gtEE(2,2,i-2)=0.0d0
2822         gtEE(2,1,i-2)=0.0d0
2823 c        EE(2,2,iti)=0.0d0
2824 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2825 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2826 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2827 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2828        b1tilde(1,i-2)=b1(1,i-2)
2829        b1tilde(2,i-2)=-b1(2,i-2)
2830        b2tilde(1,i-2)=b2(1,i-2)
2831        b2tilde(2,i-2)=-b2(2,i-2)
2832 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2833 c       write(iout,*)  'b1=',b1(1,i-2)
2834 c       write (iout,*) 'theta=', theta(i-1)
2835        enddo
2836 #else
2837         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2838           iti = itortyp(itype(i-2))
2839         else
2840           iti=ntortyp+1
2841         endif
2842 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2843         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2844           iti1 = itortyp(itype(i-1))
2845         else
2846           iti1=ntortyp+1
2847         endif
2848         b1(1,i-2)=b(3,iti)
2849         b1(2,i-2)=b(5,iti)
2850         b2(1,i-2)=b(2,iti)
2851         b2(2,i-2)=b(4,iti)
2852        b1tilde(1,i-2)=b1(1,i-2)
2853        b1tilde(2,i-2)=-b1(2,i-2)
2854        b2tilde(1,i-2)=b2(1,i-2)
2855        b2tilde(2,i-2)=-b2(2,i-2)
2856         EE(1,2,i-2)=eeold(1,2,iti)
2857         EE(2,1,i-2)=eeold(2,1,iti)
2858         EE(2,2,i-2)=eeold(2,2,iti)
2859         EE(1,1,i-2)=eeold(1,1,iti)
2860       enddo
2861 #endif
2862 #ifdef PARMAT
2863       do i=ivec_start+2,ivec_end+2
2864 #else
2865       do i=3,nres+1
2866 #endif
2867         if (i .lt. nres+1) then
2868           sin1=dsin(phi(i))
2869           cos1=dcos(phi(i))
2870           sintab(i-2)=sin1
2871           costab(i-2)=cos1
2872           obrot(1,i-2)=cos1
2873           obrot(2,i-2)=sin1
2874           sin2=dsin(2*phi(i))
2875           cos2=dcos(2*phi(i))
2876           sintab2(i-2)=sin2
2877           costab2(i-2)=cos2
2878           obrot2(1,i-2)=cos2
2879           obrot2(2,i-2)=sin2
2880           Ug(1,1,i-2)=-cos1
2881           Ug(1,2,i-2)=-sin1
2882           Ug(2,1,i-2)=-sin1
2883           Ug(2,2,i-2)= cos1
2884           Ug2(1,1,i-2)=-cos2
2885           Ug2(1,2,i-2)=-sin2
2886           Ug2(2,1,i-2)=-sin2
2887           Ug2(2,2,i-2)= cos2
2888         else
2889           costab(i-2)=1.0d0
2890           sintab(i-2)=0.0d0
2891           obrot(1,i-2)=1.0d0
2892           obrot(2,i-2)=0.0d0
2893           obrot2(1,i-2)=0.0d0
2894           obrot2(2,i-2)=0.0d0
2895           Ug(1,1,i-2)=1.0d0
2896           Ug(1,2,i-2)=0.0d0
2897           Ug(2,1,i-2)=0.0d0
2898           Ug(2,2,i-2)=1.0d0
2899           Ug2(1,1,i-2)=0.0d0
2900           Ug2(1,2,i-2)=0.0d0
2901           Ug2(2,1,i-2)=0.0d0
2902           Ug2(2,2,i-2)=0.0d0
2903         endif
2904         if (i .gt. 3 .and. i .lt. nres+1) then
2905           obrot_der(1,i-2)=-sin1
2906           obrot_der(2,i-2)= cos1
2907           Ugder(1,1,i-2)= sin1
2908           Ugder(1,2,i-2)=-cos1
2909           Ugder(2,1,i-2)=-cos1
2910           Ugder(2,2,i-2)=-sin1
2911           dwacos2=cos2+cos2
2912           dwasin2=sin2+sin2
2913           obrot2_der(1,i-2)=-dwasin2
2914           obrot2_der(2,i-2)= dwacos2
2915           Ug2der(1,1,i-2)= dwasin2
2916           Ug2der(1,2,i-2)=-dwacos2
2917           Ug2der(2,1,i-2)=-dwacos2
2918           Ug2der(2,2,i-2)=-dwasin2
2919         else
2920           obrot_der(1,i-2)=0.0d0
2921           obrot_der(2,i-2)=0.0d0
2922           Ugder(1,1,i-2)=0.0d0
2923           Ugder(1,2,i-2)=0.0d0
2924           Ugder(2,1,i-2)=0.0d0
2925           Ugder(2,2,i-2)=0.0d0
2926           obrot2_der(1,i-2)=0.0d0
2927           obrot2_der(2,i-2)=0.0d0
2928           Ug2der(1,1,i-2)=0.0d0
2929           Ug2der(1,2,i-2)=0.0d0
2930           Ug2der(2,1,i-2)=0.0d0
2931           Ug2der(2,2,i-2)=0.0d0
2932         endif
2933 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2934         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2935           iti = itortyp(itype(i-2))
2936         else
2937           iti=ntortyp
2938         endif
2939 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2940         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2941           iti1 = itortyp(itype(i-1))
2942         else
2943           iti1=ntortyp
2944         endif
2945 cd        write (iout,*) '*******i',i,' iti1',iti
2946 cd        write (iout,*) 'b1',b1(:,iti)
2947 cd        write (iout,*) 'b2',b2(:,iti)
2948 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2949 c        if (i .gt. iatel_s+2) then
2950         if (i .gt. nnt+2) then
2951           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2952 #ifdef NEWCORR
2953           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2954 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2955 #endif
2956 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2957 c     &    EE(1,2,iti),EE(2,2,iti)
2958           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2959           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2960 c          write(iout,*) "Macierz EUG",
2961 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2962 c     &    eug(2,2,i-2)
2963           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2964      &    then
2965           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2966           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2967           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2968           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2969           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2970           endif
2971         else
2972           do k=1,2
2973             Ub2(k,i-2)=0.0d0
2974             Ctobr(k,i-2)=0.0d0
2975             Dtobr2(k,i-2)=0.0d0
2976             do l=1,2
2977               EUg(l,k,i-2)=0.0d0
2978               CUg(l,k,i-2)=0.0d0
2979               DUg(l,k,i-2)=0.0d0
2980               DtUg2(l,k,i-2)=0.0d0
2981             enddo
2982           enddo
2983         endif
2984         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2985         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2986         do k=1,2
2987           muder(k,i-2)=Ub2der(k,i-2)
2988         enddo
2989 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2990         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2991           if (itype(i-1).le.ntyp) then
2992             iti1 = itortyp(itype(i-1))
2993           else
2994             iti1=ntortyp
2995           endif
2996         else
2997           iti1=ntortyp
2998         endif
2999         do k=1,2
3000           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3001         enddo
3002 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
3003 c        write (iout,*) 'mu ',mu(:,i-2),i-2
3004 cd        write (iout,*) 'mu1',mu1(:,i-2)
3005 cd        write (iout,*) 'mu2',mu2(:,i-2)
3006         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3007      &  then
3008         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3009         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3010         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3011         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3012         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3013 C Vectors and matrices dependent on a single virtual-bond dihedral.
3014         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3015         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3016         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3017         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3018         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3019         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3020         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3021         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3022         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3023         endif
3024       enddo
3025 C Matrices dependent on two consecutive virtual-bond dihedrals.
3026 C The order of matrices is from left to right.
3027       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3028      &then
3029 c      do i=max0(ivec_start,2),ivec_end
3030       do i=2,nres-1
3031         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3032         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3033         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3034         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3035         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3036         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3037         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3038         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3039       enddo
3040       endif
3041 #if defined(MPI) && defined(PARMAT)
3042 #ifdef DEBUG
3043 c      if (fg_rank.eq.0) then
3044         write (iout,*) "Arrays UG and UGDER before GATHER"
3045         do i=1,nres-1
3046           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3047      &     ((ug(l,k,i),l=1,2),k=1,2),
3048      &     ((ugder(l,k,i),l=1,2),k=1,2)
3049         enddo
3050         write (iout,*) "Arrays UG2 and UG2DER"
3051         do i=1,nres-1
3052           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3053      &     ((ug2(l,k,i),l=1,2),k=1,2),
3054      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3055         enddo
3056         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3057         do i=1,nres-1
3058           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3059      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3060      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3061         enddo
3062         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3063         do i=1,nres-1
3064           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3065      &     costab(i),sintab(i),costab2(i),sintab2(i)
3066         enddo
3067         write (iout,*) "Array MUDER"
3068         do i=1,nres-1
3069           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3070         enddo
3071 c      endif
3072 #endif
3073       if (nfgtasks.gt.1) then
3074         time00=MPI_Wtime()
3075 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3076 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3077 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3078 #ifdef MATGATHER
3079         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3098      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3099      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3100         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3101      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3102      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3103         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3104      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3105      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3106         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3107      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3108      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3109         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3110      &  then
3111         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3112      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3113      &   FG_COMM1,IERR)
3114         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3115      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3116      &   FG_COMM1,IERR)
3117         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3118      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3119      &   FG_COMM1,IERR)
3120        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3121      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3122      &   FG_COMM1,IERR)
3123         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3124      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3125      &   FG_COMM1,IERR)
3126         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3127      &   ivec_count(fg_rank1),
3128      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3129      &   FG_COMM1,IERR)
3130         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3131      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3132      &   FG_COMM1,IERR)
3133         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3134      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3135      &   FG_COMM1,IERR)
3136         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3137      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3138      &   FG_COMM1,IERR)
3139         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3140      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3141      &   FG_COMM1,IERR)
3142         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3143      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3144      &   FG_COMM1,IERR)
3145         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3146      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3147      &   FG_COMM1,IERR)
3148         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3149      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3150      &   FG_COMM1,IERR)
3151         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3152      &   ivec_count(fg_rank1),
3153      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3154      &   FG_COMM1,IERR)
3155         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3156      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3157      &   FG_COMM1,IERR)
3158        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3159      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3160      &   FG_COMM1,IERR)
3161         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3162      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3163      &   FG_COMM1,IERR)
3164        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3165      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3166      &   FG_COMM1,IERR)
3167         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3168      &   ivec_count(fg_rank1),
3169      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3170      &   FG_COMM1,IERR)
3171         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3172      &   ivec_count(fg_rank1),
3173      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3174      &   FG_COMM1,IERR)
3175         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3176      &   ivec_count(fg_rank1),
3177      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3178      &   MPI_MAT2,FG_COMM1,IERR)
3179         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3180      &   ivec_count(fg_rank1),
3181      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3182      &   MPI_MAT2,FG_COMM1,IERR)
3183         endif
3184 #else
3185 c Passes matrix info through the ring
3186       isend=fg_rank1
3187       irecv=fg_rank1-1
3188       if (irecv.lt.0) irecv=nfgtasks1-1
3189       iprev=irecv
3190       inext=fg_rank1+1
3191       if (inext.ge.nfgtasks1) inext=0
3192       do i=1,nfgtasks1-1
3193 c        write (iout,*) "isend",isend," irecv",irecv
3194 c        call flush(iout)
3195         lensend=lentyp(isend)
3196         lenrecv=lentyp(irecv)
3197 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3198 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3199 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3200 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3201 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3202 c        write (iout,*) "Gather ROTAT1"
3203 c        call flush(iout)
3204 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3205 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3206 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3207 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3208 c        write (iout,*) "Gather ROTAT2"
3209 c        call flush(iout)
3210         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3211      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3212      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3213      &   iprev,4400+irecv,FG_COMM,status,IERR)
3214 c        write (iout,*) "Gather ROTAT_OLD"
3215 c        call flush(iout)
3216         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3217      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3218      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3219      &   iprev,5500+irecv,FG_COMM,status,IERR)
3220 c        write (iout,*) "Gather PRECOMP11"
3221 c        call flush(iout)
3222         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3223      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3224      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3225      &   iprev,6600+irecv,FG_COMM,status,IERR)
3226 c        write (iout,*) "Gather PRECOMP12"
3227 c        call flush(iout)
3228         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3229      &  then
3230         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3231      &   MPI_ROTAT2(lensend),inext,7700+isend,
3232      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3233      &   iprev,7700+irecv,FG_COMM,status,IERR)
3234 c        write (iout,*) "Gather PRECOMP21"
3235 c        call flush(iout)
3236         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3237      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3238      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3239      &   iprev,8800+irecv,FG_COMM,status,IERR)
3240 c        write (iout,*) "Gather PRECOMP22"
3241 c        call flush(iout)
3242         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3243      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3244      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3245      &   MPI_PRECOMP23(lenrecv),
3246      &   iprev,9900+irecv,FG_COMM,status,IERR)
3247 c        write (iout,*) "Gather PRECOMP23"
3248 c        call flush(iout)
3249         endif
3250         isend=irecv
3251         irecv=irecv-1
3252         if (irecv.lt.0) irecv=nfgtasks1-1
3253       enddo
3254 #endif
3255         time_gather=time_gather+MPI_Wtime()-time00
3256       endif
3257 #ifdef DEBUG
3258 c      if (fg_rank.eq.0) then
3259         write (iout,*) "Arrays UG and UGDER"
3260         do i=1,nres-1
3261           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3262      &     ((ug(l,k,i),l=1,2),k=1,2),
3263      &     ((ugder(l,k,i),l=1,2),k=1,2)
3264         enddo
3265         write (iout,*) "Arrays UG2 and UG2DER"
3266         do i=1,nres-1
3267           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3268      &     ((ug2(l,k,i),l=1,2),k=1,2),
3269      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3270         enddo
3271         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3272         do i=1,nres-1
3273           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3274      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3275      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3276         enddo
3277         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3278         do i=1,nres-1
3279           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3280      &     costab(i),sintab(i),costab2(i),sintab2(i)
3281         enddo
3282         write (iout,*) "Array MUDER"
3283         do i=1,nres-1
3284           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3285         enddo
3286 c      endif
3287 #endif
3288 #endif
3289 cd      do i=1,nres
3290 cd        iti = itortyp(itype(i))
3291 cd        write (iout,*) i
3292 cd        do j=1,2
3293 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3294 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3295 cd        enddo
3296 cd      enddo
3297       return
3298       end
3299 C--------------------------------------------------------------------------
3300       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3301 C
3302 C This subroutine calculates the average interaction energy and its gradient
3303 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3304 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3305 C The potential depends both on the distance of peptide-group centers and on
3306 C the orientation of the CA-CA virtual bonds.
3307 C
3308       implicit real*8 (a-h,o-z)
3309 #ifdef MPI
3310       include 'mpif.h'
3311 #endif
3312       include 'DIMENSIONS'
3313       include 'COMMON.CONTROL'
3314       include 'COMMON.SETUP'
3315       include 'COMMON.IOUNITS'
3316       include 'COMMON.GEO'
3317       include 'COMMON.VAR'
3318       include 'COMMON.LOCAL'
3319       include 'COMMON.CHAIN'
3320       include 'COMMON.DERIV'
3321       include 'COMMON.INTERACT'
3322       include 'COMMON.CONTACTS'
3323       include 'COMMON.TORSION'
3324       include 'COMMON.VECTORS'
3325       include 'COMMON.FFIELD'
3326       include 'COMMON.TIME1'
3327       include 'COMMON.SPLITELE'
3328       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3329      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3330       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3331      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3332       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3333      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3334      &    num_conti,j1,j2
3335 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3336 #ifdef MOMENT
3337       double precision scal_el /1.0d0/
3338 #else
3339       double precision scal_el /0.5d0/
3340 #endif
3341 C 12/13/98
3342 C 13-go grudnia roku pamietnego...
3343       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3344      &                   0.0d0,1.0d0,0.0d0,
3345      &                   0.0d0,0.0d0,1.0d0/
3346 cd      write(iout,*) 'In EELEC'
3347 cd      do i=1,nloctyp
3348 cd        write(iout,*) 'Type',i
3349 cd        write(iout,*) 'B1',B1(:,i)
3350 cd        write(iout,*) 'B2',B2(:,i)
3351 cd        write(iout,*) 'CC',CC(:,:,i)
3352 cd        write(iout,*) 'DD',DD(:,:,i)
3353 cd        write(iout,*) 'EE',EE(:,:,i)
3354 cd      enddo
3355 cd      call check_vecgrad
3356 cd      stop
3357       if (icheckgrad.eq.1) then
3358         do i=1,nres-1
3359           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3360           do k=1,3
3361             dc_norm(k,i)=dc(k,i)*fac
3362           enddo
3363 c          write (iout,*) 'i',i,' fac',fac
3364         enddo
3365       endif
3366       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3367      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3368      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3369 c        call vec_and_deriv
3370 #ifdef TIMING
3371         time01=MPI_Wtime()
3372 #endif
3373         call set_matrices
3374 #ifdef TIMING
3375         time_mat=time_mat+MPI_Wtime()-time01
3376 #endif
3377       endif
3378 cd      do i=1,nres-1
3379 cd        write (iout,*) 'i=',i
3380 cd        do k=1,3
3381 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3382 cd        enddo
3383 cd        do k=1,3
3384 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3385 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3386 cd        enddo
3387 cd      enddo
3388       t_eelecij=0.0d0
3389       ees=0.0D0
3390       evdw1=0.0D0
3391       eel_loc=0.0d0
3392       eello_turn3=0.0d0
3393       eello_turn4=0.0d0
3394       ind=0
3395       do i=1,nres
3396         num_cont_hb(i)=0
3397       enddo
3398 cd      print '(a)','Enter EELEC'
3399 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3400       do i=1,nres
3401         gel_loc_loc(i)=0.0d0
3402         gcorr_loc(i)=0.0d0
3403       enddo
3404 c
3405 c
3406 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3407 C
3408 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3409 C
3410 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3411       do i=iturn3_start,iturn3_end
3412         if (i.le.1) cycle
3413 C        write(iout,*) "tu jest i",i
3414         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3415 C changes suggested by Ana to avoid out of bounds
3416      & .or.((i+4).gt.nres)
3417      & .or.((i-1).le.0)
3418 C end of changes by Ana
3419      &  .or. itype(i+2).eq.ntyp1
3420      &  .or. itype(i+3).eq.ntyp1) cycle
3421         if(i.gt.1)then
3422           if(itype(i-1).eq.ntyp1)cycle
3423         end if
3424         if(i.LT.nres-3)then
3425           if (itype(i+4).eq.ntyp1) cycle
3426         end if
3427         dxi=dc(1,i)
3428         dyi=dc(2,i)
3429         dzi=dc(3,i)
3430         dx_normi=dc_norm(1,i)
3431         dy_normi=dc_norm(2,i)
3432         dz_normi=dc_norm(3,i)
3433         xmedi=c(1,i)+0.5d0*dxi
3434         ymedi=c(2,i)+0.5d0*dyi
3435         zmedi=c(3,i)+0.5d0*dzi
3436           xmedi=mod(xmedi,boxxsize)
3437           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3438           ymedi=mod(ymedi,boxysize)
3439           if (ymedi.lt.0) ymedi=ymedi+boxysize
3440           zmedi=mod(zmedi,boxzsize)
3441           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3442         num_conti=0
3443         call eelecij(i,i+2,ees,evdw1,eel_loc)
3444         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3445         num_cont_hb(i)=num_conti
3446       enddo
3447       do i=iturn4_start,iturn4_end
3448         if (i.le.1) cycle
3449         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3450 C changes suggested by Ana to avoid out of bounds
3451      & .or.((i+5).gt.nres)
3452      & .or.((i-1).le.0)
3453 C end of changes suggested by Ana
3454      &    .or. itype(i+3).eq.ntyp1
3455      &    .or. itype(i+4).eq.ntyp1
3456      &    .or. itype(i+5).eq.ntyp1
3457      &    .or. itype(i).eq.ntyp1
3458      &    .or. itype(i-1).eq.ntyp1
3459      &                             ) cycle
3460         dxi=dc(1,i)
3461         dyi=dc(2,i)
3462         dzi=dc(3,i)
3463         dx_normi=dc_norm(1,i)
3464         dy_normi=dc_norm(2,i)
3465         dz_normi=dc_norm(3,i)
3466         xmedi=c(1,i)+0.5d0*dxi
3467         ymedi=c(2,i)+0.5d0*dyi
3468         zmedi=c(3,i)+0.5d0*dzi
3469 C Return atom into box, boxxsize is size of box in x dimension
3470 c  194   continue
3471 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3472 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3473 C Condition for being inside the proper box
3474 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3475 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3476 c        go to 194
3477 c        endif
3478 c  195   continue
3479 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3480 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3481 C Condition for being inside the proper box
3482 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3483 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3484 c        go to 195
3485 c        endif
3486 c  196   continue
3487 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3488 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3489 C Condition for being inside the proper box
3490 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3491 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3492 c        go to 196
3493 c        endif
3494           xmedi=mod(xmedi,boxxsize)
3495           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3496           ymedi=mod(ymedi,boxysize)
3497           if (ymedi.lt.0) ymedi=ymedi+boxysize
3498           zmedi=mod(zmedi,boxzsize)
3499           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3500
3501         num_conti=num_cont_hb(i)
3502 c        write(iout,*) "JESTEM W PETLI"
3503         call eelecij(i,i+3,ees,evdw1,eel_loc)
3504         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3505      &   call eturn4(i,eello_turn4)
3506         num_cont_hb(i)=num_conti
3507       enddo   ! i
3508 C Loop over all neighbouring boxes
3509 C      do xshift=-1,1
3510 C      do yshift=-1,1
3511 C      do zshift=-1,1
3512 c
3513 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3514 c
3515 CTU KURWA
3516       do i=iatel_s,iatel_e
3517 C        do i=75,75
3518         if (i.le.1) cycle
3519         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3520 C changes suggested by Ana to avoid out of bounds
3521      & .or.((i+2).gt.nres)
3522      & .or.((i-1).le.0)
3523 C end of changes by Ana
3524      &  .or. itype(i+2).eq.ntyp1
3525      &  .or. itype(i-1).eq.ntyp1
3526      &                ) cycle
3527         dxi=dc(1,i)
3528         dyi=dc(2,i)
3529         dzi=dc(3,i)
3530         dx_normi=dc_norm(1,i)
3531         dy_normi=dc_norm(2,i)
3532         dz_normi=dc_norm(3,i)
3533         xmedi=c(1,i)+0.5d0*dxi
3534         ymedi=c(2,i)+0.5d0*dyi
3535         zmedi=c(3,i)+0.5d0*dzi
3536           xmedi=mod(xmedi,boxxsize)
3537           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3538           ymedi=mod(ymedi,boxysize)
3539           if (ymedi.lt.0) ymedi=ymedi+boxysize
3540           zmedi=mod(zmedi,boxzsize)
3541           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3542 C          xmedi=xmedi+xshift*boxxsize
3543 C          ymedi=ymedi+yshift*boxysize
3544 C          zmedi=zmedi+zshift*boxzsize
3545
3546 C Return tom into box, boxxsize is size of box in x dimension
3547 c  164   continue
3548 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3549 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3550 C Condition for being inside the proper box
3551 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3552 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3553 c        go to 164
3554 c        endif
3555 c  165   continue
3556 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3557 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3558 C Condition for being inside the proper box
3559 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3560 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3561 c        go to 165
3562 c        endif
3563 c  166   continue
3564 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3565 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3566 cC Condition for being inside the proper box
3567 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3568 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3569 c        go to 166
3570 c        endif
3571
3572 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3573         num_conti=num_cont_hb(i)
3574 C I TU KURWA
3575         do j=ielstart(i),ielend(i)
3576 C          do j=16,17
3577 C          write (iout,*) i,j
3578          if (j.le.1) cycle
3579           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3580 C changes suggested by Ana to avoid out of bounds
3581      & .or.((j+2).gt.nres)
3582      & .or.((j-1).le.0)
3583 C end of changes by Ana
3584      & .or.itype(j+2).eq.ntyp1
3585      & .or.itype(j-1).eq.ntyp1
3586      &) cycle
3587           call eelecij(i,j,ees,evdw1,eel_loc)
3588         enddo ! j
3589         num_cont_hb(i)=num_conti
3590       enddo   ! i
3591 C     enddo   ! zshift
3592 C      enddo   ! yshift
3593 C      enddo   ! xshift
3594
3595 c      write (iout,*) "Number of loop steps in EELEC:",ind
3596 cd      do i=1,nres
3597 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3598 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3599 cd      enddo
3600 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3601 ccc      eel_loc=eel_loc+eello_turn3
3602 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3603       return
3604       end
3605 C-------------------------------------------------------------------------------
3606       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3607       implicit real*8 (a-h,o-z)
3608       include 'DIMENSIONS'
3609 #ifdef MPI
3610       include "mpif.h"
3611 #endif
3612       include 'COMMON.CONTROL'
3613       include 'COMMON.IOUNITS'
3614       include 'COMMON.GEO'
3615       include 'COMMON.VAR'
3616       include 'COMMON.LOCAL'
3617       include 'COMMON.CHAIN'
3618       include 'COMMON.DERIV'
3619       include 'COMMON.INTERACT'
3620       include 'COMMON.CONTACTS'
3621       include 'COMMON.TORSION'
3622       include 'COMMON.VECTORS'
3623       include 'COMMON.FFIELD'
3624       include 'COMMON.TIME1'
3625       include 'COMMON.SPLITELE'
3626       include 'COMMON.SHIELD'
3627       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3628      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3629       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3630      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3631      &    gmuij2(4),gmuji2(4)
3632       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3633      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3634      &    num_conti,j1,j2
3635 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3636 #ifdef MOMENT
3637       double precision scal_el /1.0d0/
3638 #else
3639       double precision scal_el /0.5d0/
3640 #endif
3641 C 12/13/98
3642 C 13-go grudnia roku pamietnego...
3643       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3644      &                   0.0d0,1.0d0,0.0d0,
3645      &                   0.0d0,0.0d0,1.0d0/
3646 c          time00=MPI_Wtime()
3647 cd      write (iout,*) "eelecij",i,j
3648 c          ind=ind+1
3649           iteli=itel(i)
3650           itelj=itel(j)
3651           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3652           aaa=app(iteli,itelj)
3653           bbb=bpp(iteli,itelj)
3654           ael6i=ael6(iteli,itelj)
3655           ael3i=ael3(iteli,itelj)
3656           dxj=dc(1,j)
3657           dyj=dc(2,j)
3658           dzj=dc(3,j)
3659           dx_normj=dc_norm(1,j)
3660           dy_normj=dc_norm(2,j)
3661           dz_normj=dc_norm(3,j)
3662 C          xj=c(1,j)+0.5D0*dxj-xmedi
3663 C          yj=c(2,j)+0.5D0*dyj-ymedi
3664 C          zj=c(3,j)+0.5D0*dzj-zmedi
3665           xj=c(1,j)+0.5D0*dxj
3666           yj=c(2,j)+0.5D0*dyj
3667           zj=c(3,j)+0.5D0*dzj
3668           xj=mod(xj,boxxsize)
3669           if (xj.lt.0) xj=xj+boxxsize
3670           yj=mod(yj,boxysize)
3671           if (yj.lt.0) yj=yj+boxysize
3672           zj=mod(zj,boxzsize)
3673           if (zj.lt.0) zj=zj+boxzsize
3674           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3675       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3676       xj_safe=xj
3677       yj_safe=yj
3678       zj_safe=zj
3679       isubchap=0
3680       do xshift=-1,1
3681       do yshift=-1,1
3682       do zshift=-1,1
3683           xj=xj_safe+xshift*boxxsize
3684           yj=yj_safe+yshift*boxysize
3685           zj=zj_safe+zshift*boxzsize
3686           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3687           if(dist_temp.lt.dist_init) then
3688             dist_init=dist_temp
3689             xj_temp=xj
3690             yj_temp=yj
3691             zj_temp=zj
3692             isubchap=1
3693           endif
3694        enddo
3695        enddo
3696        enddo
3697        if (isubchap.eq.1) then
3698           xj=xj_temp-xmedi
3699           yj=yj_temp-ymedi
3700           zj=zj_temp-zmedi
3701        else
3702           xj=xj_safe-xmedi
3703           yj=yj_safe-ymedi
3704           zj=zj_safe-zmedi
3705        endif
3706 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3707 c  174   continue
3708 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3709 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3710 C Condition for being inside the proper box
3711 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3712 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3713 c        go to 174
3714 c        endif
3715 c  175   continue
3716 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3717 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3718 C Condition for being inside the proper box
3719 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3720 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3721 c        go to 175
3722 c        endif
3723 c  176   continue
3724 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3725 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3726 C Condition for being inside the proper box
3727 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3728 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3729 c        go to 176
3730 c        endif
3731 C        endif !endPBC condintion
3732 C        xj=xj-xmedi
3733 C        yj=yj-ymedi
3734 C        zj=zj-zmedi
3735           rij=xj*xj+yj*yj+zj*zj
3736
3737             sss=sscale(sqrt(rij))
3738             sssgrad=sscagrad(sqrt(rij))
3739 c            if (sss.gt.0.0d0) then
3740           rrmij=1.0D0/rij
3741           rij=dsqrt(rij)
3742           rmij=1.0D0/rij
3743           r3ij=rrmij*rmij
3744           r6ij=r3ij*r3ij
3745           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3746           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3747           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3748           fac=cosa-3.0D0*cosb*cosg
3749           ev1=aaa*r6ij*r6ij
3750 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3751           if (j.eq.i+2) ev1=scal_el*ev1
3752           ev2=bbb*r6ij
3753           fac3=ael6i*r6ij
3754           fac4=ael3i*r3ij
3755           evdwij=(ev1+ev2)
3756           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3757           el2=fac4*fac
3758 C MARYSIA
3759 C          eesij=(el1+el2)
3760 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3761           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3762           if (shield_mode.gt.0) then
3763 C          fac_shield(i)=0.4
3764 C          fac_shield(j)=0.6
3765           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3766           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3767           eesij=(el1+el2)
3768           ees=ees+eesij
3769           else
3770           fac_shield(i)=1.0
3771           fac_shield(j)=1.0
3772           eesij=(el1+el2)
3773           ees=ees+eesij
3774           endif
3775           evdw1=evdw1+evdwij*sss
3776 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3777 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3778 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3779 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3780
3781           if (energy_dec) then
3782               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3783      &'evdw1',i,j,evdwij
3784      &,iteli,itelj,aaa,evdw1
3785               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3786      &fac_shield(i),fac_shield(j)
3787           endif
3788
3789 C
3790 C Calculate contributions to the Cartesian gradient.
3791 C
3792 #ifdef SPLITELE
3793           facvdw=-6*rrmij*(ev1+evdwij)*sss
3794           facel=-3*rrmij*(el1+eesij)
3795           fac1=fac
3796           erij(1)=xj*rmij
3797           erij(2)=yj*rmij
3798           erij(3)=zj*rmij
3799
3800 *
3801 * Radial derivatives. First process both termini of the fragment (i,j)
3802 *
3803           ggg(1)=facel*xj
3804           ggg(2)=facel*yj
3805           ggg(3)=facel*zj
3806           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3807      &  (shield_mode.gt.0)) then
3808 C          print *,i,j
3809           do ilist=1,ishield_list(i)
3810            iresshield=shield_list(ilist,i)
3811            do k=1,3
3812            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3813      &      *2.0
3814            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3815      &              rlocshield
3816      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3817             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3818 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3819 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3820 C             if (iresshield.gt.i) then
3821 C               do ishi=i+1,iresshield-1
3822 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3823 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3824 C
3825 C              enddo
3826 C             else
3827 C               do ishi=iresshield,i
3828 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3829 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3830 C
3831 C               enddo
3832 C              endif
3833            enddo
3834           enddo
3835           do ilist=1,ishield_list(j)
3836            iresshield=shield_list(ilist,j)
3837            do k=1,3
3838            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3839      &     *2.0
3840            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3841      &              rlocshield
3842      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3843            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3844
3845 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3846 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3847 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3848 C             if (iresshield.gt.j) then
3849 C               do ishi=j+1,iresshield-1
3850 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3851 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3852 C
3853 C               enddo
3854 C            else
3855 C               do ishi=iresshield,j
3856 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3857 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3858 C               enddo
3859 C              endif
3860            enddo
3861           enddo
3862
3863           do k=1,3
3864             gshieldc(k,i)=gshieldc(k,i)+
3865      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3866             gshieldc(k,j)=gshieldc(k,j)+
3867      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3868             gshieldc(k,i-1)=gshieldc(k,i-1)+
3869      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3870             gshieldc(k,j-1)=gshieldc(k,j-1)+
3871      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3872
3873            enddo
3874            endif
3875 c          do k=1,3
3876 c            ghalf=0.5D0*ggg(k)
3877 c            gelc(k,i)=gelc(k,i)+ghalf
3878 c            gelc(k,j)=gelc(k,j)+ghalf
3879 c          enddo
3880 c 9/28/08 AL Gradient compotents will be summed only at the end
3881 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3882           do k=1,3
3883             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3884 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3885             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3886 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3887 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3888 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3889 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3890 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3891           enddo
3892 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3893
3894 *
3895 * Loop over residues i+1 thru j-1.
3896 *
3897 cgrad          do k=i+1,j-1
3898 cgrad            do l=1,3
3899 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3900 cgrad            enddo
3901 cgrad          enddo
3902           if (sss.gt.0.0) then
3903           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3904           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3905           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3906           else
3907           ggg(1)=0.0
3908           ggg(2)=0.0
3909           ggg(3)=0.0
3910           endif
3911 c          do k=1,3
3912 c            ghalf=0.5D0*ggg(k)
3913 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3914 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3915 c          enddo
3916 c 9/28/08 AL Gradient compotents will be summed only at the end
3917           do k=1,3
3918             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3919             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3920           enddo
3921 *
3922 * Loop over residues i+1 thru j-1.
3923 *
3924 cgrad          do k=i+1,j-1
3925 cgrad            do l=1,3
3926 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3927 cgrad            enddo
3928 cgrad          enddo
3929 #else
3930 C MARYSIA
3931           facvdw=(ev1+evdwij)*sss
3932           facel=(el1+eesij)
3933           fac1=fac
3934           fac=-3*rrmij*(facvdw+facvdw+facel)
3935           erij(1)=xj*rmij
3936           erij(2)=yj*rmij
3937           erij(3)=zj*rmij
3938 *
3939 * Radial derivatives. First process both termini of the fragment (i,j)
3940 *
3941           ggg(1)=fac*xj
3942 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3943           ggg(2)=fac*yj
3944 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3945           ggg(3)=fac*zj
3946 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3947 c          do k=1,3
3948 c            ghalf=0.5D0*ggg(k)
3949 c            gelc(k,i)=gelc(k,i)+ghalf
3950 c            gelc(k,j)=gelc(k,j)+ghalf
3951 c          enddo
3952 c 9/28/08 AL Gradient compotents will be summed only at the end
3953           do k=1,3
3954             gelc_long(k,j)=gelc(k,j)+ggg(k)
3955             gelc_long(k,i)=gelc(k,i)-ggg(k)
3956           enddo
3957 *
3958 * Loop over residues i+1 thru j-1.
3959 *
3960 cgrad          do k=i+1,j-1
3961 cgrad            do l=1,3
3962 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3963 cgrad            enddo
3964 cgrad          enddo
3965 c 9/28/08 AL Gradient compotents will be summed only at the end
3966           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3967           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3968           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3969           do k=1,3
3970             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3971             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3972           enddo
3973 #endif
3974 *
3975 * Angular part
3976 *
3977           ecosa=2.0D0*fac3*fac1+fac4
3978           fac4=-3.0D0*fac4
3979           fac3=-6.0D0*fac3
3980           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3981           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3982           do k=1,3
3983             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3984             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3985           enddo
3986 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3987 cd   &          (dcosg(k),k=1,3)
3988           do k=1,3
3989             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3990      &      fac_shield(i)**2*fac_shield(j)**2
3991           enddo
3992 c          do k=1,3
3993 c            ghalf=0.5D0*ggg(k)
3994 c            gelc(k,i)=gelc(k,i)+ghalf
3995 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3996 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3997 c            gelc(k,j)=gelc(k,j)+ghalf
3998 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3999 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4000 c          enddo
4001 cgrad          do k=i+1,j-1
4002 cgrad            do l=1,3
4003 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4004 cgrad            enddo
4005 cgrad          enddo
4006 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4007           do k=1,3
4008             gelc(k,i)=gelc(k,i)
4009      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4010      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4011      &           *fac_shield(i)**2*fac_shield(j)**2
4012             gelc(k,j)=gelc(k,j)
4013      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4014      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4015      &           *fac_shield(i)**2*fac_shield(j)**2
4016             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4017             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4018           enddo
4019 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4020
4021 C MARYSIA
4022 c          endif !sscale
4023           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4024      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4025      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4026 C
4027 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4028 C   energy of a peptide unit is assumed in the form of a second-order
4029 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4030 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4031 C   are computed for EVERY pair of non-contiguous peptide groups.
4032 C
4033
4034           if (j.lt.nres-1) then
4035             j1=j+1
4036             j2=j-1
4037           else
4038             j1=j-1
4039             j2=j-2
4040           endif
4041           kkk=0
4042           lll=0
4043           do k=1,2
4044             do l=1,2
4045               kkk=kkk+1
4046               muij(kkk)=mu(k,i)*mu(l,j)
4047 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4048 #ifdef NEWCORR
4049              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4050 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4051              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4052              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4053 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4054              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4055 #endif
4056             enddo
4057           enddo
4058 cd         write (iout,*) 'EELEC: i',i,' j',j
4059 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4060 cd          write(iout,*) 'muij',muij
4061           ury=scalar(uy(1,i),erij)
4062           urz=scalar(uz(1,i),erij)
4063           vry=scalar(uy(1,j),erij)
4064           vrz=scalar(uz(1,j),erij)
4065           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4066           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4067           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4068           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4069           fac=dsqrt(-ael6i)*r3ij
4070           a22=a22*fac
4071           a23=a23*fac
4072           a32=a32*fac
4073           a33=a33*fac
4074 cd          write (iout,'(4i5,4f10.5)')
4075 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4076 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4077 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4078 cd     &      uy(:,j),uz(:,j)
4079 cd          write (iout,'(4f10.5)')
4080 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4081 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4082 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4083 cd           write (iout,'(9f10.5/)')
4084 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4085 C Derivatives of the elements of A in virtual-bond vectors
4086           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4087           do k=1,3
4088             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4089             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4090             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4091             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4092             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4093             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4094             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4095             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4096             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4097             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4098             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4099             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4100           enddo
4101 C Compute radial contributions to the gradient
4102           facr=-3.0d0*rrmij
4103           a22der=a22*facr
4104           a23der=a23*facr
4105           a32der=a32*facr
4106           a33der=a33*facr
4107           agg(1,1)=a22der*xj
4108           agg(2,1)=a22der*yj
4109           agg(3,1)=a22der*zj
4110           agg(1,2)=a23der*xj
4111           agg(2,2)=a23der*yj
4112           agg(3,2)=a23der*zj
4113           agg(1,3)=a32der*xj
4114           agg(2,3)=a32der*yj
4115           agg(3,3)=a32der*zj
4116           agg(1,4)=a33der*xj
4117           agg(2,4)=a33der*yj
4118           agg(3,4)=a33der*zj
4119 C Add the contributions coming from er
4120           fac3=-3.0d0*fac
4121           do k=1,3
4122             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4123             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4124             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4125             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4126           enddo
4127           do k=1,3
4128 C Derivatives in DC(i)
4129 cgrad            ghalf1=0.5d0*agg(k,1)
4130 cgrad            ghalf2=0.5d0*agg(k,2)
4131 cgrad            ghalf3=0.5d0*agg(k,3)
4132 cgrad            ghalf4=0.5d0*agg(k,4)
4133             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4134      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4135             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4136      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4137             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4138      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4139             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4140      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4141 C Derivatives in DC(i+1)
4142             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4143      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4144             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4145      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4146             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4147      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4148             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4149      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4150 C Derivatives in DC(j)
4151             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4152      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4153             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4154      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4155             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4156      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4157             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4158      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4159 C Derivatives in DC(j+1) or DC(nres-1)
4160             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4161      &      -3.0d0*vryg(k,3)*ury)
4162             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4163      &      -3.0d0*vrzg(k,3)*ury)
4164             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4165      &      -3.0d0*vryg(k,3)*urz)
4166             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4167      &      -3.0d0*vrzg(k,3)*urz)
4168 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4169 cgrad              do l=1,4
4170 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4171 cgrad              enddo
4172 cgrad            endif
4173           enddo
4174           acipa(1,1)=a22
4175           acipa(1,2)=a23
4176           acipa(2,1)=a32
4177           acipa(2,2)=a33
4178           a22=-a22
4179           a23=-a23
4180           do l=1,2
4181             do k=1,3
4182               agg(k,l)=-agg(k,l)
4183               aggi(k,l)=-aggi(k,l)
4184               aggi1(k,l)=-aggi1(k,l)
4185               aggj(k,l)=-aggj(k,l)
4186               aggj1(k,l)=-aggj1(k,l)
4187             enddo
4188           enddo
4189           if (j.lt.nres-1) then
4190             a22=-a22
4191             a32=-a32
4192             do l=1,3,2
4193               do k=1,3
4194                 agg(k,l)=-agg(k,l)
4195                 aggi(k,l)=-aggi(k,l)
4196                 aggi1(k,l)=-aggi1(k,l)
4197                 aggj(k,l)=-aggj(k,l)
4198                 aggj1(k,l)=-aggj1(k,l)
4199               enddo
4200             enddo
4201           else
4202             a22=-a22
4203             a23=-a23
4204             a32=-a32
4205             a33=-a33
4206             do l=1,4
4207               do k=1,3
4208                 agg(k,l)=-agg(k,l)
4209                 aggi(k,l)=-aggi(k,l)
4210                 aggi1(k,l)=-aggi1(k,l)
4211                 aggj(k,l)=-aggj(k,l)
4212                 aggj1(k,l)=-aggj1(k,l)
4213               enddo
4214             enddo
4215           endif
4216           ENDIF ! WCORR
4217           IF (wel_loc.gt.0.0d0) THEN
4218 C Contribution to the local-electrostatic energy coming from the i-j pair
4219           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4220      &     +a33*muij(4)
4221           if (shield_mode.eq.0) then
4222            fac_shield(i)=1.0
4223            fac_shield(j)=1.0
4224 C          else
4225 C           fac_shield(i)=0.4
4226 C           fac_shield(j)=0.6
4227           endif
4228           eel_loc_ij=eel_loc_ij
4229      &    *fac_shield(i)*fac_shield(j)
4230 C Now derivative over eel_loc
4231           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4232      &  (shield_mode.gt.0)) then
4233 C          print *,i,j
4234
4235           do ilist=1,ishield_list(i)
4236            iresshield=shield_list(ilist,i)
4237            do k=1,3
4238            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4239      &                                          /fac_shield(i)
4240 C     &      *2.0
4241            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4242      &              rlocshield
4243      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4244             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4245      &      +rlocshield
4246            enddo
4247           enddo
4248           do ilist=1,ishield_list(j)
4249            iresshield=shield_list(ilist,j)
4250            do k=1,3
4251            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4252      &                                       /fac_shield(j)
4253 C     &     *2.0
4254            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4255      &              rlocshield
4256      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4257            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4258      &             +rlocshield
4259
4260            enddo
4261           enddo
4262
4263           do k=1,3
4264             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4265      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4266             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4267      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4268             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4269      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4270             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4271      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4272            enddo
4273            endif
4274
4275
4276 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4277 c     &                     ' eel_loc_ij',eel_loc_ij
4278 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4279 C Calculate patrial derivative for theta angle
4280 #ifdef NEWCORR
4281          geel_loc_ij=(a22*gmuij1(1)
4282      &     +a23*gmuij1(2)
4283      &     +a32*gmuij1(3)
4284      &     +a33*gmuij1(4))
4285      &    *fac_shield(i)*fac_shield(j)
4286 c         write(iout,*) "derivative over thatai"
4287 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4288 c     &   a33*gmuij1(4)
4289          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4290      &      geel_loc_ij*wel_loc
4291 c         write(iout,*) "derivative over thatai-1"
4292 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4293 c     &   a33*gmuij2(4)
4294          geel_loc_ij=
4295      &     a22*gmuij2(1)
4296      &     +a23*gmuij2(2)
4297      &     +a32*gmuij2(3)
4298      &     +a33*gmuij2(4)
4299          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4300      &      geel_loc_ij*wel_loc
4301      &    *fac_shield(i)*fac_shield(j)
4302
4303 c  Derivative over j residue
4304          geel_loc_ji=a22*gmuji1(1)
4305      &     +a23*gmuji1(2)
4306      &     +a32*gmuji1(3)
4307      &     +a33*gmuji1(4)
4308 c         write(iout,*) "derivative over thataj"
4309 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4310 c     &   a33*gmuji1(4)
4311
4312         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4313      &      geel_loc_ji*wel_loc
4314      &    *fac_shield(i)*fac_shield(j)
4315
4316          geel_loc_ji=
4317      &     +a22*gmuji2(1)
4318      &     +a23*gmuji2(2)
4319      &     +a32*gmuji2(3)
4320      &     +a33*gmuji2(4)
4321 c         write(iout,*) "derivative over thataj-1"
4322 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4323 c     &   a33*gmuji2(4)
4324          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4325      &      geel_loc_ji*wel_loc
4326      &    *fac_shield(i)*fac_shield(j)
4327 #endif
4328 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4329
4330           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4331      &            'eelloc',i,j,eel_loc_ij
4332 c           if (eel_loc_ij.ne.0)
4333 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4334 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4335
4336           eel_loc=eel_loc+eel_loc_ij
4337 C Partial derivatives in virtual-bond dihedral angles gamma
4338           if (i.gt.1)
4339      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4340      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4341      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4342      &    *fac_shield(i)*fac_shield(j)
4343
4344           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4345      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4346      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4347      &    *fac_shield(i)*fac_shield(j)
4348 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4349           do l=1,3
4350             ggg(l)=(agg(l,1)*muij(1)+
4351      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4352      &    *fac_shield(i)*fac_shield(j)
4353             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4354             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4355 cgrad            ghalf=0.5d0*ggg(l)
4356 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4357 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4358           enddo
4359 cgrad          do k=i+1,j2
4360 cgrad            do l=1,3
4361 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4362 cgrad            enddo
4363 cgrad          enddo
4364 C Remaining derivatives of eello
4365           do l=1,3
4366             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4367      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4368      &    *fac_shield(i)*fac_shield(j)
4369
4370             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4371      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4372      &    *fac_shield(i)*fac_shield(j)
4373
4374             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4375      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4376      &    *fac_shield(i)*fac_shield(j)
4377
4378             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4379      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4380      &    *fac_shield(i)*fac_shield(j)
4381
4382           enddo
4383           ENDIF
4384 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4385 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4386           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4387      &       .and. num_conti.le.maxconts) then
4388 c            write (iout,*) i,j," entered corr"
4389 C
4390 C Calculate the contact function. The ith column of the array JCONT will
4391 C contain the numbers of atoms that make contacts with the atom I (of numbers
4392 C greater than I). The arrays FACONT and GACONT will contain the values of
4393 C the contact function and its derivative.
4394 c           r0ij=1.02D0*rpp(iteli,itelj)
4395 c           r0ij=1.11D0*rpp(iteli,itelj)
4396             r0ij=2.20D0*rpp(iteli,itelj)
4397 c           r0ij=1.55D0*rpp(iteli,itelj)
4398             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4399             if (fcont.gt.0.0D0) then
4400               num_conti=num_conti+1
4401               if (num_conti.gt.maxconts) then
4402                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4403      &                         ' will skip next contacts for this conf.'
4404               else
4405                 jcont_hb(num_conti,i)=j
4406 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4407 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4408                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4409      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4410 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4411 C  terms.
4412                 d_cont(num_conti,i)=rij
4413 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4414 C     --- Electrostatic-interaction matrix ---
4415                 a_chuj(1,1,num_conti,i)=a22
4416                 a_chuj(1,2,num_conti,i)=a23
4417                 a_chuj(2,1,num_conti,i)=a32
4418                 a_chuj(2,2,num_conti,i)=a33
4419 C     --- Gradient of rij
4420                 do kkk=1,3
4421                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4422                 enddo
4423                 kkll=0
4424                 do k=1,2
4425                   do l=1,2
4426                     kkll=kkll+1
4427                     do m=1,3
4428                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4429                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4430                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4431                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4432                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4433                     enddo
4434                   enddo
4435                 enddo
4436                 ENDIF
4437                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4438 C Calculate contact energies
4439                 cosa4=4.0D0*cosa
4440                 wij=cosa-3.0D0*cosb*cosg
4441                 cosbg1=cosb+cosg
4442                 cosbg2=cosb-cosg
4443 c               fac3=dsqrt(-ael6i)/r0ij**3
4444                 fac3=dsqrt(-ael6i)*r3ij
4445 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4446                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4447                 if (ees0tmp.gt.0) then
4448                   ees0pij=dsqrt(ees0tmp)
4449                 else
4450                   ees0pij=0
4451                 endif
4452 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4453                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4454                 if (ees0tmp.gt.0) then
4455                   ees0mij=dsqrt(ees0tmp)
4456                 else
4457                   ees0mij=0
4458                 endif
4459 c               ees0mij=0.0D0
4460                 if (shield_mode.eq.0) then
4461                 fac_shield(i)=1.0d0
4462                 fac_shield(j)=1.0d0
4463                 else
4464                 ees0plist(num_conti,i)=j
4465 C                fac_shield(i)=0.4d0
4466 C                fac_shield(j)=0.6d0
4467                 endif
4468                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4469      &          *fac_shield(i)*fac_shield(j)
4470                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4471      &          *fac_shield(i)*fac_shield(j)
4472 C Diagnostics. Comment out or remove after debugging!
4473 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4474 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4475 c               ees0m(num_conti,i)=0.0D0
4476 C End diagnostics.
4477 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4478 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4479 C Angular derivatives of the contact function
4480                 ees0pij1=fac3/ees0pij
4481                 ees0mij1=fac3/ees0mij
4482                 fac3p=-3.0D0*fac3*rrmij
4483                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4484                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4485 c               ees0mij1=0.0D0
4486                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4487                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4488                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4489                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4490                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4491                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4492                 ecosap=ecosa1+ecosa2
4493                 ecosbp=ecosb1+ecosb2
4494                 ecosgp=ecosg1+ecosg2
4495                 ecosam=ecosa1-ecosa2
4496                 ecosbm=ecosb1-ecosb2
4497                 ecosgm=ecosg1-ecosg2
4498 C Diagnostics
4499 c               ecosap=ecosa1
4500 c               ecosbp=ecosb1
4501 c               ecosgp=ecosg1
4502 c               ecosam=0.0D0
4503 c               ecosbm=0.0D0
4504 c               ecosgm=0.0D0
4505 C End diagnostics
4506                 facont_hb(num_conti,i)=fcont
4507                 fprimcont=fprimcont/rij
4508 cd              facont_hb(num_conti,i)=1.0D0
4509 C Following line is for diagnostics.
4510 cd              fprimcont=0.0D0
4511                 do k=1,3
4512                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4513                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4514                 enddo
4515                 do k=1,3
4516                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4517                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4518                 enddo
4519                 gggp(1)=gggp(1)+ees0pijp*xj
4520                 gggp(2)=gggp(2)+ees0pijp*yj
4521                 gggp(3)=gggp(3)+ees0pijp*zj
4522                 gggm(1)=gggm(1)+ees0mijp*xj
4523                 gggm(2)=gggm(2)+ees0mijp*yj
4524                 gggm(3)=gggm(3)+ees0mijp*zj
4525 C Derivatives due to the contact function
4526                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4527                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4528                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4529                 do k=1,3
4530 c
4531 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4532 c          following the change of gradient-summation algorithm.
4533 c
4534 cgrad                  ghalfp=0.5D0*gggp(k)
4535 cgrad                  ghalfm=0.5D0*gggm(k)
4536                   gacontp_hb1(k,num_conti,i)=!ghalfp
4537      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4538      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4539      &          *fac_shield(i)*fac_shield(j)
4540
4541                   gacontp_hb2(k,num_conti,i)=!ghalfp
4542      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4543      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4544      &          *fac_shield(i)*fac_shield(j)
4545
4546                   gacontp_hb3(k,num_conti,i)=gggp(k)
4547      &          *fac_shield(i)*fac_shield(j)
4548
4549                   gacontm_hb1(k,num_conti,i)=!ghalfm
4550      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4551      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4552      &          *fac_shield(i)*fac_shield(j)
4553
4554                   gacontm_hb2(k,num_conti,i)=!ghalfm
4555      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4556      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4557      &          *fac_shield(i)*fac_shield(j)
4558
4559                   gacontm_hb3(k,num_conti,i)=gggm(k)
4560      &          *fac_shield(i)*fac_shield(j)
4561
4562                 enddo
4563 C Diagnostics. Comment out or remove after debugging!
4564 cdiag           do k=1,3
4565 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4566 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4567 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4568 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4569 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4570 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4571 cdiag           enddo
4572               ENDIF ! wcorr
4573               endif  ! num_conti.le.maxconts
4574             endif  ! fcont.gt.0
4575           endif    ! j.gt.i+1
4576           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4577             do k=1,4
4578               do l=1,3
4579                 ghalf=0.5d0*agg(l,k)
4580                 aggi(l,k)=aggi(l,k)+ghalf
4581                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4582                 aggj(l,k)=aggj(l,k)+ghalf
4583               enddo
4584             enddo
4585             if (j.eq.nres-1 .and. i.lt.j-2) then
4586               do k=1,4
4587                 do l=1,3
4588                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4589                 enddo
4590               enddo
4591             endif
4592           endif
4593 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4594       return
4595       end
4596 C-----------------------------------------------------------------------------
4597       subroutine eturn3(i,eello_turn3)
4598 C Third- and fourth-order contributions from turns
4599       implicit real*8 (a-h,o-z)
4600       include 'DIMENSIONS'
4601       include 'COMMON.IOUNITS'
4602       include 'COMMON.GEO'
4603       include 'COMMON.VAR'
4604       include 'COMMON.LOCAL'
4605       include 'COMMON.CHAIN'
4606       include 'COMMON.DERIV'
4607       include 'COMMON.INTERACT'
4608       include 'COMMON.CONTACTS'
4609       include 'COMMON.TORSION'
4610       include 'COMMON.VECTORS'
4611       include 'COMMON.FFIELD'
4612       include 'COMMON.CONTROL'
4613       include 'COMMON.SHIELD'
4614       dimension ggg(3)
4615       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4616      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4617      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4618      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4619      &  auxgmat2(2,2),auxgmatt2(2,2)
4620       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4621      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4622       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4623      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4624      &    num_conti,j1,j2
4625       j=i+2
4626 c      write (iout,*) "eturn3",i,j,j1,j2
4627       a_temp(1,1)=a22
4628       a_temp(1,2)=a23
4629       a_temp(2,1)=a32
4630       a_temp(2,2)=a33
4631 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4632 C
4633 C               Third-order contributions
4634 C
4635 C                 (i+2)o----(i+3)
4636 C                      | |
4637 C                      | |
4638 C                 (i+1)o----i
4639 C
4640 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4641 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4642         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4643 c auxalary matices for theta gradient
4644 c auxalary matrix for i+1 and constant i+2
4645         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4646 c auxalary matrix for i+2 and constant i+1
4647         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4648         call transpose2(auxmat(1,1),auxmat1(1,1))
4649         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4650         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4651         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4652         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4653         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4654         if (shield_mode.eq.0) then
4655         fac_shield(i)=1.0
4656         fac_shield(j)=1.0
4657 C        else
4658 C        fac_shield(i)=0.4
4659 C        fac_shield(j)=0.6
4660         endif
4661         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4662      &  *fac_shield(i)*fac_shield(j)
4663         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4664      &  *fac_shield(i)*fac_shield(j)
4665 C Derivatives in theta
4666         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4667      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4668      &   *fac_shield(i)*fac_shield(j)
4669         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4670      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4671      &   *fac_shield(i)*fac_shield(j)
4672
4673
4674 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4675 C Derivatives in shield mode
4676           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4677      &  (shield_mode.gt.0)) then
4678 C          print *,i,j
4679
4680           do ilist=1,ishield_list(i)
4681            iresshield=shield_list(ilist,i)
4682            do k=1,3
4683            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4684 C     &      *2.0
4685            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4686      &              rlocshield
4687      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4688             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4689      &      +rlocshield
4690            enddo
4691           enddo
4692           do ilist=1,ishield_list(j)
4693            iresshield=shield_list(ilist,j)
4694            do k=1,3
4695            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4696 C     &     *2.0
4697            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4698      &              rlocshield
4699      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4700            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4701      &             +rlocshield
4702
4703            enddo
4704           enddo
4705
4706           do k=1,3
4707             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4708      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4709             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4710      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4711             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4712      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4713             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4714      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4715            enddo
4716            endif
4717
4718 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4719 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4720 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4721 cd     &    ' eello_turn3_num',4*eello_turn3_num
4722 C Derivatives in gamma(i)
4723         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4724         call transpose2(auxmat2(1,1),auxmat3(1,1))
4725         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4726         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4727      &   *fac_shield(i)*fac_shield(j)
4728 C Derivatives in gamma(i+1)
4729         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4730         call transpose2(auxmat2(1,1),auxmat3(1,1))
4731         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4732         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4733      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4734      &   *fac_shield(i)*fac_shield(j)
4735 C Cartesian derivatives
4736         do l=1,3
4737 c            ghalf1=0.5d0*agg(l,1)
4738 c            ghalf2=0.5d0*agg(l,2)
4739 c            ghalf3=0.5d0*agg(l,3)
4740 c            ghalf4=0.5d0*agg(l,4)
4741           a_temp(1,1)=aggi(l,1)!+ghalf1
4742           a_temp(1,2)=aggi(l,2)!+ghalf2
4743           a_temp(2,1)=aggi(l,3)!+ghalf3
4744           a_temp(2,2)=aggi(l,4)!+ghalf4
4745           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4746           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4747      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4748      &   *fac_shield(i)*fac_shield(j)
4749
4750           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4751           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4752           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4753           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4754           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4755           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4756      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4757      &   *fac_shield(i)*fac_shield(j)
4758           a_temp(1,1)=aggj(l,1)!+ghalf1
4759           a_temp(1,2)=aggj(l,2)!+ghalf2
4760           a_temp(2,1)=aggj(l,3)!+ghalf3
4761           a_temp(2,2)=aggj(l,4)!+ghalf4
4762           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4763           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4764      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4765      &   *fac_shield(i)*fac_shield(j)
4766           a_temp(1,1)=aggj1(l,1)
4767           a_temp(1,2)=aggj1(l,2)
4768           a_temp(2,1)=aggj1(l,3)
4769           a_temp(2,2)=aggj1(l,4)
4770           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4771           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4772      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4773      &   *fac_shield(i)*fac_shield(j)
4774         enddo
4775       return
4776       end
4777 C-------------------------------------------------------------------------------
4778       subroutine eturn4(i,eello_turn4)
4779 C Third- and fourth-order contributions from turns
4780       implicit real*8 (a-h,o-z)
4781       include 'DIMENSIONS'
4782       include 'COMMON.IOUNITS'
4783       include 'COMMON.GEO'
4784       include 'COMMON.VAR'
4785       include 'COMMON.LOCAL'
4786       include 'COMMON.CHAIN'
4787       include 'COMMON.DERIV'
4788       include 'COMMON.INTERACT'
4789       include 'COMMON.CONTACTS'
4790       include 'COMMON.TORSION'
4791       include 'COMMON.VECTORS'
4792       include 'COMMON.FFIELD'
4793       include 'COMMON.CONTROL'
4794       include 'COMMON.SHIELD'
4795       dimension ggg(3)
4796       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4797      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4798      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4799      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4800      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4801      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4802      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4803       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4804      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4805       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4806      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4807      &    num_conti,j1,j2
4808       j=i+3
4809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4810 C
4811 C               Fourth-order contributions
4812 C
4813 C                 (i+3)o----(i+4)
4814 C                     /  |
4815 C               (i+2)o   |
4816 C                     \  |
4817 C                 (i+1)o----i
4818 C
4819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4820 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4821 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4822 c        write(iout,*)"WCHODZE W PROGRAM"
4823         a_temp(1,1)=a22
4824         a_temp(1,2)=a23
4825         a_temp(2,1)=a32
4826         a_temp(2,2)=a33
4827         iti1=itortyp(itype(i+1))
4828         iti2=itortyp(itype(i+2))
4829         iti3=itortyp(itype(i+3))
4830 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4831         call transpose2(EUg(1,1,i+1),e1t(1,1))
4832         call transpose2(Eug(1,1,i+2),e2t(1,1))
4833         call transpose2(Eug(1,1,i+3),e3t(1,1))
4834 C Ematrix derivative in theta
4835         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4836         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4837         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4838         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4839 c       eta1 in derivative theta
4840         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4841         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4842 c       auxgvec is derivative of Ub2 so i+3 theta
4843         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4844 c       auxalary matrix of E i+1
4845         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4846 c        s1=0.0
4847 c        gs1=0.0
4848         s1=scalar2(b1(1,i+2),auxvec(1))
4849 c derivative of theta i+2 with constant i+3
4850         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4851 c derivative of theta i+2 with constant i+2
4852         gs32=scalar2(b1(1,i+2),auxgvec(1))
4853 c derivative of E matix in theta of i+1
4854         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4855
4856         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4857 c       ea31 in derivative theta
4858         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4859         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4860 c auxilary matrix auxgvec of Ub2 with constant E matirx
4861         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4862 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4863         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4864
4865 c        s2=0.0
4866 c        gs2=0.0
4867         s2=scalar2(b1(1,i+1),auxvec(1))
4868 c derivative of theta i+1 with constant i+3
4869         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4870 c derivative of theta i+2 with constant i+1
4871         gs21=scalar2(b1(1,i+1),auxgvec(1))
4872 c derivative of theta i+3 with constant i+1
4873         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4874 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4875 c     &  gtb1(1,i+1)
4876         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4877 c two derivatives over diffetent matrices
4878 c gtae3e2 is derivative over i+3
4879         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4880 c ae3gte2 is derivative over i+2
4881         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4882         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4883 c three possible derivative over theta E matices
4884 c i+1
4885         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4886 c i+2
4887         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4888 c i+3
4889         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4890         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4891
4892         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4893         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4894         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4895         if (shield_mode.eq.0) then
4896         fac_shield(i)=1.0
4897         fac_shield(j)=1.0
4898 C        else
4899 C        fac_shield(i)=0.6
4900 C        fac_shield(j)=0.4
4901         endif
4902         eello_turn4=eello_turn4-(s1+s2+s3)
4903      &  *fac_shield(i)*fac_shield(j)
4904         eello_t4=-(s1+s2+s3)
4905      &  *fac_shield(i)*fac_shield(j)
4906 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4907         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4908      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4909 C Now derivative over shield:
4910           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4911      &  (shield_mode.gt.0)) then
4912 C          print *,i,j
4913
4914           do ilist=1,ishield_list(i)
4915            iresshield=shield_list(ilist,i)
4916            do k=1,3
4917            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4918 C     &      *2.0
4919            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4920      &              rlocshield
4921      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4922             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4923      &      +rlocshield
4924            enddo
4925           enddo
4926           do ilist=1,ishield_list(j)
4927            iresshield=shield_list(ilist,j)
4928            do k=1,3
4929            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4930 C     &     *2.0
4931            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4932      &              rlocshield
4933      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4934            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4935      &             +rlocshield
4936
4937            enddo
4938           enddo
4939
4940           do k=1,3
4941             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4942      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4943             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4944      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4945             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4946      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4947             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4948      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4949            enddo
4950            endif
4951
4952
4953
4954
4955
4956
4957 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4958 cd     &    ' eello_turn4_num',8*eello_turn4_num
4959 #ifdef NEWCORR
4960         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4961      &                  -(gs13+gsE13+gsEE1)*wturn4
4962      &  *fac_shield(i)*fac_shield(j)
4963         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4964      &                    -(gs23+gs21+gsEE2)*wturn4
4965      &  *fac_shield(i)*fac_shield(j)
4966
4967         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4968      &                    -(gs32+gsE31+gsEE3)*wturn4
4969      &  *fac_shield(i)*fac_shield(j)
4970
4971 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4972 c     &   gs2
4973 #endif
4974         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4975      &      'eturn4',i,j,-(s1+s2+s3)
4976 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4977 c     &    ' eello_turn4_num',8*eello_turn4_num
4978 C Derivatives in gamma(i)
4979         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4980         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4981         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4982         s1=scalar2(b1(1,i+2),auxvec(1))
4983         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4984         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4985         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4986      &  *fac_shield(i)*fac_shield(j)
4987 C Derivatives in gamma(i+1)
4988         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4989         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4990         s2=scalar2(b1(1,i+1),auxvec(1))
4991         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4992         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4993         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4994         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4995      &  *fac_shield(i)*fac_shield(j)
4996 C Derivatives in gamma(i+2)
4997         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4998         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4999         s1=scalar2(b1(1,i+2),auxvec(1))
5000         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5001         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5002         s2=scalar2(b1(1,i+1),auxvec(1))
5003         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5004         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5005         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5006         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5007      &  *fac_shield(i)*fac_shield(j)
5008 C Cartesian derivatives
5009 C Derivatives of this turn contributions in DC(i+2)
5010         if (j.lt.nres-1) then
5011           do l=1,3
5012             a_temp(1,1)=agg(l,1)
5013             a_temp(1,2)=agg(l,2)
5014             a_temp(2,1)=agg(l,3)
5015             a_temp(2,2)=agg(l,4)
5016             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5017             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5018             s1=scalar2(b1(1,i+2),auxvec(1))
5019             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5020             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5021             s2=scalar2(b1(1,i+1),auxvec(1))
5022             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5023             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5024             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5025             ggg(l)=-(s1+s2+s3)
5026             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5027      &  *fac_shield(i)*fac_shield(j)
5028           enddo
5029         endif
5030 C Remaining derivatives of this turn contribution
5031         do l=1,3
5032           a_temp(1,1)=aggi(l,1)
5033           a_temp(1,2)=aggi(l,2)
5034           a_temp(2,1)=aggi(l,3)
5035           a_temp(2,2)=aggi(l,4)
5036           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5037           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5038           s1=scalar2(b1(1,i+2),auxvec(1))
5039           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5040           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5041           s2=scalar2(b1(1,i+1),auxvec(1))
5042           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5043           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5044           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5045           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5046      &  *fac_shield(i)*fac_shield(j)
5047           a_temp(1,1)=aggi1(l,1)
5048           a_temp(1,2)=aggi1(l,2)
5049           a_temp(2,1)=aggi1(l,3)
5050           a_temp(2,2)=aggi1(l,4)
5051           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5052           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5053           s1=scalar2(b1(1,i+2),auxvec(1))
5054           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5055           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5056           s2=scalar2(b1(1,i+1),auxvec(1))
5057           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5058           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5059           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5060           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5061      &  *fac_shield(i)*fac_shield(j)
5062           a_temp(1,1)=aggj(l,1)
5063           a_temp(1,2)=aggj(l,2)
5064           a_temp(2,1)=aggj(l,3)
5065           a_temp(2,2)=aggj(l,4)
5066           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5067           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5068           s1=scalar2(b1(1,i+2),auxvec(1))
5069           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5070           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5071           s2=scalar2(b1(1,i+1),auxvec(1))
5072           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5073           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5074           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5075           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5076      &  *fac_shield(i)*fac_shield(j)
5077           a_temp(1,1)=aggj1(l,1)
5078           a_temp(1,2)=aggj1(l,2)
5079           a_temp(2,1)=aggj1(l,3)
5080           a_temp(2,2)=aggj1(l,4)
5081           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5082           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5083           s1=scalar2(b1(1,i+2),auxvec(1))
5084           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5085           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5086           s2=scalar2(b1(1,i+1),auxvec(1))
5087           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5088           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5089           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5090 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5091           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5092      &  *fac_shield(i)*fac_shield(j)
5093         enddo
5094       return
5095       end
5096 C-----------------------------------------------------------------------------
5097       subroutine vecpr(u,v,w)
5098       implicit real*8(a-h,o-z)
5099       dimension u(3),v(3),w(3)
5100       w(1)=u(2)*v(3)-u(3)*v(2)
5101       w(2)=-u(1)*v(3)+u(3)*v(1)
5102       w(3)=u(1)*v(2)-u(2)*v(1)
5103       return
5104       end
5105 C-----------------------------------------------------------------------------
5106       subroutine unormderiv(u,ugrad,unorm,ungrad)
5107 C This subroutine computes the derivatives of a normalized vector u, given
5108 C the derivatives computed without normalization conditions, ugrad. Returns
5109 C ungrad.
5110       implicit none
5111       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5112       double precision vec(3)
5113       double precision scalar
5114       integer i,j
5115 c      write (2,*) 'ugrad',ugrad
5116 c      write (2,*) 'u',u
5117       do i=1,3
5118         vec(i)=scalar(ugrad(1,i),u(1))
5119       enddo
5120 c      write (2,*) 'vec',vec
5121       do i=1,3
5122         do j=1,3
5123           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5124         enddo
5125       enddo
5126 c      write (2,*) 'ungrad',ungrad
5127       return
5128       end
5129 C-----------------------------------------------------------------------------
5130       subroutine escp_soft_sphere(evdw2,evdw2_14)
5131 C
5132 C This subroutine calculates the excluded-volume interaction energy between
5133 C peptide-group centers and side chains and its gradient in virtual-bond and
5134 C side-chain vectors.
5135 C
5136       implicit real*8 (a-h,o-z)
5137       include 'DIMENSIONS'
5138       include 'COMMON.GEO'
5139       include 'COMMON.VAR'
5140       include 'COMMON.LOCAL'
5141       include 'COMMON.CHAIN'
5142       include 'COMMON.DERIV'
5143       include 'COMMON.INTERACT'
5144       include 'COMMON.FFIELD'
5145       include 'COMMON.IOUNITS'
5146       include 'COMMON.CONTROL'
5147       dimension ggg(3)
5148       evdw2=0.0D0
5149       evdw2_14=0.0d0
5150       r0_scp=4.5d0
5151 cd    print '(a)','Enter ESCP'
5152 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5153 C      do xshift=-1,1
5154 C      do yshift=-1,1
5155 C      do zshift=-1,1
5156       do i=iatscp_s,iatscp_e
5157         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5158         iteli=itel(i)
5159         xi=0.5D0*(c(1,i)+c(1,i+1))
5160         yi=0.5D0*(c(2,i)+c(2,i+1))
5161         zi=0.5D0*(c(3,i)+c(3,i+1))
5162 C Return atom into box, boxxsize is size of box in x dimension
5163 c  134   continue
5164 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5165 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5166 C Condition for being inside the proper box
5167 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5168 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5169 c        go to 134
5170 c        endif
5171 c  135   continue
5172 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5173 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5174 C Condition for being inside the proper box
5175 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5176 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5177 c        go to 135
5178 c c       endif
5179 c  136   continue
5180 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5181 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5182 cC Condition for being inside the proper box
5183 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5184 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5185 c        go to 136
5186 c        endif
5187           xi=mod(xi,boxxsize)
5188           if (xi.lt.0) xi=xi+boxxsize
5189           yi=mod(yi,boxysize)
5190           if (yi.lt.0) yi=yi+boxysize
5191           zi=mod(zi,boxzsize)
5192           if (zi.lt.0) zi=zi+boxzsize
5193 C          xi=xi+xshift*boxxsize
5194 C          yi=yi+yshift*boxysize
5195 C          zi=zi+zshift*boxzsize
5196         do iint=1,nscp_gr(i)
5197
5198         do j=iscpstart(i,iint),iscpend(i,iint)
5199           if (itype(j).eq.ntyp1) cycle
5200           itypj=iabs(itype(j))
5201 C Uncomment following three lines for SC-p interactions
5202 c         xj=c(1,nres+j)-xi
5203 c         yj=c(2,nres+j)-yi
5204 c         zj=c(3,nres+j)-zi
5205 C Uncomment following three lines for Ca-p interactions
5206           xj=c(1,j)
5207           yj=c(2,j)
5208           zj=c(3,j)
5209 c  174   continue
5210 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5211 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5212 C Condition for being inside the proper box
5213 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5214 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5215 c        go to 174
5216 c        endif
5217 c  175   continue
5218 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5219 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5220 cC Condition for being inside the proper box
5221 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5222 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5223 c        go to 175
5224 c        endif
5225 c  176   continue
5226 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5227 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5228 C Condition for being inside the proper box
5229 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5230 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5231 c        go to 176
5232           xj=mod(xj,boxxsize)
5233           if (xj.lt.0) xj=xj+boxxsize
5234           yj=mod(yj,boxysize)
5235           if (yj.lt.0) yj=yj+boxysize
5236           zj=mod(zj,boxzsize)
5237           if (zj.lt.0) zj=zj+boxzsize
5238       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5239       xj_safe=xj
5240       yj_safe=yj
5241       zj_safe=zj
5242       subchap=0
5243       do xshift=-1,1
5244       do yshift=-1,1
5245       do zshift=-1,1
5246           xj=xj_safe+xshift*boxxsize
5247           yj=yj_safe+yshift*boxysize
5248           zj=zj_safe+zshift*boxzsize
5249           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5250           if(dist_temp.lt.dist_init) then
5251             dist_init=dist_temp
5252             xj_temp=xj
5253             yj_temp=yj
5254             zj_temp=zj
5255             subchap=1
5256           endif
5257        enddo
5258        enddo
5259        enddo
5260        if (subchap.eq.1) then
5261           xj=xj_temp-xi
5262           yj=yj_temp-yi
5263           zj=zj_temp-zi
5264        else
5265           xj=xj_safe-xi
5266           yj=yj_safe-yi
5267           zj=zj_safe-zi
5268        endif
5269 c c       endif
5270 C          xj=xj-xi
5271 C          yj=yj-yi
5272 C          zj=zj-zi
5273           rij=xj*xj+yj*yj+zj*zj
5274
5275           r0ij=r0_scp
5276           r0ijsq=r0ij*r0ij
5277           if (rij.lt.r0ijsq) then
5278             evdwij=0.25d0*(rij-r0ijsq)**2
5279             fac=rij-r0ijsq
5280           else
5281             evdwij=0.0d0
5282             fac=0.0d0
5283           endif
5284           evdw2=evdw2+evdwij
5285 C
5286 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5287 C
5288           ggg(1)=xj*fac
5289           ggg(2)=yj*fac
5290           ggg(3)=zj*fac
5291 cgrad          if (j.lt.i) then
5292 cd          write (iout,*) 'j<i'
5293 C Uncomment following three lines for SC-p interactions
5294 c           do k=1,3
5295 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5296 c           enddo
5297 cgrad          else
5298 cd          write (iout,*) 'j>i'
5299 cgrad            do k=1,3
5300 cgrad              ggg(k)=-ggg(k)
5301 C Uncomment following line for SC-p interactions
5302 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5303 cgrad            enddo
5304 cgrad          endif
5305 cgrad          do k=1,3
5306 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5307 cgrad          enddo
5308 cgrad          kstart=min0(i+1,j)
5309 cgrad          kend=max0(i-1,j-1)
5310 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5311 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5312 cgrad          do k=kstart,kend
5313 cgrad            do l=1,3
5314 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5315 cgrad            enddo
5316 cgrad          enddo
5317           do k=1,3
5318             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5319             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5320           enddo
5321         enddo
5322
5323         enddo ! iint
5324       enddo ! i
5325 C      enddo !zshift
5326 C      enddo !yshift
5327 C      enddo !xshift
5328       return
5329       end
5330 C-----------------------------------------------------------------------------
5331       subroutine escp(evdw2,evdw2_14)
5332 C
5333 C This subroutine calculates the excluded-volume interaction energy between
5334 C peptide-group centers and side chains and its gradient in virtual-bond and
5335 C side-chain vectors.
5336 C
5337       implicit real*8 (a-h,o-z)
5338       include 'DIMENSIONS'
5339       include 'COMMON.GEO'
5340       include 'COMMON.VAR'
5341       include 'COMMON.LOCAL'
5342       include 'COMMON.CHAIN'
5343       include 'COMMON.DERIV'
5344       include 'COMMON.INTERACT'
5345       include 'COMMON.FFIELD'
5346       include 'COMMON.IOUNITS'
5347       include 'COMMON.CONTROL'
5348       include 'COMMON.SPLITELE'
5349       dimension ggg(3)
5350       evdw2=0.0D0
5351       evdw2_14=0.0d0
5352 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5353 cd    print '(a)','Enter ESCP'
5354 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5355 C      do xshift=-1,1
5356 C      do yshift=-1,1
5357 C      do zshift=-1,1
5358       do i=iatscp_s,iatscp_e
5359         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5360         iteli=itel(i)
5361         xi=0.5D0*(c(1,i)+c(1,i+1))
5362         yi=0.5D0*(c(2,i)+c(2,i+1))
5363         zi=0.5D0*(c(3,i)+c(3,i+1))
5364           xi=mod(xi,boxxsize)
5365           if (xi.lt.0) xi=xi+boxxsize
5366           yi=mod(yi,boxysize)
5367           if (yi.lt.0) yi=yi+boxysize
5368           zi=mod(zi,boxzsize)
5369           if (zi.lt.0) zi=zi+boxzsize
5370 c          xi=xi+xshift*boxxsize
5371 c          yi=yi+yshift*boxysize
5372 c          zi=zi+zshift*boxzsize
5373 c        print *,xi,yi,zi,'polozenie i'
5374 C Return atom into box, boxxsize is size of box in x dimension
5375 c  134   continue
5376 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5377 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5378 C Condition for being inside the proper box
5379 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5380 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5381 c        go to 134
5382 c        endif
5383 c  135   continue
5384 c          print *,xi,boxxsize,"pierwszy"
5385
5386 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5387 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5388 C Condition for being inside the proper box
5389 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5390 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5391 c        go to 135
5392 c        endif
5393 c  136   continue
5394 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5395 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5396 C Condition for being inside the proper box
5397 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5398 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5399 c        go to 136
5400 c        endif
5401         do iint=1,nscp_gr(i)
5402
5403         do j=iscpstart(i,iint),iscpend(i,iint)
5404           itypj=iabs(itype(j))
5405           if (itypj.eq.ntyp1) cycle
5406 C Uncomment following three lines for SC-p interactions
5407 c         xj=c(1,nres+j)-xi
5408 c         yj=c(2,nres+j)-yi
5409 c         zj=c(3,nres+j)-zi
5410 C Uncomment following three lines for Ca-p interactions
5411           xj=c(1,j)
5412           yj=c(2,j)
5413           zj=c(3,j)
5414           xj=mod(xj,boxxsize)
5415           if (xj.lt.0) xj=xj+boxxsize
5416           yj=mod(yj,boxysize)
5417           if (yj.lt.0) yj=yj+boxysize
5418           zj=mod(zj,boxzsize)
5419           if (zj.lt.0) zj=zj+boxzsize
5420 c  174   continue
5421 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5422 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5423 C Condition for being inside the proper box
5424 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5425 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5426 c        go to 174
5427 c        endif
5428 c  175   continue
5429 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5430 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5431 cC Condition for being inside the proper box
5432 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5433 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5434 c        go to 175
5435 c        endif
5436 c  176   continue
5437 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5438 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5439 C Condition for being inside the proper box
5440 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5441 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5442 c        go to 176
5443 c        endif
5444 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5445       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5446       xj_safe=xj
5447       yj_safe=yj
5448       zj_safe=zj
5449       subchap=0
5450       do xshift=-1,1
5451       do yshift=-1,1
5452       do zshift=-1,1
5453           xj=xj_safe+xshift*boxxsize
5454           yj=yj_safe+yshift*boxysize
5455           zj=zj_safe+zshift*boxzsize
5456           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5457           if(dist_temp.lt.dist_init) then
5458             dist_init=dist_temp
5459             xj_temp=xj
5460             yj_temp=yj
5461             zj_temp=zj
5462             subchap=1
5463           endif
5464        enddo
5465        enddo
5466        enddo
5467        if (subchap.eq.1) then
5468           xj=xj_temp-xi
5469           yj=yj_temp-yi
5470           zj=zj_temp-zi
5471        else
5472           xj=xj_safe-xi
5473           yj=yj_safe-yi
5474           zj=zj_safe-zi
5475        endif
5476 c          print *,xj,yj,zj,'polozenie j'
5477           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5478 c          print *,rrij
5479           sss=sscale(1.0d0/(dsqrt(rrij)))
5480 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5481 c          if (sss.eq.0) print *,'czasem jest OK'
5482           if (sss.le.0.0d0) cycle
5483           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5484           fac=rrij**expon2
5485           e1=fac*fac*aad(itypj,iteli)
5486           e2=fac*bad(itypj,iteli)
5487           if (iabs(j-i) .le. 2) then
5488             e1=scal14*e1
5489             e2=scal14*e2
5490             evdw2_14=evdw2_14+(e1+e2)*sss
5491           endif
5492           evdwij=e1+e2
5493           evdw2=evdw2+evdwij*sss
5494           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5495      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5496      &       bad(itypj,iteli)
5497 C
5498 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5499 C
5500           fac=-(evdwij+e1)*rrij*sss
5501           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5502           ggg(1)=xj*fac
5503           ggg(2)=yj*fac
5504           ggg(3)=zj*fac
5505 cgrad          if (j.lt.i) then
5506 cd          write (iout,*) 'j<i'
5507 C Uncomment following three lines for SC-p interactions
5508 c           do k=1,3
5509 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5510 c           enddo
5511 cgrad          else
5512 cd          write (iout,*) 'j>i'
5513 cgrad            do k=1,3
5514 cgrad              ggg(k)=-ggg(k)
5515 C Uncomment following line for SC-p interactions
5516 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5517 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5518 cgrad            enddo
5519 cgrad          endif
5520 cgrad          do k=1,3
5521 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5522 cgrad          enddo
5523 cgrad          kstart=min0(i+1,j)
5524 cgrad          kend=max0(i-1,j-1)
5525 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5526 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5527 cgrad          do k=kstart,kend
5528 cgrad            do l=1,3
5529 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5530 cgrad            enddo
5531 cgrad          enddo
5532           do k=1,3
5533             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5534             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5535           enddo
5536 c        endif !endif for sscale cutoff
5537         enddo ! j
5538
5539         enddo ! iint
5540       enddo ! i
5541 c      enddo !zshift
5542 c      enddo !yshift
5543 c      enddo !xshift
5544       do i=1,nct
5545         do j=1,3
5546           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5547           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5548           gradx_scp(j,i)=expon*gradx_scp(j,i)
5549         enddo
5550       enddo
5551 C******************************************************************************
5552 C
5553 C                              N O T E !!!
5554 C
5555 C To save time the factor EXPON has been extracted from ALL components
5556 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5557 C use!
5558 C
5559 C******************************************************************************
5560       return
5561       end
5562 C--------------------------------------------------------------------------
5563       subroutine edis(ehpb)
5564 C
5565 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5566 C
5567       implicit real*8 (a-h,o-z)
5568       include 'DIMENSIONS'
5569       include 'COMMON.SBRIDGE'
5570       include 'COMMON.CHAIN'
5571       include 'COMMON.DERIV'
5572       include 'COMMON.VAR'
5573       include 'COMMON.INTERACT'
5574       include 'COMMON.IOUNITS'
5575       include 'COMMON.CONTROL'
5576       dimension ggg(3)
5577       ehpb=0.0D0
5578       do i=1,3
5579        ggg(i)=0.0d0
5580       enddo
5581 C      write (iout,*) ,"link_end",link_end,constr_dist
5582 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5583 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5584       if (link_end.eq.0) return
5585       do i=link_start,link_end
5586 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5587 C CA-CA distance used in regularization of structure.
5588         ii=ihpb(i)
5589         jj=jhpb(i)
5590 C iii and jjj point to the residues for which the distance is assigned.
5591         if (ii.gt.nres) then
5592           iii=ii-nres
5593           jjj=jj-nres
5594         else
5595           iii=ii
5596           jjj=jj
5597         endif
5598 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5599 c     &    dhpb(i),dhpb1(i),forcon(i)
5600 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5601 C    distance and angle dependent SS bond potential.
5602 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5603 C     & iabs(itype(jjj)).eq.1) then
5604 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5605 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5606         if (.not.dyn_ss .and. i.le.nss) then
5607 C 15/02/13 CC dynamic SSbond - additional check
5608          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5609      & iabs(itype(jjj)).eq.1) then
5610           call ssbond_ene(iii,jjj,eij)
5611           ehpb=ehpb+2*eij
5612          endif
5613 cd          write (iout,*) "eij",eij
5614 cd   &   ' waga=',waga,' fac=',fac
5615         else if (ii.gt.nres .and. jj.gt.nres) then
5616 c Restraints from contact prediction
5617           dd=dist(ii,jj)
5618           if (constr_dist.eq.11) then
5619             ehpb=ehpb+fordepth(i)**4.0d0
5620      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5621             fac=fordepth(i)**4.0d0
5622      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5623           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5624      &    ehpb,fordepth(i),dd
5625            else
5626           if (dhpb1(i).gt.0.0d0) then
5627             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5628             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5629 c            write (iout,*) "beta nmr",
5630 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5631           else
5632             dd=dist(ii,jj)
5633             rdis=dd-dhpb(i)
5634 C Get the force constant corresponding to this distance.
5635             waga=forcon(i)
5636 C Calculate the contribution to energy.
5637             ehpb=ehpb+waga*rdis*rdis
5638 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5639 C
5640 C Evaluate gradient.
5641 C
5642             fac=waga*rdis/dd
5643           endif
5644           endif
5645           do j=1,3
5646             ggg(j)=fac*(c(j,jj)-c(j,ii))
5647           enddo
5648           do j=1,3
5649             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5650             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5651           enddo
5652           do k=1,3
5653             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5654             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5655           enddo
5656         else
5657 C Calculate the distance between the two points and its difference from the
5658 C target distance.
5659           dd=dist(ii,jj)
5660           if (constr_dist.eq.11) then
5661             ehpb=ehpb+fordepth(i)**4.0d0
5662      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5663             fac=fordepth(i)**4.0d0
5664      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5665           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5666      &    ehpb,fordepth(i),dd
5667            else
5668           if (dhpb1(i).gt.0.0d0) then
5669             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5670             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5671 c            write (iout,*) "alph nmr",
5672 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5673           else
5674             rdis=dd-dhpb(i)
5675 C Get the force constant corresponding to this distance.
5676             waga=forcon(i)
5677 C Calculate the contribution to energy.
5678             ehpb=ehpb+waga*rdis*rdis
5679 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5680 C
5681 C Evaluate gradient.
5682 C
5683             fac=waga*rdis/dd
5684           endif
5685           endif
5686             do j=1,3
5687               ggg(j)=fac*(c(j,jj)-c(j,ii))
5688             enddo
5689 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5690 C If this is a SC-SC distance, we need to calculate the contributions to the
5691 C Cartesian gradient in the SC vectors (ghpbx).
5692           if (iii.lt.ii) then
5693           do j=1,3
5694             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5695             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5696           enddo
5697           endif
5698 cgrad        do j=iii,jjj-1
5699 cgrad          do k=1,3
5700 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5701 cgrad          enddo
5702 cgrad        enddo
5703           do k=1,3
5704             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5705             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5706           enddo
5707         endif
5708       enddo
5709       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5710       return
5711       end
5712 C--------------------------------------------------------------------------
5713       subroutine ssbond_ene(i,j,eij)
5714 C
5715 C Calculate the distance and angle dependent SS-bond potential energy
5716 C using a free-energy function derived based on RHF/6-31G** ab initio
5717 C calculations of diethyl disulfide.
5718 C
5719 C A. Liwo and U. Kozlowska, 11/24/03
5720 C
5721       implicit real*8 (a-h,o-z)
5722       include 'DIMENSIONS'
5723       include 'COMMON.SBRIDGE'
5724       include 'COMMON.CHAIN'
5725       include 'COMMON.DERIV'
5726       include 'COMMON.LOCAL'
5727       include 'COMMON.INTERACT'
5728       include 'COMMON.VAR'
5729       include 'COMMON.IOUNITS'
5730       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5731       itypi=iabs(itype(i))
5732       xi=c(1,nres+i)
5733       yi=c(2,nres+i)
5734       zi=c(3,nres+i)
5735       dxi=dc_norm(1,nres+i)
5736       dyi=dc_norm(2,nres+i)
5737       dzi=dc_norm(3,nres+i)
5738 c      dsci_inv=dsc_inv(itypi)
5739       dsci_inv=vbld_inv(nres+i)
5740       itypj=iabs(itype(j))
5741 c      dscj_inv=dsc_inv(itypj)
5742       dscj_inv=vbld_inv(nres+j)
5743       xj=c(1,nres+j)-xi
5744       yj=c(2,nres+j)-yi
5745       zj=c(3,nres+j)-zi
5746       dxj=dc_norm(1,nres+j)
5747       dyj=dc_norm(2,nres+j)
5748       dzj=dc_norm(3,nres+j)
5749       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5750       rij=dsqrt(rrij)
5751       erij(1)=xj*rij
5752       erij(2)=yj*rij
5753       erij(3)=zj*rij
5754       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5755       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5756       om12=dxi*dxj+dyi*dyj+dzi*dzj
5757       do k=1,3
5758         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5759         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5760       enddo
5761       rij=1.0d0/rij
5762       deltad=rij-d0cm
5763       deltat1=1.0d0-om1
5764       deltat2=1.0d0+om2
5765       deltat12=om2-om1+2.0d0
5766       cosphi=om12-om1*om2
5767       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5768      &  +akct*deltad*deltat12
5769      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5770 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5771 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5772 c     &  " deltat12",deltat12," eij",eij
5773       ed=2*akcm*deltad+akct*deltat12
5774       pom1=akct*deltad
5775       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5776       eom1=-2*akth*deltat1-pom1-om2*pom2
5777       eom2= 2*akth*deltat2+pom1-om1*pom2
5778       eom12=pom2
5779       do k=1,3
5780         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5781         ghpbx(k,i)=ghpbx(k,i)-ggk
5782      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5783      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5784         ghpbx(k,j)=ghpbx(k,j)+ggk
5785      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5786      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5787         ghpbc(k,i)=ghpbc(k,i)-ggk
5788         ghpbc(k,j)=ghpbc(k,j)+ggk
5789       enddo
5790 C
5791 C Calculate the components of the gradient in DC and X
5792 C
5793 cgrad      do k=i,j-1
5794 cgrad        do l=1,3
5795 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5796 cgrad        enddo
5797 cgrad      enddo
5798       return
5799       end
5800 C--------------------------------------------------------------------------
5801       subroutine ebond(estr)
5802 c
5803 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5804 c
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.LOCAL'
5808       include 'COMMON.GEO'
5809       include 'COMMON.INTERACT'
5810       include 'COMMON.DERIV'
5811       include 'COMMON.VAR'
5812       include 'COMMON.CHAIN'
5813       include 'COMMON.IOUNITS'
5814       include 'COMMON.NAMES'
5815       include 'COMMON.FFIELD'
5816       include 'COMMON.CONTROL'
5817       include 'COMMON.SETUP'
5818       double precision u(3),ud(3)
5819       estr=0.0d0
5820       estr1=0.0d0
5821       do i=ibondp_start,ibondp_end
5822         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5823 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5824 c          do j=1,3
5825 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5826 c     &      *dc(j,i-1)/vbld(i)
5827 c          enddo
5828 c          if (energy_dec) write(iout,*)
5829 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5830 c        else
5831 C       Checking if it involves dummy (NH3+ or COO-) group
5832          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5833 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5834         diff = vbld(i)-vbldpDUM
5835          else
5836 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5837         diff = vbld(i)-vbldp0
5838          endif
5839         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5840      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5841         estr=estr+diff*diff
5842         do j=1,3
5843           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5844         enddo
5845 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5846 c        endif
5847       enddo
5848       estr=0.5d0*AKP*estr+estr1
5849 c
5850 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5851 c
5852       do i=ibond_start,ibond_end
5853         iti=iabs(itype(i))
5854         if (iti.ne.10 .and. iti.ne.ntyp1) then
5855           nbi=nbondterm(iti)
5856           if (nbi.eq.1) then
5857             diff=vbld(i+nres)-vbldsc0(1,iti)
5858             if (energy_dec)  write (iout,*)
5859      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5860      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5861             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5862             do j=1,3
5863               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5864             enddo
5865           else
5866             do j=1,nbi
5867               diff=vbld(i+nres)-vbldsc0(j,iti)
5868               ud(j)=aksc(j,iti)*diff
5869               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5870             enddo
5871             uprod=u(1)
5872             do j=2,nbi
5873               uprod=uprod*u(j)
5874             enddo
5875             usum=0.0d0
5876             usumsqder=0.0d0
5877             do j=1,nbi
5878               uprod1=1.0d0
5879               uprod2=1.0d0
5880               do k=1,nbi
5881                 if (k.ne.j) then
5882                   uprod1=uprod1*u(k)
5883                   uprod2=uprod2*u(k)*u(k)
5884                 endif
5885               enddo
5886               usum=usum+uprod1
5887               usumsqder=usumsqder+ud(j)*uprod2
5888             enddo
5889             estr=estr+uprod/usum
5890             do j=1,3
5891              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5892             enddo
5893           endif
5894         endif
5895       enddo
5896       return
5897       end
5898 #ifdef CRYST_THETA
5899 C--------------------------------------------------------------------------
5900       subroutine ebend(etheta,ethetacnstr)
5901 C
5902 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5903 C angles gamma and its derivatives in consecutive thetas and gammas.
5904 C
5905       implicit real*8 (a-h,o-z)
5906       include 'DIMENSIONS'
5907       include 'COMMON.LOCAL'
5908       include 'COMMON.GEO'
5909       include 'COMMON.INTERACT'
5910       include 'COMMON.DERIV'
5911       include 'COMMON.VAR'
5912       include 'COMMON.CHAIN'
5913       include 'COMMON.IOUNITS'
5914       include 'COMMON.NAMES'
5915       include 'COMMON.FFIELD'
5916       include 'COMMON.CONTROL'
5917       include 'COMMON.TORCNSTR'
5918       common /calcthet/ term1,term2,termm,diffak,ratak,
5919      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5920      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5921       double precision y(2),z(2)
5922       delta=0.02d0*pi
5923 c      time11=dexp(-2*time)
5924 c      time12=1.0d0
5925       etheta=0.0D0
5926 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5927       do i=ithet_start,ithet_end
5928         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5929      &  .or.itype(i).eq.ntyp1) cycle
5930 C Zero the energy function and its derivative at 0 or pi.
5931         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5932         it=itype(i-1)
5933         ichir1=isign(1,itype(i-2))
5934         ichir2=isign(1,itype(i))
5935          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5936          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5937          if (itype(i-1).eq.10) then
5938           itype1=isign(10,itype(i-2))
5939           ichir11=isign(1,itype(i-2))
5940           ichir12=isign(1,itype(i-2))
5941           itype2=isign(10,itype(i))
5942           ichir21=isign(1,itype(i))
5943           ichir22=isign(1,itype(i))
5944          endif
5945
5946         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5947 #ifdef OSF
5948           phii=phi(i)
5949           if (phii.ne.phii) phii=150.0
5950 #else
5951           phii=phi(i)
5952 #endif
5953           y(1)=dcos(phii)
5954           y(2)=dsin(phii)
5955         else
5956           y(1)=0.0D0
5957           y(2)=0.0D0
5958         endif
5959         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5960 #ifdef OSF
5961           phii1=phi(i+1)
5962           if (phii1.ne.phii1) phii1=150.0
5963           phii1=pinorm(phii1)
5964           z(1)=cos(phii1)
5965 #else
5966           phii1=phi(i+1)
5967 #endif
5968           z(1)=dcos(phii1)
5969           z(2)=dsin(phii1)
5970         else
5971           z(1)=0.0D0
5972           z(2)=0.0D0
5973         endif
5974 C Calculate the "mean" value of theta from the part of the distribution
5975 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5976 C In following comments this theta will be referred to as t_c.
5977         thet_pred_mean=0.0d0
5978         do k=1,2
5979             athetk=athet(k,it,ichir1,ichir2)
5980             bthetk=bthet(k,it,ichir1,ichir2)
5981           if (it.eq.10) then
5982              athetk=athet(k,itype1,ichir11,ichir12)
5983              bthetk=bthet(k,itype2,ichir21,ichir22)
5984           endif
5985          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5986 c         write(iout,*) 'chuj tu', y(k),z(k)
5987         enddo
5988         dthett=thet_pred_mean*ssd
5989         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5990 C Derivatives of the "mean" values in gamma1 and gamma2.
5991         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5992      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5993          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5994      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5995          if (it.eq.10) then
5996       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5997      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5998         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5999      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6000          endif
6001         if (theta(i).gt.pi-delta) then
6002           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6003      &         E_tc0)
6004           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6005           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6006           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6007      &        E_theta)
6008           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6009      &        E_tc)
6010         else if (theta(i).lt.delta) then
6011           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6012           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6013           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6014      &        E_theta)
6015           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6016           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6017      &        E_tc)
6018         else
6019           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6020      &        E_theta,E_tc)
6021         endif
6022         etheta=etheta+ethetai
6023         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6024      &      'ebend',i,ethetai,theta(i),itype(i)
6025         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6026         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6027         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6028       enddo
6029       ethetacnstr=0.0d0
6030 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6031       do i=ithetaconstr_start,ithetaconstr_end
6032         itheta=itheta_constr(i)
6033         thetiii=theta(itheta)
6034         difi=pinorm(thetiii-theta_constr0(i))
6035         if (difi.gt.theta_drange(i)) then
6036           difi=difi-theta_drange(i)
6037           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6038           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6039      &    +for_thet_constr(i)*difi**3
6040         else if (difi.lt.-drange(i)) then
6041           difi=difi+drange(i)
6042           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6043           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6044      &    +for_thet_constr(i)*difi**3
6045         else
6046           difi=0.0
6047         endif
6048        if (energy_dec) then
6049         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6050      &    i,itheta,rad2deg*thetiii,
6051      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6052      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6053      &    gloc(itheta+nphi-2,icg)
6054         endif
6055       enddo
6056
6057 C Ufff.... We've done all this!!!
6058       return
6059       end
6060 C---------------------------------------------------------------------------
6061       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6062      &     E_tc)
6063       implicit real*8 (a-h,o-z)
6064       include 'DIMENSIONS'
6065       include 'COMMON.LOCAL'
6066       include 'COMMON.IOUNITS'
6067       common /calcthet/ term1,term2,termm,diffak,ratak,
6068      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6069      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6070 C Calculate the contributions to both Gaussian lobes.
6071 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6072 C The "polynomial part" of the "standard deviation" of this part of
6073 C the distributioni.
6074 ccc        write (iout,*) thetai,thet_pred_mean
6075         sig=polthet(3,it)
6076         do j=2,0,-1
6077           sig=sig*thet_pred_mean+polthet(j,it)
6078         enddo
6079 C Derivative of the "interior part" of the "standard deviation of the"
6080 C gamma-dependent Gaussian lobe in t_c.
6081         sigtc=3*polthet(3,it)
6082         do j=2,1,-1
6083           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6084         enddo
6085         sigtc=sig*sigtc
6086 C Set the parameters of both Gaussian lobes of the distribution.
6087 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6088         fac=sig*sig+sigc0(it)
6089         sigcsq=fac+fac
6090         sigc=1.0D0/sigcsq
6091 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6092         sigsqtc=-4.0D0*sigcsq*sigtc
6093 c       print *,i,sig,sigtc,sigsqtc
6094 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6095         sigtc=-sigtc/(fac*fac)
6096 C Following variable is sigma(t_c)**(-2)
6097         sigcsq=sigcsq*sigcsq
6098         sig0i=sig0(it)
6099         sig0inv=1.0D0/sig0i**2
6100         delthec=thetai-thet_pred_mean
6101         delthe0=thetai-theta0i
6102         term1=-0.5D0*sigcsq*delthec*delthec
6103         term2=-0.5D0*sig0inv*delthe0*delthe0
6104 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6105 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6106 C NaNs in taking the logarithm. We extract the largest exponent which is added
6107 C to the energy (this being the log of the distribution) at the end of energy
6108 C term evaluation for this virtual-bond angle.
6109         if (term1.gt.term2) then
6110           termm=term1
6111           term2=dexp(term2-termm)
6112           term1=1.0d0
6113         else
6114           termm=term2
6115           term1=dexp(term1-termm)
6116           term2=1.0d0
6117         endif
6118 C The ratio between the gamma-independent and gamma-dependent lobes of
6119 C the distribution is a Gaussian function of thet_pred_mean too.
6120         diffak=gthet(2,it)-thet_pred_mean
6121         ratak=diffak/gthet(3,it)**2
6122         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6123 C Let's differentiate it in thet_pred_mean NOW.
6124         aktc=ak*ratak
6125 C Now put together the distribution terms to make complete distribution.
6126         termexp=term1+ak*term2
6127         termpre=sigc+ak*sig0i
6128 C Contribution of the bending energy from this theta is just the -log of
6129 C the sum of the contributions from the two lobes and the pre-exponential
6130 C factor. Simple enough, isn't it?
6131         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6132 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6133 C NOW the derivatives!!!
6134 C 6/6/97 Take into account the deformation.
6135         E_theta=(delthec*sigcsq*term1
6136      &       +ak*delthe0*sig0inv*term2)/termexp
6137         E_tc=((sigtc+aktc*sig0i)/termpre
6138      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6139      &       aktc*term2)/termexp)
6140       return
6141       end
6142 c-----------------------------------------------------------------------------
6143       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6144       implicit real*8 (a-h,o-z)
6145       include 'DIMENSIONS'
6146       include 'COMMON.LOCAL'
6147       include 'COMMON.IOUNITS'
6148       common /calcthet/ term1,term2,termm,diffak,ratak,
6149      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6150      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6151       delthec=thetai-thet_pred_mean
6152       delthe0=thetai-theta0i
6153 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6154       t3 = thetai-thet_pred_mean
6155       t6 = t3**2
6156       t9 = term1
6157       t12 = t3*sigcsq
6158       t14 = t12+t6*sigsqtc
6159       t16 = 1.0d0
6160       t21 = thetai-theta0i
6161       t23 = t21**2
6162       t26 = term2
6163       t27 = t21*t26
6164       t32 = termexp
6165       t40 = t32**2
6166       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6167      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6168      & *(-t12*t9-ak*sig0inv*t27)
6169       return
6170       end
6171 #else
6172 C--------------------------------------------------------------------------
6173       subroutine ebend(etheta,ethetacnstr)
6174 C
6175 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6176 C angles gamma and its derivatives in consecutive thetas and gammas.
6177 C ab initio-derived potentials from
6178 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6179 C
6180       implicit real*8 (a-h,o-z)
6181       include 'DIMENSIONS'
6182       include 'COMMON.LOCAL'
6183       include 'COMMON.GEO'
6184       include 'COMMON.INTERACT'
6185       include 'COMMON.DERIV'
6186       include 'COMMON.VAR'
6187       include 'COMMON.CHAIN'
6188       include 'COMMON.IOUNITS'
6189       include 'COMMON.NAMES'
6190       include 'COMMON.FFIELD'
6191       include 'COMMON.CONTROL'
6192       include 'COMMON.TORCNSTR'
6193       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6194      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6195      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6196      & sinph1ph2(maxdouble,maxdouble)
6197       logical lprn /.false./, lprn1 /.false./
6198       etheta=0.0D0
6199       do i=ithet_start,ithet_end
6200 c        print *,i,itype(i-1),itype(i),itype(i-2)
6201         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6202      &  .or.itype(i).eq.ntyp1) cycle
6203 C        print *,i,theta(i)
6204         if (iabs(itype(i+1)).eq.20) iblock=2
6205         if (iabs(itype(i+1)).ne.20) iblock=1
6206         dethetai=0.0d0
6207         dephii=0.0d0
6208         dephii1=0.0d0
6209         theti2=0.5d0*theta(i)
6210         ityp2=ithetyp((itype(i-1)))
6211         do k=1,nntheterm
6212           coskt(k)=dcos(k*theti2)
6213           sinkt(k)=dsin(k*theti2)
6214         enddo
6215 C        print *,ethetai
6216         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6217 #ifdef OSF
6218           phii=phi(i)
6219           if (phii.ne.phii) phii=150.0
6220 #else
6221           phii=phi(i)
6222 #endif
6223           ityp1=ithetyp((itype(i-2)))
6224 C propagation of chirality for glycine type
6225           do k=1,nsingle
6226             cosph1(k)=dcos(k*phii)
6227             sinph1(k)=dsin(k*phii)
6228           enddo
6229         else
6230           phii=0.0d0
6231           do k=1,nsingle
6232           ityp1=ithetyp((itype(i-2)))
6233             cosph1(k)=0.0d0
6234             sinph1(k)=0.0d0
6235           enddo
6236         endif
6237         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6238 #ifdef OSF
6239           phii1=phi(i+1)
6240           if (phii1.ne.phii1) phii1=150.0
6241           phii1=pinorm(phii1)
6242 #else
6243           phii1=phi(i+1)
6244 #endif
6245           ityp3=ithetyp((itype(i)))
6246           do k=1,nsingle
6247             cosph2(k)=dcos(k*phii1)
6248             sinph2(k)=dsin(k*phii1)
6249           enddo
6250         else
6251           phii1=0.0d0
6252           ityp3=ithetyp((itype(i)))
6253           do k=1,nsingle
6254             cosph2(k)=0.0d0
6255             sinph2(k)=0.0d0
6256           enddo
6257         endif
6258         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6259         do k=1,ndouble
6260           do l=1,k-1
6261             ccl=cosph1(l)*cosph2(k-l)
6262             ssl=sinph1(l)*sinph2(k-l)
6263             scl=sinph1(l)*cosph2(k-l)
6264             csl=cosph1(l)*sinph2(k-l)
6265             cosph1ph2(l,k)=ccl-ssl
6266             cosph1ph2(k,l)=ccl+ssl
6267             sinph1ph2(l,k)=scl+csl
6268             sinph1ph2(k,l)=scl-csl
6269           enddo
6270         enddo
6271         if (lprn) then
6272         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6273      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6274         write (iout,*) "coskt and sinkt"
6275         do k=1,nntheterm
6276           write (iout,*) k,coskt(k),sinkt(k)
6277         enddo
6278         endif
6279         do k=1,ntheterm
6280           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6281           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6282      &      *coskt(k)
6283           if (lprn)
6284      &    write (iout,*) "k",k,"
6285      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6286      &     " ethetai",ethetai
6287         enddo
6288         if (lprn) then
6289         write (iout,*) "cosph and sinph"
6290         do k=1,nsingle
6291           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6292         enddo
6293         write (iout,*) "cosph1ph2 and sinph2ph2"
6294         do k=2,ndouble
6295           do l=1,k-1
6296             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6297      &         sinph1ph2(l,k),sinph1ph2(k,l)
6298           enddo
6299         enddo
6300         write(iout,*) "ethetai",ethetai
6301         endif
6302 C       print *,ethetai
6303         do m=1,ntheterm2
6304           do k=1,nsingle
6305             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6306      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6307      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6308      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6309             ethetai=ethetai+sinkt(m)*aux
6310             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6311             dephii=dephii+k*sinkt(m)*(
6312      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6313      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6314             dephii1=dephii1+k*sinkt(m)*(
6315      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6316      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6317             if (lprn)
6318      &      write (iout,*) "m",m," k",k," bbthet",
6319      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6320      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6321      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6322      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6323 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6324           enddo
6325         enddo
6326 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6327 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6328 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6329 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6330         if (lprn)
6331      &  write(iout,*) "ethetai",ethetai
6332 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6333         do m=1,ntheterm3
6334           do k=2,ndouble
6335             do l=1,k-1
6336               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6337      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6338      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6339      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6340               ethetai=ethetai+sinkt(m)*aux
6341               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6342               dephii=dephii+l*sinkt(m)*(
6343      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6344      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6345      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6346      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6347               dephii1=dephii1+(k-l)*sinkt(m)*(
6348      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6349      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6350      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6351      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6352               if (lprn) then
6353               write (iout,*) "m",m," k",k," l",l," ffthet",
6354      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6355      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6356      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6357      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6358      &            " ethetai",ethetai
6359               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6360      &            cosph1ph2(k,l)*sinkt(m),
6361      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6362               endif
6363             enddo
6364           enddo
6365         enddo
6366 10      continue
6367 c        lprn1=.true.
6368 C        print *,ethetai
6369         if (lprn1)
6370      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6371      &   i,theta(i)*rad2deg,phii*rad2deg,
6372      &   phii1*rad2deg,ethetai
6373 c        lprn1=.false.
6374         etheta=etheta+ethetai
6375         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6376         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6377         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6378       enddo
6379 C now constrains
6380       ethetacnstr=0.0d0
6381 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6382       do i=ithetaconstr_start,ithetaconstr_end
6383         itheta=itheta_constr(i)
6384         thetiii=theta(itheta)
6385         difi=pinorm(thetiii-theta_constr0(i))
6386         if (difi.gt.theta_drange(i)) then
6387           difi=difi-theta_drange(i)
6388           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6389           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6390      &    +for_thet_constr(i)*difi**3
6391         else if (difi.lt.-drange(i)) then
6392           difi=difi+drange(i)
6393           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6394           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6395      &    +for_thet_constr(i)*difi**3
6396         else
6397           difi=0.0
6398         endif
6399        if (energy_dec) then
6400         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6401      &    i,itheta,rad2deg*thetiii,
6402      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6403      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6404      &    gloc(itheta+nphi-2,icg)
6405         endif
6406       enddo
6407
6408       return
6409       end
6410 #endif
6411 #ifdef CRYST_SC
6412 c-----------------------------------------------------------------------------
6413       subroutine esc(escloc)
6414 C Calculate the local energy of a side chain and its derivatives in the
6415 C corresponding virtual-bond valence angles THETA and the spherical angles
6416 C ALPHA and OMEGA.
6417       implicit real*8 (a-h,o-z)
6418       include 'DIMENSIONS'
6419       include 'COMMON.GEO'
6420       include 'COMMON.LOCAL'
6421       include 'COMMON.VAR'
6422       include 'COMMON.INTERACT'
6423       include 'COMMON.DERIV'
6424       include 'COMMON.CHAIN'
6425       include 'COMMON.IOUNITS'
6426       include 'COMMON.NAMES'
6427       include 'COMMON.FFIELD'
6428       include 'COMMON.CONTROL'
6429       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6430      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6431       common /sccalc/ time11,time12,time112,theti,it,nlobit
6432       delta=0.02d0*pi
6433       escloc=0.0D0
6434 c     write (iout,'(a)') 'ESC'
6435       do i=loc_start,loc_end
6436         it=itype(i)
6437         if (it.eq.ntyp1) cycle
6438         if (it.eq.10) goto 1
6439         nlobit=nlob(iabs(it))
6440 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6441 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6442         theti=theta(i+1)-pipol
6443         x(1)=dtan(theti)
6444         x(2)=alph(i)
6445         x(3)=omeg(i)
6446
6447         if (x(2).gt.pi-delta) then
6448           xtemp(1)=x(1)
6449           xtemp(2)=pi-delta
6450           xtemp(3)=x(3)
6451           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6452           xtemp(2)=pi
6453           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6454           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6455      &        escloci,dersc(2))
6456           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6457      &        ddersc0(1),dersc(1))
6458           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6459      &        ddersc0(3),dersc(3))
6460           xtemp(2)=pi-delta
6461           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6462           xtemp(2)=pi
6463           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6464           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6465      &            dersc0(2),esclocbi,dersc02)
6466           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6467      &            dersc12,dersc01)
6468           call splinthet(x(2),0.5d0*delta,ss,ssd)
6469           dersc0(1)=dersc01
6470           dersc0(2)=dersc02
6471           dersc0(3)=0.0d0
6472           do k=1,3
6473             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6474           enddo
6475           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6476 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6477 c    &             esclocbi,ss,ssd
6478           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6479 c         escloci=esclocbi
6480 c         write (iout,*) escloci
6481         else if (x(2).lt.delta) then
6482           xtemp(1)=x(1)
6483           xtemp(2)=delta
6484           xtemp(3)=x(3)
6485           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6486           xtemp(2)=0.0d0
6487           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6488           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6489      &        escloci,dersc(2))
6490           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6491      &        ddersc0(1),dersc(1))
6492           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6493      &        ddersc0(3),dersc(3))
6494           xtemp(2)=delta
6495           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6496           xtemp(2)=0.0d0
6497           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6498           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6499      &            dersc0(2),esclocbi,dersc02)
6500           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6501      &            dersc12,dersc01)
6502           dersc0(1)=dersc01
6503           dersc0(2)=dersc02
6504           dersc0(3)=0.0d0
6505           call splinthet(x(2),0.5d0*delta,ss,ssd)
6506           do k=1,3
6507             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6508           enddo
6509           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6510 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6511 c    &             esclocbi,ss,ssd
6512           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6513 c         write (iout,*) escloci
6514         else
6515           call enesc(x,escloci,dersc,ddummy,.false.)
6516         endif
6517
6518         escloc=escloc+escloci
6519         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6520      &     'escloc',i,escloci
6521 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6522
6523         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6524      &   wscloc*dersc(1)
6525         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6526         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6527     1   continue
6528       enddo
6529       return
6530       end
6531 C---------------------------------------------------------------------------
6532       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6533       implicit real*8 (a-h,o-z)
6534       include 'DIMENSIONS'
6535       include 'COMMON.GEO'
6536       include 'COMMON.LOCAL'
6537       include 'COMMON.IOUNITS'
6538       common /sccalc/ time11,time12,time112,theti,it,nlobit
6539       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6540       double precision contr(maxlob,-1:1)
6541       logical mixed
6542 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6543         escloc_i=0.0D0
6544         do j=1,3
6545           dersc(j)=0.0D0
6546           if (mixed) ddersc(j)=0.0d0
6547         enddo
6548         x3=x(3)
6549
6550 C Because of periodicity of the dependence of the SC energy in omega we have
6551 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6552 C To avoid underflows, first compute & store the exponents.
6553
6554         do iii=-1,1
6555
6556           x(3)=x3+iii*dwapi
6557
6558           do j=1,nlobit
6559             do k=1,3
6560               z(k)=x(k)-censc(k,j,it)
6561             enddo
6562             do k=1,3
6563               Axk=0.0D0
6564               do l=1,3
6565                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6566               enddo
6567               Ax(k,j,iii)=Axk
6568             enddo
6569             expfac=0.0D0
6570             do k=1,3
6571               expfac=expfac+Ax(k,j,iii)*z(k)
6572             enddo
6573             contr(j,iii)=expfac
6574           enddo ! j
6575
6576         enddo ! iii
6577
6578         x(3)=x3
6579 C As in the case of ebend, we want to avoid underflows in exponentiation and
6580 C subsequent NaNs and INFs in energy calculation.
6581 C Find the largest exponent
6582         emin=contr(1,-1)
6583         do iii=-1,1
6584           do j=1,nlobit
6585             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6586           enddo
6587         enddo
6588         emin=0.5D0*emin
6589 cd      print *,'it=',it,' emin=',emin
6590
6591 C Compute the contribution to SC energy and derivatives
6592         do iii=-1,1
6593
6594           do j=1,nlobit
6595 #ifdef OSF
6596             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6597             if(adexp.ne.adexp) adexp=1.0
6598             expfac=dexp(adexp)
6599 #else
6600             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6601 #endif
6602 cd          print *,'j=',j,' expfac=',expfac
6603             escloc_i=escloc_i+expfac
6604             do k=1,3
6605               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6606             enddo
6607             if (mixed) then
6608               do k=1,3,2
6609                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6610      &            +gaussc(k,2,j,it))*expfac
6611               enddo
6612             endif
6613           enddo
6614
6615         enddo ! iii
6616
6617         dersc(1)=dersc(1)/cos(theti)**2
6618         ddersc(1)=ddersc(1)/cos(theti)**2
6619         ddersc(3)=ddersc(3)
6620
6621         escloci=-(dlog(escloc_i)-emin)
6622         do j=1,3
6623           dersc(j)=dersc(j)/escloc_i
6624         enddo
6625         if (mixed) then
6626           do j=1,3,2
6627             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6628           enddo
6629         endif
6630       return
6631       end
6632 C------------------------------------------------------------------------------
6633       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6634       implicit real*8 (a-h,o-z)
6635       include 'DIMENSIONS'
6636       include 'COMMON.GEO'
6637       include 'COMMON.LOCAL'
6638       include 'COMMON.IOUNITS'
6639       common /sccalc/ time11,time12,time112,theti,it,nlobit
6640       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6641       double precision contr(maxlob)
6642       logical mixed
6643
6644       escloc_i=0.0D0
6645
6646       do j=1,3
6647         dersc(j)=0.0D0
6648       enddo
6649
6650       do j=1,nlobit
6651         do k=1,2
6652           z(k)=x(k)-censc(k,j,it)
6653         enddo
6654         z(3)=dwapi
6655         do k=1,3
6656           Axk=0.0D0
6657           do l=1,3
6658             Axk=Axk+gaussc(l,k,j,it)*z(l)
6659           enddo
6660           Ax(k,j)=Axk
6661         enddo
6662         expfac=0.0D0
6663         do k=1,3
6664           expfac=expfac+Ax(k,j)*z(k)
6665         enddo
6666         contr(j)=expfac
6667       enddo ! j
6668
6669 C As in the case of ebend, we want to avoid underflows in exponentiation and
6670 C subsequent NaNs and INFs in energy calculation.
6671 C Find the largest exponent
6672       emin=contr(1)
6673       do j=1,nlobit
6674         if (emin.gt.contr(j)) emin=contr(j)
6675       enddo
6676       emin=0.5D0*emin
6677
6678 C Compute the contribution to SC energy and derivatives
6679
6680       dersc12=0.0d0
6681       do j=1,nlobit
6682         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6683         escloc_i=escloc_i+expfac
6684         do k=1,2
6685           dersc(k)=dersc(k)+Ax(k,j)*expfac
6686         enddo
6687         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6688      &            +gaussc(1,2,j,it))*expfac
6689         dersc(3)=0.0d0
6690       enddo
6691
6692       dersc(1)=dersc(1)/cos(theti)**2
6693       dersc12=dersc12/cos(theti)**2
6694       escloci=-(dlog(escloc_i)-emin)
6695       do j=1,2
6696         dersc(j)=dersc(j)/escloc_i
6697       enddo
6698       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6699       return
6700       end
6701 #else
6702 c----------------------------------------------------------------------------------
6703       subroutine esc(escloc)
6704 C Calculate the local energy of a side chain and its derivatives in the
6705 C corresponding virtual-bond valence angles THETA and the spherical angles
6706 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6707 C added by Urszula Kozlowska. 07/11/2007
6708 C
6709       implicit real*8 (a-h,o-z)
6710       include 'DIMENSIONS'
6711       include 'COMMON.GEO'
6712       include 'COMMON.LOCAL'
6713       include 'COMMON.VAR'
6714       include 'COMMON.SCROT'
6715       include 'COMMON.INTERACT'
6716       include 'COMMON.DERIV'
6717       include 'COMMON.CHAIN'
6718       include 'COMMON.IOUNITS'
6719       include 'COMMON.NAMES'
6720       include 'COMMON.FFIELD'
6721       include 'COMMON.CONTROL'
6722       include 'COMMON.VECTORS'
6723       double precision x_prime(3),y_prime(3),z_prime(3)
6724      &    , sumene,dsc_i,dp2_i,x(65),
6725      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6726      &    de_dxx,de_dyy,de_dzz,de_dt
6727       double precision s1_t,s1_6_t,s2_t,s2_6_t
6728       double precision
6729      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6730      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6731      & dt_dCi(3),dt_dCi1(3)
6732       common /sccalc/ time11,time12,time112,theti,it,nlobit
6733       delta=0.02d0*pi
6734       escloc=0.0D0
6735       do i=loc_start,loc_end
6736         if (itype(i).eq.ntyp1) cycle
6737         costtab(i+1) =dcos(theta(i+1))
6738         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6739         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6740         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6741         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6742         cosfac=dsqrt(cosfac2)
6743         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6744         sinfac=dsqrt(sinfac2)
6745         it=iabs(itype(i))
6746         if (it.eq.10) goto 1
6747 c
6748 C  Compute the axes of tghe local cartesian coordinates system; store in
6749 c   x_prime, y_prime and z_prime
6750 c
6751         do j=1,3
6752           x_prime(j) = 0.00
6753           y_prime(j) = 0.00
6754           z_prime(j) = 0.00
6755         enddo
6756 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6757 C     &   dc_norm(3,i+nres)
6758         do j = 1,3
6759           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6760           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6761         enddo
6762         do j = 1,3
6763           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6764         enddo
6765 c       write (2,*) "i",i
6766 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6767 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6768 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6769 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6770 c      & " xy",scalar(x_prime(1),y_prime(1)),
6771 c      & " xz",scalar(x_prime(1),z_prime(1)),
6772 c      & " yy",scalar(y_prime(1),y_prime(1)),
6773 c      & " yz",scalar(y_prime(1),z_prime(1)),
6774 c      & " zz",scalar(z_prime(1),z_prime(1))
6775 c
6776 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6777 C to local coordinate system. Store in xx, yy, zz.
6778 c
6779         xx=0.0d0
6780         yy=0.0d0
6781         zz=0.0d0
6782         do j = 1,3
6783           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6784           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6785           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6786         enddo
6787
6788         xxtab(i)=xx
6789         yytab(i)=yy
6790         zztab(i)=zz
6791 C
6792 C Compute the energy of the ith side cbain
6793 C
6794 c        write (2,*) "xx",xx," yy",yy," zz",zz
6795         it=iabs(itype(i))
6796         do j = 1,65
6797           x(j) = sc_parmin(j,it)
6798         enddo
6799 #ifdef CHECK_COORD
6800 Cc diagnostics - remove later
6801         xx1 = dcos(alph(2))
6802         yy1 = dsin(alph(2))*dcos(omeg(2))
6803         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6804         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6805      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6806      &    xx1,yy1,zz1
6807 C,"  --- ", xx_w,yy_w,zz_w
6808 c end diagnostics
6809 #endif
6810         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6811      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6812      &   + x(10)*yy*zz
6813         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6814      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6815      & + x(20)*yy*zz
6816         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6817      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6818      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6819      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6820      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6821      &  +x(40)*xx*yy*zz
6822         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6823      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6824      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6825      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6826      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6827      &  +x(60)*xx*yy*zz
6828         dsc_i   = 0.743d0+x(61)
6829         dp2_i   = 1.9d0+x(62)
6830         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6831      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6832         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6833      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6834         s1=(1+x(63))/(0.1d0 + dscp1)
6835         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6836         s2=(1+x(65))/(0.1d0 + dscp2)
6837         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6838         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6839      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6840 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6841 c     &   sumene4,
6842 c     &   dscp1,dscp2,sumene
6843 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6844         escloc = escloc + sumene
6845 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6846 c     & ,zz,xx,yy
6847 c#define DEBUG
6848 #ifdef DEBUG
6849 C
6850 C This section to check the numerical derivatives of the energy of ith side
6851 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6852 C #define DEBUG in the code to turn it on.
6853 C
6854         write (2,*) "sumene               =",sumene
6855         aincr=1.0d-7
6856         xxsave=xx
6857         xx=xx+aincr
6858         write (2,*) xx,yy,zz
6859         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6860         de_dxx_num=(sumenep-sumene)/aincr
6861         xx=xxsave
6862         write (2,*) "xx+ sumene from enesc=",sumenep
6863         yysave=yy
6864         yy=yy+aincr
6865         write (2,*) xx,yy,zz
6866         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6867         de_dyy_num=(sumenep-sumene)/aincr
6868         yy=yysave
6869         write (2,*) "yy+ sumene from enesc=",sumenep
6870         zzsave=zz
6871         zz=zz+aincr
6872         write (2,*) xx,yy,zz
6873         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6874         de_dzz_num=(sumenep-sumene)/aincr
6875         zz=zzsave
6876         write (2,*) "zz+ sumene from enesc=",sumenep
6877         costsave=cost2tab(i+1)
6878         sintsave=sint2tab(i+1)
6879         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6880         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6881         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6882         de_dt_num=(sumenep-sumene)/aincr
6883         write (2,*) " t+ sumene from enesc=",sumenep
6884         cost2tab(i+1)=costsave
6885         sint2tab(i+1)=sintsave
6886 C End of diagnostics section.
6887 #endif
6888 C
6889 C Compute the gradient of esc
6890 C
6891 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6892         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6893         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6894         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6895         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6896         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6897         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6898         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6899         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6900         pom1=(sumene3*sint2tab(i+1)+sumene1)
6901      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6902         pom2=(sumene4*cost2tab(i+1)+sumene2)
6903      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6904         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6905         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6906      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6907      &  +x(40)*yy*zz
6908         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6909         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6910      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6911      &  +x(60)*yy*zz
6912         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6913      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6914      &        +(pom1+pom2)*pom_dx
6915 #ifdef DEBUG
6916         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6917 #endif
6918 C
6919         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6920         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6921      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6922      &  +x(40)*xx*zz
6923         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6924         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6925      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6926      &  +x(59)*zz**2 +x(60)*xx*zz
6927         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6928      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6929      &        +(pom1-pom2)*pom_dy
6930 #ifdef DEBUG
6931         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6932 #endif
6933 C
6934         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6935      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6936      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6937      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6938      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6939      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6940      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6941      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6942 #ifdef DEBUG
6943         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6944 #endif
6945 C
6946         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6947      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6948      &  +pom1*pom_dt1+pom2*pom_dt2
6949 #ifdef DEBUG
6950         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6951 #endif
6952 c#undef DEBUG
6953 c
6954 C
6955        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6956        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6957        cosfac2xx=cosfac2*xx
6958        sinfac2yy=sinfac2*yy
6959        do k = 1,3
6960          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6961      &      vbld_inv(i+1)
6962          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6963      &      vbld_inv(i)
6964          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6965          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6966 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6967 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6968 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6969 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6970          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6971          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6972          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6973          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6974          dZZ_Ci1(k)=0.0d0
6975          dZZ_Ci(k)=0.0d0
6976          do j=1,3
6977            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6978      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6979            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6980      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6981          enddo
6982
6983          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6984          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6985          dZZ_XYZ(k)=vbld_inv(i+nres)*
6986      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6987 c
6988          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6989          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6990        enddo
6991
6992        do k=1,3
6993          dXX_Ctab(k,i)=dXX_Ci(k)
6994          dXX_C1tab(k,i)=dXX_Ci1(k)
6995          dYY_Ctab(k,i)=dYY_Ci(k)
6996          dYY_C1tab(k,i)=dYY_Ci1(k)
6997          dZZ_Ctab(k,i)=dZZ_Ci(k)
6998          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6999          dXX_XYZtab(k,i)=dXX_XYZ(k)
7000          dYY_XYZtab(k,i)=dYY_XYZ(k)
7001          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7002        enddo
7003
7004        do k = 1,3
7005 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7006 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7007 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7008 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7009 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7010 c     &    dt_dci(k)
7011 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7012 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7013          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7014      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7015          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7016      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7017          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7018      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7019        enddo
7020 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7021 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7022
7023 C to check gradient call subroutine check_grad
7024
7025     1 continue
7026       enddo
7027       return
7028       end
7029 c------------------------------------------------------------------------------
7030       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7031       implicit none
7032       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7033      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7034       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7035      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7036      &   + x(10)*yy*zz
7037       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7038      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7039      & + x(20)*yy*zz
7040       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7041      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7042      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7043      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7044      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7045      &  +x(40)*xx*yy*zz
7046       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7047      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7048      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7049      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7050      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7051      &  +x(60)*xx*yy*zz
7052       dsc_i   = 0.743d0+x(61)
7053       dp2_i   = 1.9d0+x(62)
7054       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7055      &          *(xx*cost2+yy*sint2))
7056       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7057      &          *(xx*cost2-yy*sint2))
7058       s1=(1+x(63))/(0.1d0 + dscp1)
7059       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7060       s2=(1+x(65))/(0.1d0 + dscp2)
7061       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7062       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7063      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7064       enesc=sumene
7065       return
7066       end
7067 #endif
7068 c------------------------------------------------------------------------------
7069       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7070 C
7071 C This procedure calculates two-body contact function g(rij) and its derivative:
7072 C
7073 C           eps0ij                                     !       x < -1
7074 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7075 C            0                                         !       x > 1
7076 C
7077 C where x=(rij-r0ij)/delta
7078 C
7079 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7080 C
7081       implicit none
7082       double precision rij,r0ij,eps0ij,fcont,fprimcont
7083       double precision x,x2,x4,delta
7084 c     delta=0.02D0*r0ij
7085 c      delta=0.2D0*r0ij
7086       x=(rij-r0ij)/delta
7087       if (x.lt.-1.0D0) then
7088         fcont=eps0ij
7089         fprimcont=0.0D0
7090       else if (x.le.1.0D0) then
7091         x2=x*x
7092         x4=x2*x2
7093         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7094         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7095       else
7096         fcont=0.0D0
7097         fprimcont=0.0D0
7098       endif
7099       return
7100       end
7101 c------------------------------------------------------------------------------
7102       subroutine splinthet(theti,delta,ss,ssder)
7103       implicit real*8 (a-h,o-z)
7104       include 'DIMENSIONS'
7105       include 'COMMON.VAR'
7106       include 'COMMON.GEO'
7107       thetup=pi-delta
7108       thetlow=delta
7109       if (theti.gt.pipol) then
7110         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7111       else
7112         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7113         ssder=-ssder
7114       endif
7115       return
7116       end
7117 c------------------------------------------------------------------------------
7118       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7119       implicit none
7120       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7121       double precision ksi,ksi2,ksi3,a1,a2,a3
7122       a1=fprim0*delta/(f1-f0)
7123       a2=3.0d0-2.0d0*a1
7124       a3=a1-2.0d0
7125       ksi=(x-x0)/delta
7126       ksi2=ksi*ksi
7127       ksi3=ksi2*ksi
7128       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7129       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7130       return
7131       end
7132 c------------------------------------------------------------------------------
7133       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7134       implicit none
7135       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7136       double precision ksi,ksi2,ksi3,a1,a2,a3
7137       ksi=(x-x0)/delta
7138       ksi2=ksi*ksi
7139       ksi3=ksi2*ksi
7140       a1=fprim0x*delta
7141       a2=3*(f1x-f0x)-2*fprim0x*delta
7142       a3=fprim0x*delta-2*(f1x-f0x)
7143       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7144       return
7145       end
7146 C-----------------------------------------------------------------------------
7147 #ifdef CRYST_TOR
7148 C-----------------------------------------------------------------------------
7149       subroutine etor(etors,edihcnstr)
7150       implicit real*8 (a-h,o-z)
7151       include 'DIMENSIONS'
7152       include 'COMMON.VAR'
7153       include 'COMMON.GEO'
7154       include 'COMMON.LOCAL'
7155       include 'COMMON.TORSION'
7156       include 'COMMON.INTERACT'
7157       include 'COMMON.DERIV'
7158       include 'COMMON.CHAIN'
7159       include 'COMMON.NAMES'
7160       include 'COMMON.IOUNITS'
7161       include 'COMMON.FFIELD'
7162       include 'COMMON.TORCNSTR'
7163       include 'COMMON.CONTROL'
7164       logical lprn
7165 C Set lprn=.true. for debugging
7166       lprn=.false.
7167 c      lprn=.true.
7168       etors=0.0D0
7169       do i=iphi_start,iphi_end
7170       etors_ii=0.0D0
7171         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7172      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7173         itori=itortyp(itype(i-2))
7174         itori1=itortyp(itype(i-1))
7175         phii=phi(i)
7176         gloci=0.0D0
7177 C Proline-Proline pair is a special case...
7178         if (itori.eq.3 .and. itori1.eq.3) then
7179           if (phii.gt.-dwapi3) then
7180             cosphi=dcos(3*phii)
7181             fac=1.0D0/(1.0D0-cosphi)
7182             etorsi=v1(1,3,3)*fac
7183             etorsi=etorsi+etorsi
7184             etors=etors+etorsi-v1(1,3,3)
7185             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7186             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7187           endif
7188           do j=1,3
7189             v1ij=v1(j+1,itori,itori1)
7190             v2ij=v2(j+1,itori,itori1)
7191             cosphi=dcos(j*phii)
7192             sinphi=dsin(j*phii)
7193             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7194             if (energy_dec) etors_ii=etors_ii+
7195      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7196             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7197           enddo
7198         else
7199           do j=1,nterm_old
7200             v1ij=v1(j,itori,itori1)
7201             v2ij=v2(j,itori,itori1)
7202             cosphi=dcos(j*phii)
7203             sinphi=dsin(j*phii)
7204             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7205             if (energy_dec) etors_ii=etors_ii+
7206      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7207             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7208           enddo
7209         endif
7210         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7211              'etor',i,etors_ii
7212         if (lprn)
7213      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7214      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7215      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7216         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7217 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7218       enddo
7219 ! 6/20/98 - dihedral angle constraints
7220       edihcnstr=0.0d0
7221       do i=1,ndih_constr
7222         itori=idih_constr(i)
7223         phii=phi(itori)
7224         difi=phii-phi0(i)
7225         if (difi.gt.drange(i)) then
7226           difi=difi-drange(i)
7227           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7228           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7229         else if (difi.lt.-drange(i)) then
7230           difi=difi+drange(i)
7231           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7232           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7233         endif
7234 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7235 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7236       enddo
7237 !      write (iout,*) 'edihcnstr',edihcnstr
7238       return
7239       end
7240 c------------------------------------------------------------------------------
7241       subroutine etor_d(etors_d)
7242       etors_d=0.0d0
7243       return
7244       end
7245 c----------------------------------------------------------------------------
7246 #else
7247       subroutine etor(etors,edihcnstr)
7248       implicit real*8 (a-h,o-z)
7249       include 'DIMENSIONS'
7250       include 'COMMON.VAR'
7251       include 'COMMON.GEO'
7252       include 'COMMON.LOCAL'
7253       include 'COMMON.TORSION'
7254       include 'COMMON.INTERACT'
7255       include 'COMMON.DERIV'
7256       include 'COMMON.CHAIN'
7257       include 'COMMON.NAMES'
7258       include 'COMMON.IOUNITS'
7259       include 'COMMON.FFIELD'
7260       include 'COMMON.TORCNSTR'
7261       include 'COMMON.CONTROL'
7262       logical lprn
7263 C Set lprn=.true. for debugging
7264       lprn=.false.
7265 c     lprn=.true.
7266       etors=0.0D0
7267       do i=iphi_start,iphi_end
7268 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7269 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7270 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7271 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7272         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7273      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7274 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7275 C For introducing the NH3+ and COO- group please check the etor_d for reference
7276 C and guidance
7277         etors_ii=0.0D0
7278          if (iabs(itype(i)).eq.20) then
7279          iblock=2
7280          else
7281          iblock=1
7282          endif
7283         itori=itortyp(itype(i-2))
7284         itori1=itortyp(itype(i-1))
7285         phii=phi(i)
7286         gloci=0.0D0
7287 C Regular cosine and sine terms
7288         do j=1,nterm(itori,itori1,iblock)
7289           v1ij=v1(j,itori,itori1,iblock)
7290           v2ij=v2(j,itori,itori1,iblock)
7291           cosphi=dcos(j*phii)
7292           sinphi=dsin(j*phii)
7293           etors=etors+v1ij*cosphi+v2ij*sinphi
7294           if (energy_dec) etors_ii=etors_ii+
7295      &                v1ij*cosphi+v2ij*sinphi
7296           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7297         enddo
7298 C Lorentz terms
7299 C                         v1
7300 C  E = SUM ----------------------------------- - v1
7301 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7302 C
7303         cosphi=dcos(0.5d0*phii)
7304         sinphi=dsin(0.5d0*phii)
7305         do j=1,nlor(itori,itori1,iblock)
7306           vl1ij=vlor1(j,itori,itori1)
7307           vl2ij=vlor2(j,itori,itori1)
7308           vl3ij=vlor3(j,itori,itori1)
7309           pom=vl2ij*cosphi+vl3ij*sinphi
7310           pom1=1.0d0/(pom*pom+1.0d0)
7311           etors=etors+vl1ij*pom1
7312           if (energy_dec) etors_ii=etors_ii+
7313      &                vl1ij*pom1
7314           pom=-pom*pom1*pom1
7315           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7316         enddo
7317 C Subtract the constant term
7318         etors=etors-v0(itori,itori1,iblock)
7319           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7320      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7321         if (lprn)
7322      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7323      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7324      &  (v1(j,itori,itori1,iblock),j=1,6),
7325      &  (v2(j,itori,itori1,iblock),j=1,6)
7326         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7327 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7328       enddo
7329 ! 6/20/98 - dihedral angle constraints
7330       edihcnstr=0.0d0
7331 c      do i=1,ndih_constr
7332       do i=idihconstr_start,idihconstr_end
7333         itori=idih_constr(i)
7334         phii=phi(itori)
7335         difi=pinorm(phii-phi0(i))
7336         if (difi.gt.drange(i)) then
7337           difi=difi-drange(i)
7338           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7339           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7340         else if (difi.lt.-drange(i)) then
7341           difi=difi+drange(i)
7342           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7343           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7344         else
7345           difi=0.0
7346         endif
7347        if (energy_dec) then
7348         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7349      &    i,itori,rad2deg*phii,
7350      &    rad2deg*phi0(i),  rad2deg*drange(i),
7351      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7352         endif
7353       enddo
7354 cd       write (iout,*) 'edihcnstr',edihcnstr
7355       return
7356       end
7357 c----------------------------------------------------------------------------
7358       subroutine etor_d(etors_d)
7359 C 6/23/01 Compute double torsional energy
7360       implicit real*8 (a-h,o-z)
7361       include 'DIMENSIONS'
7362       include 'COMMON.VAR'
7363       include 'COMMON.GEO'
7364       include 'COMMON.LOCAL'
7365       include 'COMMON.TORSION'
7366       include 'COMMON.INTERACT'
7367       include 'COMMON.DERIV'
7368       include 'COMMON.CHAIN'
7369       include 'COMMON.NAMES'
7370       include 'COMMON.IOUNITS'
7371       include 'COMMON.FFIELD'
7372       include 'COMMON.TORCNSTR'
7373       logical lprn
7374 C Set lprn=.true. for debugging
7375       lprn=.false.
7376 c     lprn=.true.
7377       etors_d=0.0D0
7378 c      write(iout,*) "a tu??"
7379       do i=iphid_start,iphid_end
7380 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7381 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7382 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7383 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7384 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7385          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7386      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7387      &  (itype(i+1).eq.ntyp1)) cycle
7388 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7389         itori=itortyp(itype(i-2))
7390         itori1=itortyp(itype(i-1))
7391         itori2=itortyp(itype(i))
7392         phii=phi(i)
7393         phii1=phi(i+1)
7394         gloci1=0.0D0
7395         gloci2=0.0D0
7396         iblock=1
7397         if (iabs(itype(i+1)).eq.20) iblock=2
7398 C Iblock=2 Proline type
7399 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7400 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7401 C        if (itype(i+1).eq.ntyp1) iblock=3
7402 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7403 C IS or IS NOT need for this
7404 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7405 C        is (itype(i-3).eq.ntyp1) ntblock=2
7406 C        ntblock is N-terminal blocking group
7407
7408 C Regular cosine and sine terms
7409         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7410 C Example of changes for NH3+ blocking group
7411 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7412 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7413           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7414           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7415           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7416           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7417           cosphi1=dcos(j*phii)
7418           sinphi1=dsin(j*phii)
7419           cosphi2=dcos(j*phii1)
7420           sinphi2=dsin(j*phii1)
7421           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7422      &     v2cij*cosphi2+v2sij*sinphi2
7423           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7424           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7425         enddo
7426         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7427           do l=1,k-1
7428             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7429             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7430             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7431             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7432             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7433             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7434             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7435             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7436             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7437      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7438             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7439      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7440             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7441      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7442           enddo
7443         enddo
7444         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7445         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7446       enddo
7447       return
7448       end
7449 #endif
7450 C----------------------------------------------------------------------------------
7451 C The rigorous attempt to derive energy function
7452       subroutine etor_kcc(etors,edihcnstr)
7453       implicit real*8 (a-h,o-z)
7454       include 'DIMENSIONS'
7455       include 'COMMON.VAR'
7456       include 'COMMON.GEO'
7457       include 'COMMON.LOCAL'
7458       include 'COMMON.TORSION'
7459       include 'COMMON.INTERACT'
7460       include 'COMMON.DERIV'
7461       include 'COMMON.CHAIN'
7462       include 'COMMON.NAMES'
7463       include 'COMMON.IOUNITS'
7464       include 'COMMON.FFIELD'
7465       include 'COMMON.TORCNSTR'
7466       include 'COMMON.CONTROL'
7467       logical lprn
7468       double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7469 C Set lprn=.true. for debugging
7470       lprn=.false.
7471 c     lprn=.true.
7472 C      print *,"wchodze kcc"
7473       if (tor_mode.ne.2) then
7474       etors=0.0D0
7475       endif
7476       do i=iphi_start,iphi_end
7477 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7478 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7479 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7480 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7481         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7482      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7483         itori=itortyp_kcc(itype(i-2))
7484         itori1=itortyp_kcc(itype(i-1))
7485         phii=phi(i)
7486         glocig=0.0D0
7487         glocit1=0.0d0
7488         glocit2=0.0d0
7489         sumnonchebyshev=0.0d0
7490         sumchebyshev=0.0d0
7491 C to avoid multiple devision by 2
7492         theti22=0.5d0*theta(i)
7493 C theta 12 is the theta_1 /2
7494 C theta 22 is theta_2 /2
7495         theti12=0.5d0*theta(i-1)
7496 C and appropriate sinus function
7497         sinthet2=dsin(theta(i))
7498         sinthet1=dsin(theta(i-1))
7499         costhet1=dcos(theta(i-1))
7500         costhet2=dcos(theta(i))
7501 C to speed up lets store its mutliplication
7502          sint1t2=sinthet2*sinthet1
7503 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7504 C +d_n*sin(n*gamma)) *
7505 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7506 C we have two sum 1) Non-Chebyshev which is with n and gamma
7507         do j=1,nterm_kcc(itori,itori1)
7508
7509           v1ij=v1_kcc(j,itori,itori1)
7510           v2ij=v2_kcc(j,itori,itori1)
7511 C v1ij is c_n and d_n in euation above
7512           cosphi=dcos(j*phii)
7513           sinphi=dsin(j*phii)
7514           sint1t2n=sint1t2**j
7515           sumnonchebyshev=
7516      &                    sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7517           actval=sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7518 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7519 C          if (energy_dec) etors_ii=etors_ii+
7520 C     &                v1ij*cosphi+v2ij*sinphi
7521 C glocig is the gradient local i site in gamma
7522           glocig=j*(v2ij*cosphi-v1ij*sinphi)*sint1t2n
7523 C now gradient over theta_1
7524           glocit1=actval/sinthet1*j*costhet1
7525           glocit2=actval/sinthet2*j*costhet2
7526
7527 C now the Czebyshev polinominal sum
7528         do k=1,nterm_kcc_Tb(itori,itori1)
7529          thybt1(k)=v1_chyb(k,j,itori,itori1)
7530          thybt2(k)=v2_chyb(k,j,itori,itori1)
7531 C         thybt1(k)=0.0
7532 C         thybt2(k)=0.0
7533         enddo
7534         sumth1thyb=tschebyshev
7535      &         (1,nterm_kcc_Tb(itori,itori1),thybt1(1),dcos(theti12)**2)
7536         gradthybt1=gradtschebyshev
7537      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt1(1),
7538      &        dcos(theti12)**2)
7539      & *dcos(theti12)*(-dsin(theti12))
7540         sumth2thyb=tschebyshev
7541      &         (1,nterm_kcc_Tb(itori,itori1),thybt2(1),dcos(theti22)**2)
7542         gradthybt2=gradtschebyshev
7543      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7544      &         dcos(theti22)**2)
7545      & *dcos(theti22)*(-dsin(theti22))
7546 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7547 C     &         gradtschebyshev
7548 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7549 C     &         dcos(theti22)**2),
7550 C     &         dsin(theti22)
7551
7552 C now overal sumation
7553          etors=etors+(1.0d0+sumth1thyb+sumth2thyb)*sumnonchebyshev
7554 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7555 C derivative over gamma
7556          gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7557      &   *(1.0d0+sumth1thyb+sumth2thyb)
7558 C derivative over theta1
7559         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*
7560      &  (glocit1*(1.0d0+sumth1thyb+sumth2thyb)+
7561      &   sumnonchebyshev*gradthybt1)
7562 C now derivative over theta2
7563         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*
7564      &  (glocit2*(1.0d0+sumth1thyb+sumth2thyb)+
7565      &   sumnonchebyshev*gradthybt2)
7566        enddo
7567       enddo
7568
7569 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7570 ! 6/20/98 - dihedral angle constraints
7571       if (tor_mode.ne.2) then
7572       edihcnstr=0.0d0
7573 c      do i=1,ndih_constr
7574       do i=idihconstr_start,idihconstr_end
7575         itori=idih_constr(i)
7576         phii=phi(itori)
7577         difi=pinorm(phii-phi0(i))
7578         if (difi.gt.drange(i)) then
7579           difi=difi-drange(i)
7580           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7581           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7582         else if (difi.lt.-drange(i)) then
7583           difi=difi+drange(i)
7584           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7585           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7586         else
7587           difi=0.0
7588         endif
7589        enddo
7590        endif
7591       return
7592       end
7593
7594 C The rigorous attempt to derive energy function
7595       subroutine ebend_kcc(etheta,ethetacnstr)
7596
7597       implicit real*8 (a-h,o-z)
7598       include 'DIMENSIONS'
7599       include 'COMMON.VAR'
7600       include 'COMMON.GEO'
7601       include 'COMMON.LOCAL'
7602       include 'COMMON.TORSION'
7603       include 'COMMON.INTERACT'
7604       include 'COMMON.DERIV'
7605       include 'COMMON.CHAIN'
7606       include 'COMMON.NAMES'
7607       include 'COMMON.IOUNITS'
7608       include 'COMMON.FFIELD'
7609       include 'COMMON.TORCNSTR'
7610       include 'COMMON.CONTROL'
7611       logical lprn
7612       double precision thybt1(maxtermkcc)
7613 C Set lprn=.true. for debugging
7614       lprn=.false.
7615 c     lprn=.true.
7616 C      print *,"wchodze kcc"
7617       if (tormode.ne.2) etheta=0.0D0
7618       do i=ithet_start,ithet_end
7619 c        print *,i,itype(i-1),itype(i),itype(i-2)
7620         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7621      &  .or.itype(i).eq.ntyp1) cycle
7622          iti=itortyp_kcc(itype(i-1))
7623         sinthet=dsin(theta(i)/2.0d0)
7624         costhet=dcos(theta(i)/2.0d0)
7625          do j=1,nbend_kcc_Tb(iti)
7626           thybt1(j)=v1bend_chyb(j,iti)
7627          enddo
7628          sumth1thyb=tschebyshev
7629      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7630         ihelp=nbend_kcc_Tb(iti)-1
7631         gradthybt1=gradtschebyshev
7632      &         (0,ihelp,thybt1(1),costhet)
7633         etheta=etheta+sumth1thyb
7634 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7635         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7636      &   gradthybt1*sinthet*(-0.5d0)
7637       enddo
7638       if (tormode.ne.2) then
7639       ethetacnstr=0.0d0
7640 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7641       do i=ithetaconstr_start,ithetaconstr_end
7642         itheta=itheta_constr(i)
7643         thetiii=theta(itheta)
7644         difi=pinorm(thetiii-theta_constr0(i))
7645         if (difi.gt.theta_drange(i)) then
7646           difi=difi-theta_drange(i)
7647           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7648           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7649      &    +for_thet_constr(i)*difi**3
7650         else if (difi.lt.-drange(i)) then
7651           difi=difi+drange(i)
7652           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7653           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7654      &    +for_thet_constr(i)*difi**3
7655         else
7656           difi=0.0
7657         endif
7658        if (energy_dec) then
7659         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7660      &    i,itheta,rad2deg*thetiii,
7661      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7662      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7663      &    gloc(itheta+nphi-2,icg)
7664         endif
7665       enddo
7666       endif
7667       return
7668       end
7669 c------------------------------------------------------------------------------
7670       subroutine eback_sc_corr(esccor)
7671 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7672 c        conformational states; temporarily implemented as differences
7673 c        between UNRES torsional potentials (dependent on three types of
7674 c        residues) and the torsional potentials dependent on all 20 types
7675 c        of residues computed from AM1  energy surfaces of terminally-blocked
7676 c        amino-acid residues.
7677       implicit real*8 (a-h,o-z)
7678       include 'DIMENSIONS'
7679       include 'COMMON.VAR'
7680       include 'COMMON.GEO'
7681       include 'COMMON.LOCAL'
7682       include 'COMMON.TORSION'
7683       include 'COMMON.SCCOR'
7684       include 'COMMON.INTERACT'
7685       include 'COMMON.DERIV'
7686       include 'COMMON.CHAIN'
7687       include 'COMMON.NAMES'
7688       include 'COMMON.IOUNITS'
7689       include 'COMMON.FFIELD'
7690       include 'COMMON.CONTROL'
7691       logical lprn
7692 C Set lprn=.true. for debugging
7693       lprn=.false.
7694 c      lprn=.true.
7695 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7696       esccor=0.0D0
7697       do i=itau_start,itau_end
7698         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7699         esccor_ii=0.0D0
7700         isccori=isccortyp(itype(i-2))
7701         isccori1=isccortyp(itype(i-1))
7702 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7703         phii=phi(i)
7704         do intertyp=1,3 !intertyp
7705 cc Added 09 May 2012 (Adasko)
7706 cc  Intertyp means interaction type of backbone mainchain correlation:
7707 c   1 = SC...Ca...Ca...Ca
7708 c   2 = Ca...Ca...Ca...SC
7709 c   3 = SC...Ca...Ca...SCi
7710         gloci=0.0D0
7711         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7712      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7713      &      (itype(i-1).eq.ntyp1)))
7714      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7715      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7716      &     .or.(itype(i).eq.ntyp1)))
7717      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7718      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7719      &      (itype(i-3).eq.ntyp1)))) cycle
7720         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7721         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7722      & cycle
7723        do j=1,nterm_sccor(isccori,isccori1)
7724           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7725           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7726           cosphi=dcos(j*tauangle(intertyp,i))
7727           sinphi=dsin(j*tauangle(intertyp,i))
7728           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7729           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7730         enddo
7731 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7732         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7733         if (lprn)
7734      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7735      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7736      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7737      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7738         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7739        enddo !intertyp
7740       enddo
7741
7742       return
7743       end
7744 c----------------------------------------------------------------------------
7745       subroutine multibody(ecorr)
7746 C This subroutine calculates multi-body contributions to energy following
7747 C the idea of Skolnick et al. If side chains I and J make a contact and
7748 C at the same time side chains I+1 and J+1 make a contact, an extra
7749 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7750       implicit real*8 (a-h,o-z)
7751       include 'DIMENSIONS'
7752       include 'COMMON.IOUNITS'
7753       include 'COMMON.DERIV'
7754       include 'COMMON.INTERACT'
7755       include 'COMMON.CONTACTS'
7756       double precision gx(3),gx1(3)
7757       logical lprn
7758
7759 C Set lprn=.true. for debugging
7760       lprn=.false.
7761
7762       if (lprn) then
7763         write (iout,'(a)') 'Contact function values:'
7764         do i=nnt,nct-2
7765           write (iout,'(i2,20(1x,i2,f10.5))')
7766      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7767         enddo
7768       endif
7769       ecorr=0.0D0
7770       do i=nnt,nct
7771         do j=1,3
7772           gradcorr(j,i)=0.0D0
7773           gradxorr(j,i)=0.0D0
7774         enddo
7775       enddo
7776       do i=nnt,nct-2
7777
7778         DO ISHIFT = 3,4
7779
7780         i1=i+ishift
7781         num_conti=num_cont(i)
7782         num_conti1=num_cont(i1)
7783         do jj=1,num_conti
7784           j=jcont(jj,i)
7785           do kk=1,num_conti1
7786             j1=jcont(kk,i1)
7787             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7788 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7789 cd   &                   ' ishift=',ishift
7790 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7791 C The system gains extra energy.
7792               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7793             endif   ! j1==j+-ishift
7794           enddo     ! kk
7795         enddo       ! jj
7796
7797         ENDDO ! ISHIFT
7798
7799       enddo         ! i
7800       return
7801       end
7802 c------------------------------------------------------------------------------
7803       double precision function esccorr(i,j,k,l,jj,kk)
7804       implicit real*8 (a-h,o-z)
7805       include 'DIMENSIONS'
7806       include 'COMMON.IOUNITS'
7807       include 'COMMON.DERIV'
7808       include 'COMMON.INTERACT'
7809       include 'COMMON.CONTACTS'
7810       include 'COMMON.SHIELD'
7811       double precision gx(3),gx1(3)
7812       logical lprn
7813       lprn=.false.
7814       eij=facont(jj,i)
7815       ekl=facont(kk,k)
7816 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7817 C Calculate the multi-body contribution to energy.
7818 C Calculate multi-body contributions to the gradient.
7819 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7820 cd   & k,l,(gacont(m,kk,k),m=1,3)
7821       do m=1,3
7822         gx(m) =ekl*gacont(m,jj,i)
7823         gx1(m)=eij*gacont(m,kk,k)
7824         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7825         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7826         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7827         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7828       enddo
7829       do m=i,j-1
7830         do ll=1,3
7831           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7832         enddo
7833       enddo
7834       do m=k,l-1
7835         do ll=1,3
7836           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7837         enddo
7838       enddo
7839       esccorr=-eij*ekl
7840       return
7841       end
7842 c------------------------------------------------------------------------------
7843       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7844 C This subroutine calculates multi-body contributions to hydrogen-bonding
7845       implicit real*8 (a-h,o-z)
7846       include 'DIMENSIONS'
7847       include 'COMMON.IOUNITS'
7848 #ifdef MPI
7849       include "mpif.h"
7850       parameter (max_cont=maxconts)
7851       parameter (max_dim=26)
7852       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7853       double precision zapas(max_dim,maxconts,max_fg_procs),
7854      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7855       common /przechowalnia/ zapas
7856       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7857      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7858 #endif
7859       include 'COMMON.SETUP'
7860       include 'COMMON.FFIELD'
7861       include 'COMMON.DERIV'
7862       include 'COMMON.INTERACT'
7863       include 'COMMON.CONTACTS'
7864       include 'COMMON.CONTROL'
7865       include 'COMMON.LOCAL'
7866       double precision gx(3),gx1(3),time00
7867       logical lprn,ldone
7868
7869 C Set lprn=.true. for debugging
7870       lprn=.false.
7871 #ifdef MPI
7872       n_corr=0
7873       n_corr1=0
7874       if (nfgtasks.le.1) goto 30
7875       if (lprn) then
7876         write (iout,'(a)') 'Contact function values before RECEIVE:'
7877         do i=nnt,nct-2
7878           write (iout,'(2i3,50(1x,i2,f5.2))')
7879      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7880      &    j=1,num_cont_hb(i))
7881         enddo
7882       endif
7883       call flush(iout)
7884       do i=1,ntask_cont_from
7885         ncont_recv(i)=0
7886       enddo
7887       do i=1,ntask_cont_to
7888         ncont_sent(i)=0
7889       enddo
7890 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7891 c     & ntask_cont_to
7892 C Make the list of contacts to send to send to other procesors
7893 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7894 c      call flush(iout)
7895       do i=iturn3_start,iturn3_end
7896 c        write (iout,*) "make contact list turn3",i," num_cont",
7897 c     &    num_cont_hb(i)
7898         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7899       enddo
7900       do i=iturn4_start,iturn4_end
7901 c        write (iout,*) "make contact list turn4",i," num_cont",
7902 c     &   num_cont_hb(i)
7903         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7904       enddo
7905       do ii=1,nat_sent
7906         i=iat_sent(ii)
7907 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7908 c     &    num_cont_hb(i)
7909         do j=1,num_cont_hb(i)
7910         do k=1,4
7911           jjc=jcont_hb(j,i)
7912           iproc=iint_sent_local(k,jjc,ii)
7913 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7914           if (iproc.gt.0) then
7915             ncont_sent(iproc)=ncont_sent(iproc)+1
7916             nn=ncont_sent(iproc)
7917             zapas(1,nn,iproc)=i
7918             zapas(2,nn,iproc)=jjc
7919             zapas(3,nn,iproc)=facont_hb(j,i)
7920             zapas(4,nn,iproc)=ees0p(j,i)
7921             zapas(5,nn,iproc)=ees0m(j,i)
7922             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7923             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7924             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7925             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7926             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7927             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7928             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7929             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7930             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7931             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7932             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7933             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7934             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7935             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7936             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7937             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7938             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7939             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7940             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7941             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7942             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7943           endif
7944         enddo
7945         enddo
7946       enddo
7947       if (lprn) then
7948       write (iout,*)
7949      &  "Numbers of contacts to be sent to other processors",
7950      &  (ncont_sent(i),i=1,ntask_cont_to)
7951       write (iout,*) "Contacts sent"
7952       do ii=1,ntask_cont_to
7953         nn=ncont_sent(ii)
7954         iproc=itask_cont_to(ii)
7955         write (iout,*) nn," contacts to processor",iproc,
7956      &   " of CONT_TO_COMM group"
7957         do i=1,nn
7958           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7959         enddo
7960       enddo
7961       call flush(iout)
7962       endif
7963       CorrelType=477
7964       CorrelID=fg_rank+1
7965       CorrelType1=478
7966       CorrelID1=nfgtasks+fg_rank+1
7967       ireq=0
7968 C Receive the numbers of needed contacts from other processors
7969       do ii=1,ntask_cont_from
7970         iproc=itask_cont_from(ii)
7971         ireq=ireq+1
7972         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7973      &    FG_COMM,req(ireq),IERR)
7974       enddo
7975 c      write (iout,*) "IRECV ended"
7976 c      call flush(iout)
7977 C Send the number of contacts needed by other processors
7978       do ii=1,ntask_cont_to
7979         iproc=itask_cont_to(ii)
7980         ireq=ireq+1
7981         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7982      &    FG_COMM,req(ireq),IERR)
7983       enddo
7984 c      write (iout,*) "ISEND ended"
7985 c      write (iout,*) "number of requests (nn)",ireq
7986       call flush(iout)
7987       if (ireq.gt.0)
7988      &  call MPI_Waitall(ireq,req,status_array,ierr)
7989 c      write (iout,*)
7990 c     &  "Numbers of contacts to be received from other processors",
7991 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7992 c      call flush(iout)
7993 C Receive contacts
7994       ireq=0
7995       do ii=1,ntask_cont_from
7996         iproc=itask_cont_from(ii)
7997         nn=ncont_recv(ii)
7998 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7999 c     &   " of CONT_TO_COMM group"
8000         call flush(iout)
8001         if (nn.gt.0) then
8002           ireq=ireq+1
8003           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8004      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8005 c          write (iout,*) "ireq,req",ireq,req(ireq)
8006         endif
8007       enddo
8008 C Send the contacts to processors that need them
8009       do ii=1,ntask_cont_to
8010         iproc=itask_cont_to(ii)
8011         nn=ncont_sent(ii)
8012 c        write (iout,*) nn," contacts to processor",iproc,
8013 c     &   " of CONT_TO_COMM group"
8014         if (nn.gt.0) then
8015           ireq=ireq+1
8016           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8017      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8018 c          write (iout,*) "ireq,req",ireq,req(ireq)
8019 c          do i=1,nn
8020 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8021 c          enddo
8022         endif
8023       enddo
8024 c      write (iout,*) "number of requests (contacts)",ireq
8025 c      write (iout,*) "req",(req(i),i=1,4)
8026 c      call flush(iout)
8027       if (ireq.gt.0)
8028      & call MPI_Waitall(ireq,req,status_array,ierr)
8029       do iii=1,ntask_cont_from
8030         iproc=itask_cont_from(iii)
8031         nn=ncont_recv(iii)
8032         if (lprn) then
8033         write (iout,*) "Received",nn," contacts from processor",iproc,
8034      &   " of CONT_FROM_COMM group"
8035         call flush(iout)
8036         do i=1,nn
8037           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8038         enddo
8039         call flush(iout)
8040         endif
8041         do i=1,nn
8042           ii=zapas_recv(1,i,iii)
8043 c Flag the received contacts to prevent double-counting
8044           jj=-zapas_recv(2,i,iii)
8045 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8046 c          call flush(iout)
8047           nnn=num_cont_hb(ii)+1
8048           num_cont_hb(ii)=nnn
8049           jcont_hb(nnn,ii)=jj
8050           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8051           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8052           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8053           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8054           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8055           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8056           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8057           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8058           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8059           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8060           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8061           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8062           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8063           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8064           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8065           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8066           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8067           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8068           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8069           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8070           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8071           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8072           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8073           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8074         enddo
8075       enddo
8076       call flush(iout)
8077       if (lprn) then
8078         write (iout,'(a)') 'Contact function values after receive:'
8079         do i=nnt,nct-2
8080           write (iout,'(2i3,50(1x,i3,f5.2))')
8081      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8082      &    j=1,num_cont_hb(i))
8083         enddo
8084         call flush(iout)
8085       endif
8086    30 continue
8087 #endif
8088       if (lprn) then
8089         write (iout,'(a)') 'Contact function values:'
8090         do i=nnt,nct-2
8091           write (iout,'(2i3,50(1x,i3,f5.2))')
8092      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8093      &    j=1,num_cont_hb(i))
8094         enddo
8095       endif
8096       ecorr=0.0D0
8097 C Remove the loop below after debugging !!!
8098       do i=nnt,nct
8099         do j=1,3
8100           gradcorr(j,i)=0.0D0
8101           gradxorr(j,i)=0.0D0
8102         enddo
8103       enddo
8104 C Calculate the local-electrostatic correlation terms
8105       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8106         i1=i+1
8107         num_conti=num_cont_hb(i)
8108         num_conti1=num_cont_hb(i+1)
8109         do jj=1,num_conti
8110           j=jcont_hb(jj,i)
8111           jp=iabs(j)
8112           do kk=1,num_conti1
8113             j1=jcont_hb(kk,i1)
8114             jp1=iabs(j1)
8115 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8116 c     &         ' jj=',jj,' kk=',kk
8117             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8118      &          .or. j.lt.0 .and. j1.gt.0) .and.
8119      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8120 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8121 C The system gains extra energy.
8122               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8123               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8124      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8125               n_corr=n_corr+1
8126             else if (j1.eq.j) then
8127 C Contacts I-J and I-(J+1) occur simultaneously.
8128 C The system loses extra energy.
8129 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8130             endif
8131           enddo ! kk
8132           do kk=1,num_conti
8133             j1=jcont_hb(kk,i)
8134 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8135 c    &         ' jj=',jj,' kk=',kk
8136             if (j1.eq.j+1) then
8137 C Contacts I-J and (I+1)-J occur simultaneously.
8138 C The system loses extra energy.
8139 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8140             endif ! j1==j+1
8141           enddo ! kk
8142         enddo ! jj
8143       enddo ! i
8144       return
8145       end
8146 c------------------------------------------------------------------------------
8147       subroutine add_hb_contact(ii,jj,itask)
8148       implicit real*8 (a-h,o-z)
8149       include "DIMENSIONS"
8150       include "COMMON.IOUNITS"
8151       integer max_cont
8152       integer max_dim
8153       parameter (max_cont=maxconts)
8154       parameter (max_dim=26)
8155       include "COMMON.CONTACTS"
8156       double precision zapas(max_dim,maxconts,max_fg_procs),
8157      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8158       common /przechowalnia/ zapas
8159       integer i,j,ii,jj,iproc,itask(4),nn
8160 c      write (iout,*) "itask",itask
8161       do i=1,2
8162         iproc=itask(i)
8163         if (iproc.gt.0) then
8164           do j=1,num_cont_hb(ii)
8165             jjc=jcont_hb(j,ii)
8166 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8167             if (jjc.eq.jj) then
8168               ncont_sent(iproc)=ncont_sent(iproc)+1
8169               nn=ncont_sent(iproc)
8170               zapas(1,nn,iproc)=ii
8171               zapas(2,nn,iproc)=jjc
8172               zapas(3,nn,iproc)=facont_hb(j,ii)
8173               zapas(4,nn,iproc)=ees0p(j,ii)
8174               zapas(5,nn,iproc)=ees0m(j,ii)
8175               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8176               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8177               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8178               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8179               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8180               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8181               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8182               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8183               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8184               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8185               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8186               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8187               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8188               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8189               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8190               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8191               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8192               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8193               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8194               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8195               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8196               exit
8197             endif
8198           enddo
8199         endif
8200       enddo
8201       return
8202       end
8203 c------------------------------------------------------------------------------
8204       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8205      &  n_corr1)
8206 C This subroutine calculates multi-body contributions to hydrogen-bonding
8207       implicit real*8 (a-h,o-z)
8208       include 'DIMENSIONS'
8209       include 'COMMON.IOUNITS'
8210 #ifdef MPI
8211       include "mpif.h"
8212       parameter (max_cont=maxconts)
8213       parameter (max_dim=70)
8214       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8215       double precision zapas(max_dim,maxconts,max_fg_procs),
8216      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8217       common /przechowalnia/ zapas
8218       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8219      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8220 #endif
8221       include 'COMMON.SETUP'
8222       include 'COMMON.FFIELD'
8223       include 'COMMON.DERIV'
8224       include 'COMMON.LOCAL'
8225       include 'COMMON.INTERACT'
8226       include 'COMMON.CONTACTS'
8227       include 'COMMON.CHAIN'
8228       include 'COMMON.CONTROL'
8229       include 'COMMON.SHIELD'
8230       double precision gx(3),gx1(3)
8231       integer num_cont_hb_old(maxres)
8232       logical lprn,ldone
8233       double precision eello4,eello5,eelo6,eello_turn6
8234       external eello4,eello5,eello6,eello_turn6
8235 C Set lprn=.true. for debugging
8236       lprn=.false.
8237       eturn6=0.0d0
8238 #ifdef MPI
8239       do i=1,nres
8240         num_cont_hb_old(i)=num_cont_hb(i)
8241       enddo
8242       n_corr=0
8243       n_corr1=0
8244       if (nfgtasks.le.1) goto 30
8245       if (lprn) then
8246         write (iout,'(a)') 'Contact function values before RECEIVE:'
8247         do i=nnt,nct-2
8248           write (iout,'(2i3,50(1x,i2,f5.2))')
8249      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8250      &    j=1,num_cont_hb(i))
8251         enddo
8252       endif
8253       call flush(iout)
8254       do i=1,ntask_cont_from
8255         ncont_recv(i)=0
8256       enddo
8257       do i=1,ntask_cont_to
8258         ncont_sent(i)=0
8259       enddo
8260 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8261 c     & ntask_cont_to
8262 C Make the list of contacts to send to send to other procesors
8263       do i=iturn3_start,iturn3_end
8264 c        write (iout,*) "make contact list turn3",i," num_cont",
8265 c     &    num_cont_hb(i)
8266         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8267       enddo
8268       do i=iturn4_start,iturn4_end
8269 c        write (iout,*) "make contact list turn4",i," num_cont",
8270 c     &   num_cont_hb(i)
8271         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8272       enddo
8273       do ii=1,nat_sent
8274         i=iat_sent(ii)
8275 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8276 c     &    num_cont_hb(i)
8277         do j=1,num_cont_hb(i)
8278         do k=1,4
8279           jjc=jcont_hb(j,i)
8280           iproc=iint_sent_local(k,jjc,ii)
8281 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8282           if (iproc.ne.0) then
8283             ncont_sent(iproc)=ncont_sent(iproc)+1
8284             nn=ncont_sent(iproc)
8285             zapas(1,nn,iproc)=i
8286             zapas(2,nn,iproc)=jjc
8287             zapas(3,nn,iproc)=d_cont(j,i)
8288             ind=3
8289             do kk=1,3
8290               ind=ind+1
8291               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8292             enddo
8293             do kk=1,2
8294               do ll=1,2
8295                 ind=ind+1
8296                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8297               enddo
8298             enddo
8299             do jj=1,5
8300               do kk=1,3
8301                 do ll=1,2
8302                   do mm=1,2
8303                     ind=ind+1
8304                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8305                   enddo
8306                 enddo
8307               enddo
8308             enddo
8309           endif
8310         enddo
8311         enddo
8312       enddo
8313       if (lprn) then
8314       write (iout,*)
8315      &  "Numbers of contacts to be sent to other processors",
8316      &  (ncont_sent(i),i=1,ntask_cont_to)
8317       write (iout,*) "Contacts sent"
8318       do ii=1,ntask_cont_to
8319         nn=ncont_sent(ii)
8320         iproc=itask_cont_to(ii)
8321         write (iout,*) nn," contacts to processor",iproc,
8322      &   " of CONT_TO_COMM group"
8323         do i=1,nn
8324           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8325         enddo
8326       enddo
8327       call flush(iout)
8328       endif
8329       CorrelType=477
8330       CorrelID=fg_rank+1
8331       CorrelType1=478
8332       CorrelID1=nfgtasks+fg_rank+1
8333       ireq=0
8334 C Receive the numbers of needed contacts from other processors
8335       do ii=1,ntask_cont_from
8336         iproc=itask_cont_from(ii)
8337         ireq=ireq+1
8338         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8339      &    FG_COMM,req(ireq),IERR)
8340       enddo
8341 c      write (iout,*) "IRECV ended"
8342 c      call flush(iout)
8343 C Send the number of contacts needed by other processors
8344       do ii=1,ntask_cont_to
8345         iproc=itask_cont_to(ii)
8346         ireq=ireq+1
8347         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8348      &    FG_COMM,req(ireq),IERR)
8349       enddo
8350 c      write (iout,*) "ISEND ended"
8351 c      write (iout,*) "number of requests (nn)",ireq
8352       call flush(iout)
8353       if (ireq.gt.0)
8354      &  call MPI_Waitall(ireq,req,status_array,ierr)
8355 c      write (iout,*)
8356 c     &  "Numbers of contacts to be received from other processors",
8357 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8358 c      call flush(iout)
8359 C Receive contacts
8360       ireq=0
8361       do ii=1,ntask_cont_from
8362         iproc=itask_cont_from(ii)
8363         nn=ncont_recv(ii)
8364 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8365 c     &   " of CONT_TO_COMM group"
8366         call flush(iout)
8367         if (nn.gt.0) then
8368           ireq=ireq+1
8369           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8370      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8371 c          write (iout,*) "ireq,req",ireq,req(ireq)
8372         endif
8373       enddo
8374 C Send the contacts to processors that need them
8375       do ii=1,ntask_cont_to
8376         iproc=itask_cont_to(ii)
8377         nn=ncont_sent(ii)
8378 c        write (iout,*) nn," contacts to processor",iproc,
8379 c     &   " of CONT_TO_COMM group"
8380         if (nn.gt.0) then
8381           ireq=ireq+1
8382           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8383      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8384 c          write (iout,*) "ireq,req",ireq,req(ireq)
8385 c          do i=1,nn
8386 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8387 c          enddo
8388         endif
8389       enddo
8390 c      write (iout,*) "number of requests (contacts)",ireq
8391 c      write (iout,*) "req",(req(i),i=1,4)
8392 c      call flush(iout)
8393       if (ireq.gt.0)
8394      & call MPI_Waitall(ireq,req,status_array,ierr)
8395       do iii=1,ntask_cont_from
8396         iproc=itask_cont_from(iii)
8397         nn=ncont_recv(iii)
8398         if (lprn) then
8399         write (iout,*) "Received",nn," contacts from processor",iproc,
8400      &   " of CONT_FROM_COMM group"
8401         call flush(iout)
8402         do i=1,nn
8403           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8404         enddo
8405         call flush(iout)
8406         endif
8407         do i=1,nn
8408           ii=zapas_recv(1,i,iii)
8409 c Flag the received contacts to prevent double-counting
8410           jj=-zapas_recv(2,i,iii)
8411 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8412 c          call flush(iout)
8413           nnn=num_cont_hb(ii)+1
8414           num_cont_hb(ii)=nnn
8415           jcont_hb(nnn,ii)=jj
8416           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8417           ind=3
8418           do kk=1,3
8419             ind=ind+1
8420             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8421           enddo
8422           do kk=1,2
8423             do ll=1,2
8424               ind=ind+1
8425               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8426             enddo
8427           enddo
8428           do jj=1,5
8429             do kk=1,3
8430               do ll=1,2
8431                 do mm=1,2
8432                   ind=ind+1
8433                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8434                 enddo
8435               enddo
8436             enddo
8437           enddo
8438         enddo
8439       enddo
8440       call flush(iout)
8441       if (lprn) then
8442         write (iout,'(a)') 'Contact function values after receive:'
8443         do i=nnt,nct-2
8444           write (iout,'(2i3,50(1x,i3,5f6.3))')
8445      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8446      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8447         enddo
8448         call flush(iout)
8449       endif
8450    30 continue
8451 #endif
8452       if (lprn) then
8453         write (iout,'(a)') 'Contact function values:'
8454         do i=nnt,nct-2
8455           write (iout,'(2i3,50(1x,i2,5f6.3))')
8456      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8457      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8458         enddo
8459       endif
8460       ecorr=0.0D0
8461       ecorr5=0.0d0
8462       ecorr6=0.0d0
8463 C Remove the loop below after debugging !!!
8464       do i=nnt,nct
8465         do j=1,3
8466           gradcorr(j,i)=0.0D0
8467           gradxorr(j,i)=0.0D0
8468         enddo
8469       enddo
8470 C Calculate the dipole-dipole interaction energies
8471       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8472       do i=iatel_s,iatel_e+1
8473         num_conti=num_cont_hb(i)
8474         do jj=1,num_conti
8475           j=jcont_hb(jj,i)
8476 #ifdef MOMENT
8477           call dipole(i,j,jj)
8478 #endif
8479         enddo
8480       enddo
8481       endif
8482 C Calculate the local-electrostatic correlation terms
8483 c                write (iout,*) "gradcorr5 in eello5 before loop"
8484 c                do iii=1,nres
8485 c                  write (iout,'(i5,3f10.5)')
8486 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8487 c                enddo
8488       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8489 c        write (iout,*) "corr loop i",i
8490         i1=i+1
8491         num_conti=num_cont_hb(i)
8492         num_conti1=num_cont_hb(i+1)
8493         do jj=1,num_conti
8494           j=jcont_hb(jj,i)
8495           jp=iabs(j)
8496           do kk=1,num_conti1
8497             j1=jcont_hb(kk,i1)
8498             jp1=iabs(j1)
8499 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8500 c     &         ' jj=',jj,' kk=',kk
8501 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8502             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8503      &          .or. j.lt.0 .and. j1.gt.0) .and.
8504      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8505 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8506 C The system gains extra energy.
8507               n_corr=n_corr+1
8508               sqd1=dsqrt(d_cont(jj,i))
8509               sqd2=dsqrt(d_cont(kk,i1))
8510               sred_geom = sqd1*sqd2
8511               IF (sred_geom.lt.cutoff_corr) THEN
8512                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8513      &            ekont,fprimcont)
8514 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8515 cd     &         ' jj=',jj,' kk=',kk
8516                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8517                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8518                 do l=1,3
8519                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8520                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8521                 enddo
8522                 n_corr1=n_corr1+1
8523 cd               write (iout,*) 'sred_geom=',sred_geom,
8524 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8525 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8526 cd               write (iout,*) "g_contij",g_contij
8527 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8528 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8529                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8530                 if (wcorr4.gt.0.0d0)
8531      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8532 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8533                   if (energy_dec.and.wcorr4.gt.0.0d0)
8534      1                 write (iout,'(a6,4i5,0pf7.3)')
8535      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8536 c                write (iout,*) "gradcorr5 before eello5"
8537 c                do iii=1,nres
8538 c                  write (iout,'(i5,3f10.5)')
8539 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8540 c                enddo
8541                 if (wcorr5.gt.0.0d0)
8542      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8543 c                write (iout,*) "gradcorr5 after eello5"
8544 c                do iii=1,nres
8545 c                  write (iout,'(i5,3f10.5)')
8546 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8547 c                enddo
8548                   if (energy_dec.and.wcorr5.gt.0.0d0)
8549      1                 write (iout,'(a6,4i5,0pf7.3)')
8550      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8551 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8552 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8553                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8554      &               .or. wturn6.eq.0.0d0))then
8555 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8556                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8557                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8558      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8559 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8560 cd     &            'ecorr6=',ecorr6
8561 cd                write (iout,'(4e15.5)') sred_geom,
8562 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8563 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8564 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8565                 else if (wturn6.gt.0.0d0
8566      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8567 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8568                   eturn6=eturn6+eello_turn6(i,jj,kk)
8569                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8570      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8571 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8572                 endif
8573               ENDIF
8574 1111          continue
8575             endif
8576           enddo ! kk
8577         enddo ! jj
8578       enddo ! i
8579       do i=1,nres
8580         num_cont_hb(i)=num_cont_hb_old(i)
8581       enddo
8582 c                write (iout,*) "gradcorr5 in eello5"
8583 c                do iii=1,nres
8584 c                  write (iout,'(i5,3f10.5)')
8585 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8586 c                enddo
8587       return
8588       end
8589 c------------------------------------------------------------------------------
8590       subroutine add_hb_contact_eello(ii,jj,itask)
8591       implicit real*8 (a-h,o-z)
8592       include "DIMENSIONS"
8593       include "COMMON.IOUNITS"
8594       integer max_cont
8595       integer max_dim
8596       parameter (max_cont=maxconts)
8597       parameter (max_dim=70)
8598       include "COMMON.CONTACTS"
8599       double precision zapas(max_dim,maxconts,max_fg_procs),
8600      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8601       common /przechowalnia/ zapas
8602       integer i,j,ii,jj,iproc,itask(4),nn
8603 c      write (iout,*) "itask",itask
8604       do i=1,2
8605         iproc=itask(i)
8606         if (iproc.gt.0) then
8607           do j=1,num_cont_hb(ii)
8608             jjc=jcont_hb(j,ii)
8609 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8610             if (jjc.eq.jj) then
8611               ncont_sent(iproc)=ncont_sent(iproc)+1
8612               nn=ncont_sent(iproc)
8613               zapas(1,nn,iproc)=ii
8614               zapas(2,nn,iproc)=jjc
8615               zapas(3,nn,iproc)=d_cont(j,ii)
8616               ind=3
8617               do kk=1,3
8618                 ind=ind+1
8619                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8620               enddo
8621               do kk=1,2
8622                 do ll=1,2
8623                   ind=ind+1
8624                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8625                 enddo
8626               enddo
8627               do jj=1,5
8628                 do kk=1,3
8629                   do ll=1,2
8630                     do mm=1,2
8631                       ind=ind+1
8632                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8633                     enddo
8634                   enddo
8635                 enddo
8636               enddo
8637               exit
8638             endif
8639           enddo
8640         endif
8641       enddo
8642       return
8643       end
8644 c------------------------------------------------------------------------------
8645       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8646       implicit real*8 (a-h,o-z)
8647       include 'DIMENSIONS'
8648       include 'COMMON.IOUNITS'
8649       include 'COMMON.DERIV'
8650       include 'COMMON.INTERACT'
8651       include 'COMMON.CONTACTS'
8652       include 'COMMON.SHIELD'
8653       include 'COMMON.CONTROL'
8654       double precision gx(3),gx1(3)
8655       logical lprn
8656       lprn=.false.
8657 C      print *,"wchodze",fac_shield(i),shield_mode
8658       eij=facont_hb(jj,i)
8659       ekl=facont_hb(kk,k)
8660       ees0pij=ees0p(jj,i)
8661       ees0pkl=ees0p(kk,k)
8662       ees0mij=ees0m(jj,i)
8663       ees0mkl=ees0m(kk,k)
8664       ekont=eij*ekl
8665       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8666 C*
8667 C     & fac_shield(i)**2*fac_shield(j)**2
8668 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8669 C Following 4 lines for diagnostics.
8670 cd    ees0pkl=0.0D0
8671 cd    ees0pij=1.0D0
8672 cd    ees0mkl=0.0D0
8673 cd    ees0mij=1.0D0
8674 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8675 c     & 'Contacts ',i,j,
8676 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8677 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8678 c     & 'gradcorr_long'
8679 C Calculate the multi-body contribution to energy.
8680 c      ecorr=ecorr+ekont*ees
8681 C Calculate multi-body contributions to the gradient.
8682       coeffpees0pij=coeffp*ees0pij
8683       coeffmees0mij=coeffm*ees0mij
8684       coeffpees0pkl=coeffp*ees0pkl
8685       coeffmees0mkl=coeffm*ees0mkl
8686       do ll=1,3
8687 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8688         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8689      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8690      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8691         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8692      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8693      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8694 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8695         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8696      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8697      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8698         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8699      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8700      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8701         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8702      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8703      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8704         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8705         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8706         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8707      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8708      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8709         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8710         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8711 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8712       enddo
8713 c      write (iout,*)
8714 cgrad      do m=i+1,j-1
8715 cgrad        do ll=1,3
8716 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8717 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8718 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8719 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8720 cgrad        enddo
8721 cgrad      enddo
8722 cgrad      do m=k+1,l-1
8723 cgrad        do ll=1,3
8724 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8725 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8726 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8727 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8728 cgrad        enddo
8729 cgrad      enddo
8730 c      write (iout,*) "ehbcorr",ekont*ees
8731 C      print *,ekont,ees,i,k
8732       ehbcorr=ekont*ees
8733 C now gradient over shielding
8734 C      return
8735       if (shield_mode.gt.0) then
8736        j=ees0plist(jj,i)
8737        l=ees0plist(kk,k)
8738 C        print *,i,j,fac_shield(i),fac_shield(j),
8739 C     &fac_shield(k),fac_shield(l)
8740         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8741      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8742           do ilist=1,ishield_list(i)
8743            iresshield=shield_list(ilist,i)
8744            do m=1,3
8745            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8746 C     &      *2.0
8747            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8748      &              rlocshield
8749      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8750             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8751      &+rlocshield
8752            enddo
8753           enddo
8754           do ilist=1,ishield_list(j)
8755            iresshield=shield_list(ilist,j)
8756            do m=1,3
8757            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8758 C     &     *2.0
8759            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8760      &              rlocshield
8761      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8762            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8763      &     +rlocshield
8764            enddo
8765           enddo
8766
8767           do ilist=1,ishield_list(k)
8768            iresshield=shield_list(ilist,k)
8769            do m=1,3
8770            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8771 C     &     *2.0
8772            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8773      &              rlocshield
8774      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8775            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8776      &     +rlocshield
8777            enddo
8778           enddo
8779           do ilist=1,ishield_list(l)
8780            iresshield=shield_list(ilist,l)
8781            do m=1,3
8782            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8783 C     &     *2.0
8784            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8785      &              rlocshield
8786      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8787            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8788      &     +rlocshield
8789            enddo
8790           enddo
8791 C          print *,gshieldx(m,iresshield)
8792           do m=1,3
8793             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8794      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8795             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8796      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8797             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8798      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8799             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8800      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8801
8802             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8803      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8804             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8805      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8806             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8807      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8808             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8809      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8810
8811            enddo
8812       endif
8813       endif
8814       return
8815       end
8816 #ifdef MOMENT
8817 C---------------------------------------------------------------------------
8818       subroutine dipole(i,j,jj)
8819       implicit real*8 (a-h,o-z)
8820       include 'DIMENSIONS'
8821       include 'COMMON.IOUNITS'
8822       include 'COMMON.CHAIN'
8823       include 'COMMON.FFIELD'
8824       include 'COMMON.DERIV'
8825       include 'COMMON.INTERACT'
8826       include 'COMMON.CONTACTS'
8827       include 'COMMON.TORSION'
8828       include 'COMMON.VAR'
8829       include 'COMMON.GEO'
8830       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8831      &  auxmat(2,2)
8832       iti1 = itortyp(itype(i+1))
8833       if (j.lt.nres-1) then
8834         itj1 = itortyp(itype(j+1))
8835       else
8836         itj1=ntortyp
8837       endif
8838       do iii=1,2
8839         dipi(iii,1)=Ub2(iii,i)
8840         dipderi(iii)=Ub2der(iii,i)
8841         dipi(iii,2)=b1(iii,i+1)
8842         dipj(iii,1)=Ub2(iii,j)
8843         dipderj(iii)=Ub2der(iii,j)
8844         dipj(iii,2)=b1(iii,j+1)
8845       enddo
8846       kkk=0
8847       do iii=1,2
8848         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8849         do jjj=1,2
8850           kkk=kkk+1
8851           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8852         enddo
8853       enddo
8854       do kkk=1,5
8855         do lll=1,3
8856           mmm=0
8857           do iii=1,2
8858             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8859      &        auxvec(1))
8860             do jjj=1,2
8861               mmm=mmm+1
8862               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8863             enddo
8864           enddo
8865         enddo
8866       enddo
8867       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8868       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8869       do iii=1,2
8870         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8871       enddo
8872       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8873       do iii=1,2
8874         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8875       enddo
8876       return
8877       end
8878 #endif
8879 C---------------------------------------------------------------------------
8880       subroutine calc_eello(i,j,k,l,jj,kk)
8881 C
8882 C This subroutine computes matrices and vectors needed to calculate
8883 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8884 C
8885       implicit real*8 (a-h,o-z)
8886       include 'DIMENSIONS'
8887       include 'COMMON.IOUNITS'
8888       include 'COMMON.CHAIN'
8889       include 'COMMON.DERIV'
8890       include 'COMMON.INTERACT'
8891       include 'COMMON.CONTACTS'
8892       include 'COMMON.TORSION'
8893       include 'COMMON.VAR'
8894       include 'COMMON.GEO'
8895       include 'COMMON.FFIELD'
8896       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8897      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8898       logical lprn
8899       common /kutas/ lprn
8900 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8901 cd     & ' jj=',jj,' kk=',kk
8902 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8903 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8904 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8905       do iii=1,2
8906         do jjj=1,2
8907           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8908           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8909         enddo
8910       enddo
8911       call transpose2(aa1(1,1),aa1t(1,1))
8912       call transpose2(aa2(1,1),aa2t(1,1))
8913       do kkk=1,5
8914         do lll=1,3
8915           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8916      &      aa1tder(1,1,lll,kkk))
8917           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8918      &      aa2tder(1,1,lll,kkk))
8919         enddo
8920       enddo
8921       if (l.eq.j+1) then
8922 C parallel orientation of the two CA-CA-CA frames.
8923         if (i.gt.1) then
8924           iti=itortyp(itype(i))
8925         else
8926           iti=ntortyp
8927         endif
8928         itk1=itortyp(itype(k+1))
8929         itj=itortyp(itype(j))
8930         if (l.lt.nres-1) then
8931           itl1=itortyp(itype(l+1))
8932         else
8933           itl1=ntortyp
8934         endif
8935 C A1 kernel(j+1) A2T
8936 cd        do iii=1,2
8937 cd          write (iout,'(3f10.5,5x,3f10.5)')
8938 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8939 cd        enddo
8940         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8941      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8942      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8943 C Following matrices are needed only for 6-th order cumulants
8944         IF (wcorr6.gt.0.0d0) THEN
8945         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8946      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8947      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8948         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8949      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8950      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8951      &   ADtEAderx(1,1,1,1,1,1))
8952         lprn=.false.
8953         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8954      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8955      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8956      &   ADtEA1derx(1,1,1,1,1,1))
8957         ENDIF
8958 C End 6-th order cumulants
8959 cd        lprn=.false.
8960 cd        if (lprn) then
8961 cd        write (2,*) 'In calc_eello6'
8962 cd        do iii=1,2
8963 cd          write (2,*) 'iii=',iii
8964 cd          do kkk=1,5
8965 cd            write (2,*) 'kkk=',kkk
8966 cd            do jjj=1,2
8967 cd              write (2,'(3(2f10.5),5x)')
8968 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8969 cd            enddo
8970 cd          enddo
8971 cd        enddo
8972 cd        endif
8973         call transpose2(EUgder(1,1,k),auxmat(1,1))
8974         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8975         call transpose2(EUg(1,1,k),auxmat(1,1))
8976         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8977         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8978         do iii=1,2
8979           do kkk=1,5
8980             do lll=1,3
8981               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8982      &          EAEAderx(1,1,lll,kkk,iii,1))
8983             enddo
8984           enddo
8985         enddo
8986 C A1T kernel(i+1) A2
8987         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8988      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8989      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8990 C Following matrices are needed only for 6-th order cumulants
8991         IF (wcorr6.gt.0.0d0) THEN
8992         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8993      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8994      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8995         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8996      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8997      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8998      &   ADtEAderx(1,1,1,1,1,2))
8999         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9000      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9001      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9002      &   ADtEA1derx(1,1,1,1,1,2))
9003         ENDIF
9004 C End 6-th order cumulants
9005         call transpose2(EUgder(1,1,l),auxmat(1,1))
9006         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9007         call transpose2(EUg(1,1,l),auxmat(1,1))
9008         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9009         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9010         do iii=1,2
9011           do kkk=1,5
9012             do lll=1,3
9013               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9014      &          EAEAderx(1,1,lll,kkk,iii,2))
9015             enddo
9016           enddo
9017         enddo
9018 C AEAb1 and AEAb2
9019 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9020 C They are needed only when the fifth- or the sixth-order cumulants are
9021 C indluded.
9022         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9023         call transpose2(AEA(1,1,1),auxmat(1,1))
9024         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9025         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9026         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9027         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9028         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9029         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9030         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9031         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9032         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9033         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9034         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9035         call transpose2(AEA(1,1,2),auxmat(1,1))
9036         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9037         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9038         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9039         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9040         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9041         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9042         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9043         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9044         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9045         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9046         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9047 C Calculate the Cartesian derivatives of the vectors.
9048         do iii=1,2
9049           do kkk=1,5
9050             do lll=1,3
9051               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9052               call matvec2(auxmat(1,1),b1(1,i),
9053      &          AEAb1derx(1,lll,kkk,iii,1,1))
9054               call matvec2(auxmat(1,1),Ub2(1,i),
9055      &          AEAb2derx(1,lll,kkk,iii,1,1))
9056               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9057      &          AEAb1derx(1,lll,kkk,iii,2,1))
9058               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9059      &          AEAb2derx(1,lll,kkk,iii,2,1))
9060               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9061               call matvec2(auxmat(1,1),b1(1,j),
9062      &          AEAb1derx(1,lll,kkk,iii,1,2))
9063               call matvec2(auxmat(1,1),Ub2(1,j),
9064      &          AEAb2derx(1,lll,kkk,iii,1,2))
9065               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9066      &          AEAb1derx(1,lll,kkk,iii,2,2))
9067               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9068      &          AEAb2derx(1,lll,kkk,iii,2,2))
9069             enddo
9070           enddo
9071         enddo
9072         ENDIF
9073 C End vectors
9074       else
9075 C Antiparallel orientation of the two CA-CA-CA frames.
9076         if (i.gt.1) then
9077           iti=itortyp(itype(i))
9078         else
9079           iti=ntortyp
9080         endif
9081         itk1=itortyp(itype(k+1))
9082         itl=itortyp(itype(l))
9083         itj=itortyp(itype(j))
9084         if (j.lt.nres-1) then
9085           itj1=itortyp(itype(j+1))
9086         else
9087           itj1=ntortyp
9088         endif
9089 C A2 kernel(j-1)T A1T
9090         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9091      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9092      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9093 C Following matrices are needed only for 6-th order cumulants
9094         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9095      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9096         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9097      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9098      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9099         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9100      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9101      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9102      &   ADtEAderx(1,1,1,1,1,1))
9103         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9104      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9105      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9106      &   ADtEA1derx(1,1,1,1,1,1))
9107         ENDIF
9108 C End 6-th order cumulants
9109         call transpose2(EUgder(1,1,k),auxmat(1,1))
9110         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9111         call transpose2(EUg(1,1,k),auxmat(1,1))
9112         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9113         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9114         do iii=1,2
9115           do kkk=1,5
9116             do lll=1,3
9117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9118      &          EAEAderx(1,1,lll,kkk,iii,1))
9119             enddo
9120           enddo
9121         enddo
9122 C A2T kernel(i+1)T A1
9123         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9124      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9125      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9126 C Following matrices are needed only for 6-th order cumulants
9127         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9128      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9129         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9130      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9131      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9132         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9133      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9134      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9135      &   ADtEAderx(1,1,1,1,1,2))
9136         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9137      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9138      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9139      &   ADtEA1derx(1,1,1,1,1,2))
9140         ENDIF
9141 C End 6-th order cumulants
9142         call transpose2(EUgder(1,1,j),auxmat(1,1))
9143         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9144         call transpose2(EUg(1,1,j),auxmat(1,1))
9145         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9146         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9147         do iii=1,2
9148           do kkk=1,5
9149             do lll=1,3
9150               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9151      &          EAEAderx(1,1,lll,kkk,iii,2))
9152             enddo
9153           enddo
9154         enddo
9155 C AEAb1 and AEAb2
9156 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9157 C They are needed only when the fifth- or the sixth-order cumulants are
9158 C indluded.
9159         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9160      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9161         call transpose2(AEA(1,1,1),auxmat(1,1))
9162         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9163         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9164         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9165         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9166         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9168         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9169         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9170         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9171         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9172         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9173         call transpose2(AEA(1,1,2),auxmat(1,1))
9174         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9175         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9176         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9177         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9178         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9179         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9180         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9181         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9182         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9183         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9184         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9185 C Calculate the Cartesian derivatives of the vectors.
9186         do iii=1,2
9187           do kkk=1,5
9188             do lll=1,3
9189               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9190               call matvec2(auxmat(1,1),b1(1,i),
9191      &          AEAb1derx(1,lll,kkk,iii,1,1))
9192               call matvec2(auxmat(1,1),Ub2(1,i),
9193      &          AEAb2derx(1,lll,kkk,iii,1,1))
9194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9195      &          AEAb1derx(1,lll,kkk,iii,2,1))
9196               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9197      &          AEAb2derx(1,lll,kkk,iii,2,1))
9198               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9199               call matvec2(auxmat(1,1),b1(1,l),
9200      &          AEAb1derx(1,lll,kkk,iii,1,2))
9201               call matvec2(auxmat(1,1),Ub2(1,l),
9202      &          AEAb2derx(1,lll,kkk,iii,1,2))
9203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9204      &          AEAb1derx(1,lll,kkk,iii,2,2))
9205               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9206      &          AEAb2derx(1,lll,kkk,iii,2,2))
9207             enddo
9208           enddo
9209         enddo
9210         ENDIF
9211 C End vectors
9212       endif
9213       return
9214       end
9215 C---------------------------------------------------------------------------
9216       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9217      &  KK,KKderg,AKA,AKAderg,AKAderx)
9218       implicit none
9219       integer nderg
9220       logical transp
9221       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9222      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9223      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9224       integer iii,kkk,lll
9225       integer jjj,mmm
9226       logical lprn
9227       common /kutas/ lprn
9228       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9229       do iii=1,nderg
9230         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9231      &    AKAderg(1,1,iii))
9232       enddo
9233 cd      if (lprn) write (2,*) 'In kernel'
9234       do kkk=1,5
9235 cd        if (lprn) write (2,*) 'kkk=',kkk
9236         do lll=1,3
9237           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9238      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9239 cd          if (lprn) then
9240 cd            write (2,*) 'lll=',lll
9241 cd            write (2,*) 'iii=1'
9242 cd            do jjj=1,2
9243 cd              write (2,'(3(2f10.5),5x)')
9244 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9245 cd            enddo
9246 cd          endif
9247           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9248      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9249 cd          if (lprn) then
9250 cd            write (2,*) 'lll=',lll
9251 cd            write (2,*) 'iii=2'
9252 cd            do jjj=1,2
9253 cd              write (2,'(3(2f10.5),5x)')
9254 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9255 cd            enddo
9256 cd          endif
9257         enddo
9258       enddo
9259       return
9260       end
9261 C---------------------------------------------------------------------------
9262       double precision function eello4(i,j,k,l,jj,kk)
9263       implicit real*8 (a-h,o-z)
9264       include 'DIMENSIONS'
9265       include 'COMMON.IOUNITS'
9266       include 'COMMON.CHAIN'
9267       include 'COMMON.DERIV'
9268       include 'COMMON.INTERACT'
9269       include 'COMMON.CONTACTS'
9270       include 'COMMON.TORSION'
9271       include 'COMMON.VAR'
9272       include 'COMMON.GEO'
9273       double precision pizda(2,2),ggg1(3),ggg2(3)
9274 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9275 cd        eello4=0.0d0
9276 cd        return
9277 cd      endif
9278 cd      print *,'eello4:',i,j,k,l,jj,kk
9279 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9280 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9281 cold      eij=facont_hb(jj,i)
9282 cold      ekl=facont_hb(kk,k)
9283 cold      ekont=eij*ekl
9284       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9285 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9286       gcorr_loc(k-1)=gcorr_loc(k-1)
9287      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9288       if (l.eq.j+1) then
9289         gcorr_loc(l-1)=gcorr_loc(l-1)
9290      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9291       else
9292         gcorr_loc(j-1)=gcorr_loc(j-1)
9293      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9294       endif
9295       do iii=1,2
9296         do kkk=1,5
9297           do lll=1,3
9298             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9299      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9300 cd            derx(lll,kkk,iii)=0.0d0
9301           enddo
9302         enddo
9303       enddo
9304 cd      gcorr_loc(l-1)=0.0d0
9305 cd      gcorr_loc(j-1)=0.0d0
9306 cd      gcorr_loc(k-1)=0.0d0
9307 cd      eel4=1.0d0
9308 cd      write (iout,*)'Contacts have occurred for peptide groups',
9309 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9310 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9311       if (j.lt.nres-1) then
9312         j1=j+1
9313         j2=j-1
9314       else
9315         j1=j-1
9316         j2=j-2
9317       endif
9318       if (l.lt.nres-1) then
9319         l1=l+1
9320         l2=l-1
9321       else
9322         l1=l-1
9323         l2=l-2
9324       endif
9325       do ll=1,3
9326 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9327 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9328         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9329         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9330 cgrad        ghalf=0.5d0*ggg1(ll)
9331         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9332         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9333         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9334         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9335         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9336         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9337 cgrad        ghalf=0.5d0*ggg2(ll)
9338         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9339         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9340         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9341         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9342         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9343         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9344       enddo
9345 cgrad      do m=i+1,j-1
9346 cgrad        do ll=1,3
9347 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9348 cgrad        enddo
9349 cgrad      enddo
9350 cgrad      do m=k+1,l-1
9351 cgrad        do ll=1,3
9352 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9353 cgrad        enddo
9354 cgrad      enddo
9355 cgrad      do m=i+2,j2
9356 cgrad        do ll=1,3
9357 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9358 cgrad        enddo
9359 cgrad      enddo
9360 cgrad      do m=k+2,l2
9361 cgrad        do ll=1,3
9362 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9363 cgrad        enddo
9364 cgrad      enddo
9365 cd      do iii=1,nres-3
9366 cd        write (2,*) iii,gcorr_loc(iii)
9367 cd      enddo
9368       eello4=ekont*eel4
9369 cd      write (2,*) 'ekont',ekont
9370 cd      write (iout,*) 'eello4',ekont*eel4
9371       return
9372       end
9373 C---------------------------------------------------------------------------
9374       double precision function eello5(i,j,k,l,jj,kk)
9375       implicit real*8 (a-h,o-z)
9376       include 'DIMENSIONS'
9377       include 'COMMON.IOUNITS'
9378       include 'COMMON.CHAIN'
9379       include 'COMMON.DERIV'
9380       include 'COMMON.INTERACT'
9381       include 'COMMON.CONTACTS'
9382       include 'COMMON.TORSION'
9383       include 'COMMON.VAR'
9384       include 'COMMON.GEO'
9385       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9386       double precision ggg1(3),ggg2(3)
9387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9388 C                                                                              C
9389 C                            Parallel chains                                   C
9390 C                                                                              C
9391 C          o             o                   o             o                   C
9392 C         /l\           / \             \   / \           / \   /              C
9393 C        /   \         /   \             \ /   \         /   \ /               C
9394 C       j| o |l1       | o |              o| o |         | o |o                C
9395 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9396 C      \i/   \         /   \ /             /   \         /   \                 C
9397 C       o    k1             o                                                  C
9398 C         (I)          (II)                (III)          (IV)                 C
9399 C                                                                              C
9400 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9401 C                                                                              C
9402 C                            Antiparallel chains                               C
9403 C                                                                              C
9404 C          o             o                   o             o                   C
9405 C         /j\           / \             \   / \           / \   /              C
9406 C        /   \         /   \             \ /   \         /   \ /               C
9407 C      j1| o |l        | o |              o| o |         | o |o                C
9408 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9409 C      \i/   \         /   \ /             /   \         /   \                 C
9410 C       o     k1            o                                                  C
9411 C         (I)          (II)                (III)          (IV)                 C
9412 C                                                                              C
9413 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9414 C                                                                              C
9415 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9416 C                                                                              C
9417 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9418 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9419 cd        eello5=0.0d0
9420 cd        return
9421 cd      endif
9422 cd      write (iout,*)
9423 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9424 cd     &   ' and',k,l
9425       itk=itortyp(itype(k))
9426       itl=itortyp(itype(l))
9427       itj=itortyp(itype(j))
9428       eello5_1=0.0d0
9429       eello5_2=0.0d0
9430       eello5_3=0.0d0
9431       eello5_4=0.0d0
9432 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9433 cd     &   eel5_3_num,eel5_4_num)
9434       do iii=1,2
9435         do kkk=1,5
9436           do lll=1,3
9437             derx(lll,kkk,iii)=0.0d0
9438           enddo
9439         enddo
9440       enddo
9441 cd      eij=facont_hb(jj,i)
9442 cd      ekl=facont_hb(kk,k)
9443 cd      ekont=eij*ekl
9444 cd      write (iout,*)'Contacts have occurred for peptide groups',
9445 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9446 cd      goto 1111
9447 C Contribution from the graph I.
9448 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9449 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9450       call transpose2(EUg(1,1,k),auxmat(1,1))
9451       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9452       vv(1)=pizda(1,1)-pizda(2,2)
9453       vv(2)=pizda(1,2)+pizda(2,1)
9454       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9455      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9456 C Explicit gradient in virtual-dihedral angles.
9457       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9458      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9459      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9460       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9461       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9462       vv(1)=pizda(1,1)-pizda(2,2)
9463       vv(2)=pizda(1,2)+pizda(2,1)
9464       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9465      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9466      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9467       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9468       vv(1)=pizda(1,1)-pizda(2,2)
9469       vv(2)=pizda(1,2)+pizda(2,1)
9470       if (l.eq.j+1) then
9471         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9472      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9473      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9474       else
9475         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9476      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9477      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9478       endif
9479 C Cartesian gradient
9480       do iii=1,2
9481         do kkk=1,5
9482           do lll=1,3
9483             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9484      &        pizda(1,1))
9485             vv(1)=pizda(1,1)-pizda(2,2)
9486             vv(2)=pizda(1,2)+pizda(2,1)
9487             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9488      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9489      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9490           enddo
9491         enddo
9492       enddo
9493 c      goto 1112
9494 c1111  continue
9495 C Contribution from graph II
9496       call transpose2(EE(1,1,itk),auxmat(1,1))
9497       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9498       vv(1)=pizda(1,1)+pizda(2,2)
9499       vv(2)=pizda(2,1)-pizda(1,2)
9500       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9501      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9502 C Explicit gradient in virtual-dihedral angles.
9503       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9504      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9505       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9506       vv(1)=pizda(1,1)+pizda(2,2)
9507       vv(2)=pizda(2,1)-pizda(1,2)
9508       if (l.eq.j+1) then
9509         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9510      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9511      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9512       else
9513         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9514      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9515      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9516       endif
9517 C Cartesian gradient
9518       do iii=1,2
9519         do kkk=1,5
9520           do lll=1,3
9521             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9522      &        pizda(1,1))
9523             vv(1)=pizda(1,1)+pizda(2,2)
9524             vv(2)=pizda(2,1)-pizda(1,2)
9525             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9526      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9527      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9528           enddo
9529         enddo
9530       enddo
9531 cd      goto 1112
9532 cd1111  continue
9533       if (l.eq.j+1) then
9534 cd        goto 1110
9535 C Parallel orientation
9536 C Contribution from graph III
9537         call transpose2(EUg(1,1,l),auxmat(1,1))
9538         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9539         vv(1)=pizda(1,1)-pizda(2,2)
9540         vv(2)=pizda(1,2)+pizda(2,1)
9541         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9542      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9543 C Explicit gradient in virtual-dihedral angles.
9544         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9545      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9546      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9547         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9548         vv(1)=pizda(1,1)-pizda(2,2)
9549         vv(2)=pizda(1,2)+pizda(2,1)
9550         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9551      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9552      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9553         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9554         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9555         vv(1)=pizda(1,1)-pizda(2,2)
9556         vv(2)=pizda(1,2)+pizda(2,1)
9557         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9558      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9559      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9560 C Cartesian gradient
9561         do iii=1,2
9562           do kkk=1,5
9563             do lll=1,3
9564               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9565      &          pizda(1,1))
9566               vv(1)=pizda(1,1)-pizda(2,2)
9567               vv(2)=pizda(1,2)+pizda(2,1)
9568               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9569      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9570      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9571             enddo
9572           enddo
9573         enddo
9574 cd        goto 1112
9575 C Contribution from graph IV
9576 cd1110    continue
9577         call transpose2(EE(1,1,itl),auxmat(1,1))
9578         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9579         vv(1)=pizda(1,1)+pizda(2,2)
9580         vv(2)=pizda(2,1)-pizda(1,2)
9581         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9582      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9583 C Explicit gradient in virtual-dihedral angles.
9584         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9585      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9586         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9587         vv(1)=pizda(1,1)+pizda(2,2)
9588         vv(2)=pizda(2,1)-pizda(1,2)
9589         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9590      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9591      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9592 C Cartesian gradient
9593         do iii=1,2
9594           do kkk=1,5
9595             do lll=1,3
9596               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9597      &          pizda(1,1))
9598               vv(1)=pizda(1,1)+pizda(2,2)
9599               vv(2)=pizda(2,1)-pizda(1,2)
9600               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9601      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9602      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9603             enddo
9604           enddo
9605         enddo
9606       else
9607 C Antiparallel orientation
9608 C Contribution from graph III
9609 c        goto 1110
9610         call transpose2(EUg(1,1,j),auxmat(1,1))
9611         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9612         vv(1)=pizda(1,1)-pizda(2,2)
9613         vv(2)=pizda(1,2)+pizda(2,1)
9614         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9615      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9616 C Explicit gradient in virtual-dihedral angles.
9617         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9618      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9619      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9620         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9621         vv(1)=pizda(1,1)-pizda(2,2)
9622         vv(2)=pizda(1,2)+pizda(2,1)
9623         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9624      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9625      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9626         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9627         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9628         vv(1)=pizda(1,1)-pizda(2,2)
9629         vv(2)=pizda(1,2)+pizda(2,1)
9630         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9631      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9633 C Cartesian gradient
9634         do iii=1,2
9635           do kkk=1,5
9636             do lll=1,3
9637               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9638      &          pizda(1,1))
9639               vv(1)=pizda(1,1)-pizda(2,2)
9640               vv(2)=pizda(1,2)+pizda(2,1)
9641               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9642      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9643      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9644             enddo
9645           enddo
9646         enddo
9647 cd        goto 1112
9648 C Contribution from graph IV
9649 1110    continue
9650         call transpose2(EE(1,1,itj),auxmat(1,1))
9651         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9652         vv(1)=pizda(1,1)+pizda(2,2)
9653         vv(2)=pizda(2,1)-pizda(1,2)
9654         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9655      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9656 C Explicit gradient in virtual-dihedral angles.
9657         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9658      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9659         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9660         vv(1)=pizda(1,1)+pizda(2,2)
9661         vv(2)=pizda(2,1)-pizda(1,2)
9662         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9663      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9664      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9665 C Cartesian gradient
9666         do iii=1,2
9667           do kkk=1,5
9668             do lll=1,3
9669               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9670      &          pizda(1,1))
9671               vv(1)=pizda(1,1)+pizda(2,2)
9672               vv(2)=pizda(2,1)-pizda(1,2)
9673               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9674      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9675      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9676             enddo
9677           enddo
9678         enddo
9679       endif
9680 1112  continue
9681       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9682 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9683 cd        write (2,*) 'ijkl',i,j,k,l
9684 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9685 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9686 cd      endif
9687 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9688 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9689 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9690 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9691       if (j.lt.nres-1) then
9692         j1=j+1
9693         j2=j-1
9694       else
9695         j1=j-1
9696         j2=j-2
9697       endif
9698       if (l.lt.nres-1) then
9699         l1=l+1
9700         l2=l-1
9701       else
9702         l1=l-1
9703         l2=l-2
9704       endif
9705 cd      eij=1.0d0
9706 cd      ekl=1.0d0
9707 cd      ekont=1.0d0
9708 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9709 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9710 C        summed up outside the subrouine as for the other subroutines
9711 C        handling long-range interactions. The old code is commented out
9712 C        with "cgrad" to keep track of changes.
9713       do ll=1,3
9714 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9715 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9716         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9717         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9718 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9719 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9720 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9721 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9722 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9723 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9724 c     &   gradcorr5ij,
9725 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9726 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9727 cgrad        ghalf=0.5d0*ggg1(ll)
9728 cd        ghalf=0.0d0
9729         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9730         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9731         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9732         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9733         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9734         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9735 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9736 cgrad        ghalf=0.5d0*ggg2(ll)
9737 cd        ghalf=0.0d0
9738         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9739         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9740         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9741         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9742         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9743         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9744       enddo
9745 cd      goto 1112
9746 cgrad      do m=i+1,j-1
9747 cgrad        do ll=1,3
9748 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9749 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9750 cgrad        enddo
9751 cgrad      enddo
9752 cgrad      do m=k+1,l-1
9753 cgrad        do ll=1,3
9754 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9755 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9756 cgrad        enddo
9757 cgrad      enddo
9758 c1112  continue
9759 cgrad      do m=i+2,j2
9760 cgrad        do ll=1,3
9761 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9762 cgrad        enddo
9763 cgrad      enddo
9764 cgrad      do m=k+2,l2
9765 cgrad        do ll=1,3
9766 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9767 cgrad        enddo
9768 cgrad      enddo
9769 cd      do iii=1,nres-3
9770 cd        write (2,*) iii,g_corr5_loc(iii)
9771 cd      enddo
9772       eello5=ekont*eel5
9773 cd      write (2,*) 'ekont',ekont
9774 cd      write (iout,*) 'eello5',ekont*eel5
9775       return
9776       end
9777 c--------------------------------------------------------------------------
9778       double precision function eello6(i,j,k,l,jj,kk)
9779       implicit real*8 (a-h,o-z)
9780       include 'DIMENSIONS'
9781       include 'COMMON.IOUNITS'
9782       include 'COMMON.CHAIN'
9783       include 'COMMON.DERIV'
9784       include 'COMMON.INTERACT'
9785       include 'COMMON.CONTACTS'
9786       include 'COMMON.TORSION'
9787       include 'COMMON.VAR'
9788       include 'COMMON.GEO'
9789       include 'COMMON.FFIELD'
9790       double precision ggg1(3),ggg2(3)
9791 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9792 cd        eello6=0.0d0
9793 cd        return
9794 cd      endif
9795 cd      write (iout,*)
9796 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9797 cd     &   ' and',k,l
9798       eello6_1=0.0d0
9799       eello6_2=0.0d0
9800       eello6_3=0.0d0
9801       eello6_4=0.0d0
9802       eello6_5=0.0d0
9803       eello6_6=0.0d0
9804 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9805 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9806       do iii=1,2
9807         do kkk=1,5
9808           do lll=1,3
9809             derx(lll,kkk,iii)=0.0d0
9810           enddo
9811         enddo
9812       enddo
9813 cd      eij=facont_hb(jj,i)
9814 cd      ekl=facont_hb(kk,k)
9815 cd      ekont=eij*ekl
9816 cd      eij=1.0d0
9817 cd      ekl=1.0d0
9818 cd      ekont=1.0d0
9819       if (l.eq.j+1) then
9820         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9821         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9822         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9823         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9824         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9825         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9826       else
9827         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9828         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9829         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9830         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9831         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9832           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9833         else
9834           eello6_5=0.0d0
9835         endif
9836         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9837       endif
9838 C If turn contributions are considered, they will be handled separately.
9839       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9840 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9841 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9842 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9843 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9844 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9845 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9846 cd      goto 1112
9847       if (j.lt.nres-1) then
9848         j1=j+1
9849         j2=j-1
9850       else
9851         j1=j-1
9852         j2=j-2
9853       endif
9854       if (l.lt.nres-1) then
9855         l1=l+1
9856         l2=l-1
9857       else
9858         l1=l-1
9859         l2=l-2
9860       endif
9861       do ll=1,3
9862 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9863 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9864 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9865 cgrad        ghalf=0.5d0*ggg1(ll)
9866 cd        ghalf=0.0d0
9867         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9868         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9869         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9870         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9871         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9872         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9873         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9874         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9875 cgrad        ghalf=0.5d0*ggg2(ll)
9876 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9877 cd        ghalf=0.0d0
9878         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9879         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9880         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9881         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9882         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9883         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9884       enddo
9885 cd      goto 1112
9886 cgrad      do m=i+1,j-1
9887 cgrad        do ll=1,3
9888 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9889 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9890 cgrad        enddo
9891 cgrad      enddo
9892 cgrad      do m=k+1,l-1
9893 cgrad        do ll=1,3
9894 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9895 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9896 cgrad        enddo
9897 cgrad      enddo
9898 cgrad1112  continue
9899 cgrad      do m=i+2,j2
9900 cgrad        do ll=1,3
9901 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9902 cgrad        enddo
9903 cgrad      enddo
9904 cgrad      do m=k+2,l2
9905 cgrad        do ll=1,3
9906 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9907 cgrad        enddo
9908 cgrad      enddo
9909 cd      do iii=1,nres-3
9910 cd        write (2,*) iii,g_corr6_loc(iii)
9911 cd      enddo
9912       eello6=ekont*eel6
9913 cd      write (2,*) 'ekont',ekont
9914 cd      write (iout,*) 'eello6',ekont*eel6
9915       return
9916       end
9917 c--------------------------------------------------------------------------
9918       double precision function eello6_graph1(i,j,k,l,imat,swap)
9919       implicit real*8 (a-h,o-z)
9920       include 'DIMENSIONS'
9921       include 'COMMON.IOUNITS'
9922       include 'COMMON.CHAIN'
9923       include 'COMMON.DERIV'
9924       include 'COMMON.INTERACT'
9925       include 'COMMON.CONTACTS'
9926       include 'COMMON.TORSION'
9927       include 'COMMON.VAR'
9928       include 'COMMON.GEO'
9929       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9930       logical swap
9931       logical lprn
9932       common /kutas/ lprn
9933 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9934 C                                                                              C
9935 C      Parallel       Antiparallel                                             C
9936 C                                                                              C
9937 C          o             o                                                     C
9938 C         /l\           /j\                                                    C
9939 C        /   \         /   \                                                   C
9940 C       /| o |         | o |\                                                  C
9941 C     \ j|/k\|  /   \  |/k\|l /                                                C
9942 C      \ /   \ /     \ /   \ /                                                 C
9943 C       o     o       o     o                                                  C
9944 C       i             i                                                        C
9945 C                                                                              C
9946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9947       itk=itortyp(itype(k))
9948       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9949       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9950       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9951       call transpose2(EUgC(1,1,k),auxmat(1,1))
9952       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9953       vv1(1)=pizda1(1,1)-pizda1(2,2)
9954       vv1(2)=pizda1(1,2)+pizda1(2,1)
9955       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9956       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9957       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9958       s5=scalar2(vv(1),Dtobr2(1,i))
9959 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9960       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9961       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9962      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9963      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9964      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9965      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9966      & +scalar2(vv(1),Dtobr2der(1,i)))
9967       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9968       vv1(1)=pizda1(1,1)-pizda1(2,2)
9969       vv1(2)=pizda1(1,2)+pizda1(2,1)
9970       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9971       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9972       if (l.eq.j+1) then
9973         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9974      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9975      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9976      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9977      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9978       else
9979         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9980      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9981      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9982      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9983      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9984       endif
9985       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9986       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9987       vv1(1)=pizda1(1,1)-pizda1(2,2)
9988       vv1(2)=pizda1(1,2)+pizda1(2,1)
9989       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9990      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9991      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9992      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9993       do iii=1,2
9994         if (swap) then
9995           ind=3-iii
9996         else
9997           ind=iii
9998         endif
9999         do kkk=1,5
10000           do lll=1,3
10001             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10002             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10003             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10004             call transpose2(EUgC(1,1,k),auxmat(1,1))
10005             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10006      &        pizda1(1,1))
10007             vv1(1)=pizda1(1,1)-pizda1(2,2)
10008             vv1(2)=pizda1(1,2)+pizda1(2,1)
10009             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10010             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10011      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10012             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10013      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10014             s5=scalar2(vv(1),Dtobr2(1,i))
10015             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10016           enddo
10017         enddo
10018       enddo
10019       return
10020       end
10021 c----------------------------------------------------------------------------
10022       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10023       implicit real*8 (a-h,o-z)
10024       include 'DIMENSIONS'
10025       include 'COMMON.IOUNITS'
10026       include 'COMMON.CHAIN'
10027       include 'COMMON.DERIV'
10028       include 'COMMON.INTERACT'
10029       include 'COMMON.CONTACTS'
10030       include 'COMMON.TORSION'
10031       include 'COMMON.VAR'
10032       include 'COMMON.GEO'
10033       logical swap
10034       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10035      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10036       logical lprn
10037       common /kutas/ lprn
10038 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10039 C                                                                              C
10040 C      Parallel       Antiparallel                                             C
10041 C                                                                              C
10042 C          o             o                                                     C
10043 C     \   /l\           /j\   /                                                C
10044 C      \ /   \         /   \ /                                                 C
10045 C       o| o |         | o |o                                                  C
10046 C     \ j|/k\|      \  |/k\|l                                                  C
10047 C      \ /   \       \ /   \                                                   C
10048 C       o             o                                                        C
10049 C       i             i                                                        C
10050 C                                                                              C
10051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10052 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10053 C AL 7/4/01 s1 would occur in the sixth-order moment,
10054 C           but not in a cluster cumulant
10055 #ifdef MOMENT
10056       s1=dip(1,jj,i)*dip(1,kk,k)
10057 #endif
10058       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10059       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10060       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10061       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10062       call transpose2(EUg(1,1,k),auxmat(1,1))
10063       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10064       vv(1)=pizda(1,1)-pizda(2,2)
10065       vv(2)=pizda(1,2)+pizda(2,1)
10066       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10067 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10068 #ifdef MOMENT
10069       eello6_graph2=-(s1+s2+s3+s4)
10070 #else
10071       eello6_graph2=-(s2+s3+s4)
10072 #endif
10073 c      eello6_graph2=-s3
10074 C Derivatives in gamma(i-1)
10075       if (i.gt.1) then
10076 #ifdef MOMENT
10077         s1=dipderg(1,jj,i)*dip(1,kk,k)
10078 #endif
10079         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10080         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10081         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10082         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10083 #ifdef MOMENT
10084         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10085 #else
10086         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10087 #endif
10088 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10089       endif
10090 C Derivatives in gamma(k-1)
10091 #ifdef MOMENT
10092       s1=dip(1,jj,i)*dipderg(1,kk,k)
10093 #endif
10094       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10095       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10096       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10097       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10098       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10099       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10100       vv(1)=pizda(1,1)-pizda(2,2)
10101       vv(2)=pizda(1,2)+pizda(2,1)
10102       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10103 #ifdef MOMENT
10104       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10105 #else
10106       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10107 #endif
10108 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10109 C Derivatives in gamma(j-1) or gamma(l-1)
10110       if (j.gt.1) then
10111 #ifdef MOMENT
10112         s1=dipderg(3,jj,i)*dip(1,kk,k)
10113 #endif
10114         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10115         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10116         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10117         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10118         vv(1)=pizda(1,1)-pizda(2,2)
10119         vv(2)=pizda(1,2)+pizda(2,1)
10120         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10121 #ifdef MOMENT
10122         if (swap) then
10123           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10124         else
10125           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10126         endif
10127 #endif
10128         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10129 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10130       endif
10131 C Derivatives in gamma(l-1) or gamma(j-1)
10132       if (l.gt.1) then
10133 #ifdef MOMENT
10134         s1=dip(1,jj,i)*dipderg(3,kk,k)
10135 #endif
10136         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10137         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10138         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10139         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10140         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10141         vv(1)=pizda(1,1)-pizda(2,2)
10142         vv(2)=pizda(1,2)+pizda(2,1)
10143         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10144 #ifdef MOMENT
10145         if (swap) then
10146           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10147         else
10148           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10149         endif
10150 #endif
10151         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10152 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10153       endif
10154 C Cartesian derivatives.
10155       if (lprn) then
10156         write (2,*) 'In eello6_graph2'
10157         do iii=1,2
10158           write (2,*) 'iii=',iii
10159           do kkk=1,5
10160             write (2,*) 'kkk=',kkk
10161             do jjj=1,2
10162               write (2,'(3(2f10.5),5x)')
10163      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10164             enddo
10165           enddo
10166         enddo
10167       endif
10168       do iii=1,2
10169         do kkk=1,5
10170           do lll=1,3
10171 #ifdef MOMENT
10172             if (iii.eq.1) then
10173               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10174             else
10175               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10176             endif
10177 #endif
10178             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10179      &        auxvec(1))
10180             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10181             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10182      &        auxvec(1))
10183             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10184             call transpose2(EUg(1,1,k),auxmat(1,1))
10185             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10186      &        pizda(1,1))
10187             vv(1)=pizda(1,1)-pizda(2,2)
10188             vv(2)=pizda(1,2)+pizda(2,1)
10189             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10190 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10191 #ifdef MOMENT
10192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10193 #else
10194             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10195 #endif
10196             if (swap) then
10197               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10198             else
10199               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10200             endif
10201           enddo
10202         enddo
10203       enddo
10204       return
10205       end
10206 c----------------------------------------------------------------------------
10207       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10208       implicit real*8 (a-h,o-z)
10209       include 'DIMENSIONS'
10210       include 'COMMON.IOUNITS'
10211       include 'COMMON.CHAIN'
10212       include 'COMMON.DERIV'
10213       include 'COMMON.INTERACT'
10214       include 'COMMON.CONTACTS'
10215       include 'COMMON.TORSION'
10216       include 'COMMON.VAR'
10217       include 'COMMON.GEO'
10218       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10219       logical swap
10220 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10221 C                                                                              C
10222 C      Parallel       Antiparallel                                             C
10223 C                                                                              C
10224 C          o             o                                                     C
10225 C         /l\   /   \   /j\                                                    C
10226 C        /   \ /     \ /   \                                                   C
10227 C       /| o |o       o| o |\                                                  C
10228 C       j|/k\|  /      |/k\|l /                                                C
10229 C        /   \ /       /   \ /                                                 C
10230 C       /     o       /     o                                                  C
10231 C       i             i                                                        C
10232 C                                                                              C
10233 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10234 C
10235 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10236 C           energy moment and not to the cluster cumulant.
10237       iti=itortyp(itype(i))
10238       if (j.lt.nres-1) then
10239         itj1=itortyp(itype(j+1))
10240       else
10241         itj1=ntortyp
10242       endif
10243       itk=itortyp(itype(k))
10244       itk1=itortyp(itype(k+1))
10245       if (l.lt.nres-1) then
10246         itl1=itortyp(itype(l+1))
10247       else
10248         itl1=ntortyp
10249       endif
10250 #ifdef MOMENT
10251       s1=dip(4,jj,i)*dip(4,kk,k)
10252 #endif
10253       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10254       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10255       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10256       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10257       call transpose2(EE(1,1,itk),auxmat(1,1))
10258       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10259       vv(1)=pizda(1,1)+pizda(2,2)
10260       vv(2)=pizda(2,1)-pizda(1,2)
10261       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10262 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10263 cd     & "sum",-(s2+s3+s4)
10264 #ifdef MOMENT
10265       eello6_graph3=-(s1+s2+s3+s4)
10266 #else
10267       eello6_graph3=-(s2+s3+s4)
10268 #endif
10269 c      eello6_graph3=-s4
10270 C Derivatives in gamma(k-1)
10271       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10272       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10273       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10274       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10275 C Derivatives in gamma(l-1)
10276       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10277       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10278       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10279       vv(1)=pizda(1,1)+pizda(2,2)
10280       vv(2)=pizda(2,1)-pizda(1,2)
10281       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10282       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10283 C Cartesian derivatives.
10284       do iii=1,2
10285         do kkk=1,5
10286           do lll=1,3
10287 #ifdef MOMENT
10288             if (iii.eq.1) then
10289               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10290             else
10291               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10292             endif
10293 #endif
10294             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10295      &        auxvec(1))
10296             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10297             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10298      &        auxvec(1))
10299             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10300             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10301      &        pizda(1,1))
10302             vv(1)=pizda(1,1)+pizda(2,2)
10303             vv(2)=pizda(2,1)-pizda(1,2)
10304             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10305 #ifdef MOMENT
10306             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10307 #else
10308             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10309 #endif
10310             if (swap) then
10311               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10312             else
10313               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10314             endif
10315 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10316           enddo
10317         enddo
10318       enddo
10319       return
10320       end
10321 c----------------------------------------------------------------------------
10322       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10323       implicit real*8 (a-h,o-z)
10324       include 'DIMENSIONS'
10325       include 'COMMON.IOUNITS'
10326       include 'COMMON.CHAIN'
10327       include 'COMMON.DERIV'
10328       include 'COMMON.INTERACT'
10329       include 'COMMON.CONTACTS'
10330       include 'COMMON.TORSION'
10331       include 'COMMON.VAR'
10332       include 'COMMON.GEO'
10333       include 'COMMON.FFIELD'
10334       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10335      & auxvec1(2),auxmat1(2,2)
10336       logical swap
10337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10338 C                                                                              C
10339 C      Parallel       Antiparallel                                             C
10340 C                                                                              C
10341 C          o             o                                                     C
10342 C         /l\   /   \   /j\                                                    C
10343 C        /   \ /     \ /   \                                                   C
10344 C       /| o |o       o| o |\                                                  C
10345 C     \ j|/k\|      \  |/k\|l                                                  C
10346 C      \ /   \       \ /   \                                                   C
10347 C       o     \       o     \                                                  C
10348 C       i             i                                                        C
10349 C                                                                              C
10350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10351 C
10352 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10353 C           energy moment and not to the cluster cumulant.
10354 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10355       iti=itortyp(itype(i))
10356       itj=itortyp(itype(j))
10357       if (j.lt.nres-1) then
10358         itj1=itortyp(itype(j+1))
10359       else
10360         itj1=ntortyp
10361       endif
10362       itk=itortyp(itype(k))
10363       if (k.lt.nres-1) then
10364         itk1=itortyp(itype(k+1))
10365       else
10366         itk1=ntortyp
10367       endif
10368       itl=itortyp(itype(l))
10369       if (l.lt.nres-1) then
10370         itl1=itortyp(itype(l+1))
10371       else
10372         itl1=ntortyp
10373       endif
10374 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10375 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10376 cd     & ' itl',itl,' itl1',itl1
10377 #ifdef MOMENT
10378       if (imat.eq.1) then
10379         s1=dip(3,jj,i)*dip(3,kk,k)
10380       else
10381         s1=dip(2,jj,j)*dip(2,kk,l)
10382       endif
10383 #endif
10384       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10385       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10386       if (j.eq.l+1) then
10387         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10388         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10389       else
10390         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10391         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10392       endif
10393       call transpose2(EUg(1,1,k),auxmat(1,1))
10394       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10395       vv(1)=pizda(1,1)-pizda(2,2)
10396       vv(2)=pizda(2,1)+pizda(1,2)
10397       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10398 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10399 #ifdef MOMENT
10400       eello6_graph4=-(s1+s2+s3+s4)
10401 #else
10402       eello6_graph4=-(s2+s3+s4)
10403 #endif
10404 C Derivatives in gamma(i-1)
10405       if (i.gt.1) then
10406 #ifdef MOMENT
10407         if (imat.eq.1) then
10408           s1=dipderg(2,jj,i)*dip(3,kk,k)
10409         else
10410           s1=dipderg(4,jj,j)*dip(2,kk,l)
10411         endif
10412 #endif
10413         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10414         if (j.eq.l+1) then
10415           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10416           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10417         else
10418           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10419           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10420         endif
10421         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10422         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10423 cd          write (2,*) 'turn6 derivatives'
10424 #ifdef MOMENT
10425           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10426 #else
10427           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10428 #endif
10429         else
10430 #ifdef MOMENT
10431           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10432 #else
10433           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10434 #endif
10435         endif
10436       endif
10437 C Derivatives in gamma(k-1)
10438 #ifdef MOMENT
10439       if (imat.eq.1) then
10440         s1=dip(3,jj,i)*dipderg(2,kk,k)
10441       else
10442         s1=dip(2,jj,j)*dipderg(4,kk,l)
10443       endif
10444 #endif
10445       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10446       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10447       if (j.eq.l+1) then
10448         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10449         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10450       else
10451         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10452         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10453       endif
10454       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10455       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10456       vv(1)=pizda(1,1)-pizda(2,2)
10457       vv(2)=pizda(2,1)+pizda(1,2)
10458       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10459       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10460 #ifdef MOMENT
10461         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10462 #else
10463         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10464 #endif
10465       else
10466 #ifdef MOMENT
10467         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10468 #else
10469         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10470 #endif
10471       endif
10472 C Derivatives in gamma(j-1) or gamma(l-1)
10473       if (l.eq.j+1 .and. l.gt.1) then
10474         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10475         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10476         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10477         vv(1)=pizda(1,1)-pizda(2,2)
10478         vv(2)=pizda(2,1)+pizda(1,2)
10479         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10480         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10481       else if (j.gt.1) then
10482         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10483         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10484         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10485         vv(1)=pizda(1,1)-pizda(2,2)
10486         vv(2)=pizda(2,1)+pizda(1,2)
10487         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10488         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10489           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10490         else
10491           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10492         endif
10493       endif
10494 C Cartesian derivatives.
10495       do iii=1,2
10496         do kkk=1,5
10497           do lll=1,3
10498 #ifdef MOMENT
10499             if (iii.eq.1) then
10500               if (imat.eq.1) then
10501                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10502               else
10503                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10504               endif
10505             else
10506               if (imat.eq.1) then
10507                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10508               else
10509                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10510               endif
10511             endif
10512 #endif
10513             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10514      &        auxvec(1))
10515             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10516             if (j.eq.l+1) then
10517               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10518      &          b1(1,j+1),auxvec(1))
10519               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10520             else
10521               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10522      &          b1(1,l+1),auxvec(1))
10523               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10524             endif
10525             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10526      &        pizda(1,1))
10527             vv(1)=pizda(1,1)-pizda(2,2)
10528             vv(2)=pizda(2,1)+pizda(1,2)
10529             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10530             if (swap) then
10531               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10532 #ifdef MOMENT
10533                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10534      &             -(s1+s2+s4)
10535 #else
10536                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10537      &             -(s2+s4)
10538 #endif
10539                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10540               else
10541 #ifdef MOMENT
10542                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10543 #else
10544                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10545 #endif
10546                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10547               endif
10548             else
10549 #ifdef MOMENT
10550               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10551 #else
10552               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10553 #endif
10554               if (l.eq.j+1) then
10555                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10556               else
10557                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10558               endif
10559             endif
10560           enddo
10561         enddo
10562       enddo
10563       return
10564       end
10565 c----------------------------------------------------------------------------
10566       double precision function eello_turn6(i,jj,kk)
10567       implicit real*8 (a-h,o-z)
10568       include 'DIMENSIONS'
10569       include 'COMMON.IOUNITS'
10570       include 'COMMON.CHAIN'
10571       include 'COMMON.DERIV'
10572       include 'COMMON.INTERACT'
10573       include 'COMMON.CONTACTS'
10574       include 'COMMON.TORSION'
10575       include 'COMMON.VAR'
10576       include 'COMMON.GEO'
10577       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10578      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10579      &  ggg1(3),ggg2(3)
10580       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10581      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10582 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10583 C           the respective energy moment and not to the cluster cumulant.
10584       s1=0.0d0
10585       s8=0.0d0
10586       s13=0.0d0
10587 c
10588       eello_turn6=0.0d0
10589       j=i+4
10590       k=i+1
10591       l=i+3
10592       iti=itortyp(itype(i))
10593       itk=itortyp(itype(k))
10594       itk1=itortyp(itype(k+1))
10595       itl=itortyp(itype(l))
10596       itj=itortyp(itype(j))
10597 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10598 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10599 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10600 cd        eello6=0.0d0
10601 cd        return
10602 cd      endif
10603 cd      write (iout,*)
10604 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10605 cd     &   ' and',k,l
10606 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10607       do iii=1,2
10608         do kkk=1,5
10609           do lll=1,3
10610             derx_turn(lll,kkk,iii)=0.0d0
10611           enddo
10612         enddo
10613       enddo
10614 cd      eij=1.0d0
10615 cd      ekl=1.0d0
10616 cd      ekont=1.0d0
10617       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10618 cd      eello6_5=0.0d0
10619 cd      write (2,*) 'eello6_5',eello6_5
10620 #ifdef MOMENT
10621       call transpose2(AEA(1,1,1),auxmat(1,1))
10622       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10623       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10624       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10625 #endif
10626       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10627       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10628       s2 = scalar2(b1(1,k),vtemp1(1))
10629 #ifdef MOMENT
10630       call transpose2(AEA(1,1,2),atemp(1,1))
10631       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10632       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10633       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10634 #endif
10635       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10636       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10637       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10638 #ifdef MOMENT
10639       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10640       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10641       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10642       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10643       ss13 = scalar2(b1(1,k),vtemp4(1))
10644       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10645 #endif
10646 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10647 c      s1=0.0d0
10648 c      s2=0.0d0
10649 c      s8=0.0d0
10650 c      s12=0.0d0
10651 c      s13=0.0d0
10652       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10653 C Derivatives in gamma(i+2)
10654       s1d =0.0d0
10655       s8d =0.0d0
10656 #ifdef MOMENT
10657       call transpose2(AEA(1,1,1),auxmatd(1,1))
10658       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10659       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10660       call transpose2(AEAderg(1,1,2),atempd(1,1))
10661       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10662       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10663 #endif
10664       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10665       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10666       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10667 c      s1d=0.0d0
10668 c      s2d=0.0d0
10669 c      s8d=0.0d0
10670 c      s12d=0.0d0
10671 c      s13d=0.0d0
10672       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10673 C Derivatives in gamma(i+3)
10674 #ifdef MOMENT
10675       call transpose2(AEA(1,1,1),auxmatd(1,1))
10676       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10677       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10678       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10679 #endif
10680       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10681       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10682       s2d = scalar2(b1(1,k),vtemp1d(1))
10683 #ifdef MOMENT
10684       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10685       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10686 #endif
10687       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10688 #ifdef MOMENT
10689       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10690       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10691       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10692 #endif
10693 c      s1d=0.0d0
10694 c      s2d=0.0d0
10695 c      s8d=0.0d0
10696 c      s12d=0.0d0
10697 c      s13d=0.0d0
10698 #ifdef MOMENT
10699       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10700      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10701 #else
10702       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10703      &               -0.5d0*ekont*(s2d+s12d)
10704 #endif
10705 C Derivatives in gamma(i+4)
10706       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10707       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10708       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10709 #ifdef MOMENT
10710       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10711       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10712       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10713 #endif
10714 c      s1d=0.0d0
10715 c      s2d=0.0d0
10716 c      s8d=0.0d0
10717 C      s12d=0.0d0
10718 c      s13d=0.0d0
10719 #ifdef MOMENT
10720       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10721 #else
10722       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10723 #endif
10724 C Derivatives in gamma(i+5)
10725 #ifdef MOMENT
10726       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10727       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10728       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10729 #endif
10730       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10731       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10732       s2d = scalar2(b1(1,k),vtemp1d(1))
10733 #ifdef MOMENT
10734       call transpose2(AEA(1,1,2),atempd(1,1))
10735       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10736       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10737 #endif
10738       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10739       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10740 #ifdef MOMENT
10741       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10742       ss13d = scalar2(b1(1,k),vtemp4d(1))
10743       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10744 #endif
10745 c      s1d=0.0d0
10746 c      s2d=0.0d0
10747 c      s8d=0.0d0
10748 c      s12d=0.0d0
10749 c      s13d=0.0d0
10750 #ifdef MOMENT
10751       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10752      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10753 #else
10754       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10755      &               -0.5d0*ekont*(s2d+s12d)
10756 #endif
10757 C Cartesian derivatives
10758       do iii=1,2
10759         do kkk=1,5
10760           do lll=1,3
10761 #ifdef MOMENT
10762             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10763             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10764             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10765 #endif
10766             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10767             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10768      &          vtemp1d(1))
10769             s2d = scalar2(b1(1,k),vtemp1d(1))
10770 #ifdef MOMENT
10771             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10772             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10773             s8d = -(atempd(1,1)+atempd(2,2))*
10774      &           scalar2(cc(1,1,itl),vtemp2(1))
10775 #endif
10776             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10777      &           auxmatd(1,1))
10778             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10779             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10780 c      s1d=0.0d0
10781 c      s2d=0.0d0
10782 c      s8d=0.0d0
10783 c      s12d=0.0d0
10784 c      s13d=0.0d0
10785 #ifdef MOMENT
10786             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10787      &        - 0.5d0*(s1d+s2d)
10788 #else
10789             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10790      &        - 0.5d0*s2d
10791 #endif
10792 #ifdef MOMENT
10793             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10794      &        - 0.5d0*(s8d+s12d)
10795 #else
10796             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10797      &        - 0.5d0*s12d
10798 #endif
10799           enddo
10800         enddo
10801       enddo
10802 #ifdef MOMENT
10803       do kkk=1,5
10804         do lll=1,3
10805           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10806      &      achuj_tempd(1,1))
10807           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10808           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10809           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10810           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10811           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10812      &      vtemp4d(1))
10813           ss13d = scalar2(b1(1,k),vtemp4d(1))
10814           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10815           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10816         enddo
10817       enddo
10818 #endif
10819 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10820 cd     &  16*eel_turn6_num
10821 cd      goto 1112
10822       if (j.lt.nres-1) then
10823         j1=j+1
10824         j2=j-1
10825       else
10826         j1=j-1
10827         j2=j-2
10828       endif
10829       if (l.lt.nres-1) then
10830         l1=l+1
10831         l2=l-1
10832       else
10833         l1=l-1
10834         l2=l-2
10835       endif
10836       do ll=1,3
10837 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10838 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10839 cgrad        ghalf=0.5d0*ggg1(ll)
10840 cd        ghalf=0.0d0
10841         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10842         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10843         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10844      &    +ekont*derx_turn(ll,2,1)
10845         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10846         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10847      &    +ekont*derx_turn(ll,4,1)
10848         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10849         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10850         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10851 cgrad        ghalf=0.5d0*ggg2(ll)
10852 cd        ghalf=0.0d0
10853         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10854      &    +ekont*derx_turn(ll,2,2)
10855         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10856         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10857      &    +ekont*derx_turn(ll,4,2)
10858         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10859         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10860         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10861       enddo
10862 cd      goto 1112
10863 cgrad      do m=i+1,j-1
10864 cgrad        do ll=1,3
10865 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10866 cgrad        enddo
10867 cgrad      enddo
10868 cgrad      do m=k+1,l-1
10869 cgrad        do ll=1,3
10870 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10871 cgrad        enddo
10872 cgrad      enddo
10873 cgrad1112  continue
10874 cgrad      do m=i+2,j2
10875 cgrad        do ll=1,3
10876 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10877 cgrad        enddo
10878 cgrad      enddo
10879 cgrad      do m=k+2,l2
10880 cgrad        do ll=1,3
10881 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10882 cgrad        enddo
10883 cgrad      enddo
10884 cd      do iii=1,nres-3
10885 cd        write (2,*) iii,g_corr6_loc(iii)
10886 cd      enddo
10887       eello_turn6=ekont*eel_turn6
10888 cd      write (2,*) 'ekont',ekont
10889 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10890       return
10891       end
10892
10893 C-----------------------------------------------------------------------------
10894       double precision function scalar(u,v)
10895 !DIR$ INLINEALWAYS scalar
10896 #ifndef OSF
10897 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10898 #endif
10899       implicit none
10900       double precision u(3),v(3)
10901 cd      double precision sc
10902 cd      integer i
10903 cd      sc=0.0d0
10904 cd      do i=1,3
10905 cd        sc=sc+u(i)*v(i)
10906 cd      enddo
10907 cd      scalar=sc
10908
10909       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10910       return
10911       end
10912 crc-------------------------------------------------
10913       SUBROUTINE MATVEC2(A1,V1,V2)
10914 !DIR$ INLINEALWAYS MATVEC2
10915 #ifndef OSF
10916 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10917 #endif
10918       implicit real*8 (a-h,o-z)
10919       include 'DIMENSIONS'
10920       DIMENSION A1(2,2),V1(2),V2(2)
10921 c      DO 1 I=1,2
10922 c        VI=0.0
10923 c        DO 3 K=1,2
10924 c    3     VI=VI+A1(I,K)*V1(K)
10925 c        Vaux(I)=VI
10926 c    1 CONTINUE
10927
10928       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10929       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10930
10931       v2(1)=vaux1
10932       v2(2)=vaux2
10933       END
10934 C---------------------------------------
10935       SUBROUTINE MATMAT2(A1,A2,A3)
10936 #ifndef OSF
10937 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10938 #endif
10939       implicit real*8 (a-h,o-z)
10940       include 'DIMENSIONS'
10941       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10942 c      DIMENSION AI3(2,2)
10943 c        DO  J=1,2
10944 c          A3IJ=0.0
10945 c          DO K=1,2
10946 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10947 c          enddo
10948 c          A3(I,J)=A3IJ
10949 c       enddo
10950 c      enddo
10951
10952       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10953       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10954       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10955       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10956
10957       A3(1,1)=AI3_11
10958       A3(2,1)=AI3_21
10959       A3(1,2)=AI3_12
10960       A3(2,2)=AI3_22
10961       END
10962
10963 c-------------------------------------------------------------------------
10964       double precision function scalar2(u,v)
10965 !DIR$ INLINEALWAYS scalar2
10966       implicit none
10967       double precision u(2),v(2)
10968       double precision sc
10969       integer i
10970       scalar2=u(1)*v(1)+u(2)*v(2)
10971       return
10972       end
10973
10974 C-----------------------------------------------------------------------------
10975
10976       subroutine transpose2(a,at)
10977 !DIR$ INLINEALWAYS transpose2
10978 #ifndef OSF
10979 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10980 #endif
10981       implicit none
10982       double precision a(2,2),at(2,2)
10983       at(1,1)=a(1,1)
10984       at(1,2)=a(2,1)
10985       at(2,1)=a(1,2)
10986       at(2,2)=a(2,2)
10987       return
10988       end
10989 c--------------------------------------------------------------------------
10990       subroutine transpose(n,a,at)
10991       implicit none
10992       integer n,i,j
10993       double precision a(n,n),at(n,n)
10994       do i=1,n
10995         do j=1,n
10996           at(j,i)=a(i,j)
10997         enddo
10998       enddo
10999       return
11000       end
11001 C---------------------------------------------------------------------------
11002       subroutine prodmat3(a1,a2,kk,transp,prod)
11003 !DIR$ INLINEALWAYS prodmat3
11004 #ifndef OSF
11005 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11006 #endif
11007       implicit none
11008       integer i,j
11009       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11010       logical transp
11011 crc      double precision auxmat(2,2),prod_(2,2)
11012
11013       if (transp) then
11014 crc        call transpose2(kk(1,1),auxmat(1,1))
11015 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11016 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11017
11018            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11019      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11020            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11021      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11022            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11023      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11024            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11025      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11026
11027       else
11028 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11029 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11030
11031            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11032      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11033            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11034      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11035            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11036      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11037            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11038      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11039
11040       endif
11041 c      call transpose2(a2(1,1),a2t(1,1))
11042
11043 crc      print *,transp
11044 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11045 crc      print *,((prod(i,j),i=1,2),j=1,2)
11046
11047       return
11048       end
11049 CCC----------------------------------------------
11050       subroutine Eliptransfer(eliptran)
11051       implicit real*8 (a-h,o-z)
11052       include 'DIMENSIONS'
11053       include 'COMMON.GEO'
11054       include 'COMMON.VAR'
11055       include 'COMMON.LOCAL'
11056       include 'COMMON.CHAIN'
11057       include 'COMMON.DERIV'
11058       include 'COMMON.NAMES'
11059       include 'COMMON.INTERACT'
11060       include 'COMMON.IOUNITS'
11061       include 'COMMON.CALC'
11062       include 'COMMON.CONTROL'
11063       include 'COMMON.SPLITELE'
11064       include 'COMMON.SBRIDGE'
11065 C this is done by Adasko
11066 C      print *,"wchodze"
11067 C structure of box:
11068 C      water
11069 C--bordliptop-- buffore starts
11070 C--bufliptop--- here true lipid starts
11071 C      lipid
11072 C--buflipbot--- lipid ends buffore starts
11073 C--bordlipbot--buffore ends
11074       eliptran=0.0
11075       do i=ilip_start,ilip_end
11076 C       do i=1,1
11077         if (itype(i).eq.ntyp1) cycle
11078
11079         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11080         if (positi.le.0) positi=positi+boxzsize
11081 C        print *,i
11082 C first for peptide groups
11083 c for each residue check if it is in lipid or lipid water border area
11084        if ((positi.gt.bordlipbot)
11085      &.and.(positi.lt.bordliptop)) then
11086 C the energy transfer exist
11087         if (positi.lt.buflipbot) then
11088 C what fraction I am in
11089          fracinbuf=1.0d0-
11090      &        ((positi-bordlipbot)/lipbufthick)
11091 C lipbufthick is thickenes of lipid buffore
11092          sslip=sscalelip(fracinbuf)
11093          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11094          eliptran=eliptran+sslip*pepliptran
11095          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11096          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11097 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11098
11099 C        print *,"doing sccale for lower part"
11100 C         print *,i,sslip,fracinbuf,ssgradlip
11101         elseif (positi.gt.bufliptop) then
11102          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11103          sslip=sscalelip(fracinbuf)
11104          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11105          eliptran=eliptran+sslip*pepliptran
11106          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11107          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11108 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11109 C          print *, "doing sscalefor top part"
11110 C         print *,i,sslip,fracinbuf,ssgradlip
11111         else
11112          eliptran=eliptran+pepliptran
11113 C         print *,"I am in true lipid"
11114         endif
11115 C       else
11116 C       eliptran=elpitran+0.0 ! I am in water
11117        endif
11118        enddo
11119 C       print *, "nic nie bylo w lipidzie?"
11120 C now multiply all by the peptide group transfer factor
11121 C       eliptran=eliptran*pepliptran
11122 C now the same for side chains
11123 CV       do i=1,1
11124        do i=ilip_start,ilip_end
11125         if (itype(i).eq.ntyp1) cycle
11126         positi=(mod(c(3,i+nres),boxzsize))
11127         if (positi.le.0) positi=positi+boxzsize
11128 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11129 c for each residue check if it is in lipid or lipid water border area
11130 C       respos=mod(c(3,i+nres),boxzsize)
11131 C       print *,positi,bordlipbot,buflipbot
11132        if ((positi.gt.bordlipbot)
11133      & .and.(positi.lt.bordliptop)) then
11134 C the energy transfer exist
11135         if (positi.lt.buflipbot) then
11136          fracinbuf=1.0d0-
11137      &     ((positi-bordlipbot)/lipbufthick)
11138 C lipbufthick is thickenes of lipid buffore
11139          sslip=sscalelip(fracinbuf)
11140          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11141          eliptran=eliptran+sslip*liptranene(itype(i))
11142          gliptranx(3,i)=gliptranx(3,i)
11143      &+ssgradlip*liptranene(itype(i))
11144          gliptranc(3,i-1)= gliptranc(3,i-1)
11145      &+ssgradlip*liptranene(itype(i))
11146 C         print *,"doing sccale for lower part"
11147         elseif (positi.gt.bufliptop) then
11148          fracinbuf=1.0d0-
11149      &((bordliptop-positi)/lipbufthick)
11150          sslip=sscalelip(fracinbuf)
11151          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11152          eliptran=eliptran+sslip*liptranene(itype(i))
11153          gliptranx(3,i)=gliptranx(3,i)
11154      &+ssgradlip*liptranene(itype(i))
11155          gliptranc(3,i-1)= gliptranc(3,i-1)
11156      &+ssgradlip*liptranene(itype(i))
11157 C          print *, "doing sscalefor top part",sslip,fracinbuf
11158         else
11159          eliptran=eliptran+liptranene(itype(i))
11160 C         print *,"I am in true lipid"
11161         endif
11162         endif ! if in lipid or buffor
11163 C       else
11164 C       eliptran=elpitran+0.0 ! I am in water
11165        enddo
11166        return
11167        end
11168 C---------------------------------------------------------
11169 C AFM soubroutine for constant force
11170        subroutine AFMforce(Eafmforce)
11171        implicit real*8 (a-h,o-z)
11172       include 'DIMENSIONS'
11173       include 'COMMON.GEO'
11174       include 'COMMON.VAR'
11175       include 'COMMON.LOCAL'
11176       include 'COMMON.CHAIN'
11177       include 'COMMON.DERIV'
11178       include 'COMMON.NAMES'
11179       include 'COMMON.INTERACT'
11180       include 'COMMON.IOUNITS'
11181       include 'COMMON.CALC'
11182       include 'COMMON.CONTROL'
11183       include 'COMMON.SPLITELE'
11184       include 'COMMON.SBRIDGE'
11185       real*8 diffafm(3)
11186       dist=0.0d0
11187       Eafmforce=0.0d0
11188       do i=1,3
11189       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11190       dist=dist+diffafm(i)**2
11191       enddo
11192       dist=dsqrt(dist)
11193       Eafmforce=-forceAFMconst*(dist-distafminit)
11194       do i=1,3
11195       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11196       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11197       enddo
11198 C      print *,'AFM',Eafmforce
11199       return
11200       end
11201 C---------------------------------------------------------
11202 C AFM subroutine with pseudoconstant velocity
11203        subroutine AFMvel(Eafmforce)
11204        implicit real*8 (a-h,o-z)
11205       include 'DIMENSIONS'
11206       include 'COMMON.GEO'
11207       include 'COMMON.VAR'
11208       include 'COMMON.LOCAL'
11209       include 'COMMON.CHAIN'
11210       include 'COMMON.DERIV'
11211       include 'COMMON.NAMES'
11212       include 'COMMON.INTERACT'
11213       include 'COMMON.IOUNITS'
11214       include 'COMMON.CALC'
11215       include 'COMMON.CONTROL'
11216       include 'COMMON.SPLITELE'
11217       include 'COMMON.SBRIDGE'
11218       real*8 diffafm(3)
11219 C Only for check grad COMMENT if not used for checkgrad
11220 C      totT=3.0d0
11221 C--------------------------------------------------------
11222 C      print *,"wchodze"
11223       dist=0.0d0
11224       Eafmforce=0.0d0
11225       do i=1,3
11226       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11227       dist=dist+diffafm(i)**2
11228       enddo
11229       dist=dsqrt(dist)
11230       Eafmforce=0.5d0*forceAFMconst
11231      & *(distafminit+totTafm*velAFMconst-dist)**2
11232 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11233       do i=1,3
11234       gradafm(i,afmend-1)=-forceAFMconst*
11235      &(distafminit+totTafm*velAFMconst-dist)
11236      &*diffafm(i)/dist
11237       gradafm(i,afmbeg-1)=forceAFMconst*
11238      &(distafminit+totTafm*velAFMconst-dist)
11239      &*diffafm(i)/dist
11240       enddo
11241 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11242       return
11243       end
11244 C-----------------------------------------------------------
11245 C first for shielding is setting of function of side-chains
11246        subroutine set_shield_fac
11247       implicit real*8 (a-h,o-z)
11248       include 'DIMENSIONS'
11249       include 'COMMON.CHAIN'
11250       include 'COMMON.DERIV'
11251       include 'COMMON.IOUNITS'
11252       include 'COMMON.SHIELD'
11253       include 'COMMON.INTERACT'
11254 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11255       double precision div77_81/0.974996043d0/,
11256      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11257
11258 C the vector between center of side_chain and peptide group
11259        double precision pep_side(3),long,side_calf(3),
11260      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11261      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11262 C the line belowe needs to be changed for FGPROC>1
11263       do i=1,nres-1
11264       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11265       ishield_list(i)=0
11266 Cif there two consequtive dummy atoms there is no peptide group between them
11267 C the line below has to be changed for FGPROC>1
11268       VolumeTotal=0.0
11269       do k=1,nres
11270        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11271        dist_pep_side=0.0
11272        dist_side_calf=0.0
11273        do j=1,3
11274 C first lets set vector conecting the ithe side-chain with kth side-chain
11275       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11276 C      pep_side(j)=2.0d0
11277 C and vector conecting the side-chain with its proper calfa
11278       side_calf(j)=c(j,k+nres)-c(j,k)
11279 C      side_calf(j)=2.0d0
11280       pept_group(j)=c(j,i)-c(j,i+1)
11281 C lets have their lenght
11282       dist_pep_side=pep_side(j)**2+dist_pep_side
11283       dist_side_calf=dist_side_calf+side_calf(j)**2
11284       dist_pept_group=dist_pept_group+pept_group(j)**2
11285       enddo
11286        dist_pep_side=dsqrt(dist_pep_side)
11287        dist_pept_group=dsqrt(dist_pept_group)
11288        dist_side_calf=dsqrt(dist_side_calf)
11289       do j=1,3
11290         pep_side_norm(j)=pep_side(j)/dist_pep_side
11291         side_calf_norm(j)=dist_side_calf
11292       enddo
11293 C now sscale fraction
11294        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11295 C       print *,buff_shield,"buff"
11296 C now sscale
11297         if (sh_frac_dist.le.0.0) cycle
11298 C If we reach here it means that this side chain reaches the shielding sphere
11299 C Lets add him to the list for gradient
11300         ishield_list(i)=ishield_list(i)+1
11301 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11302 C this list is essential otherwise problem would be O3
11303         shield_list(ishield_list(i),i)=k
11304 C Lets have the sscale value
11305         if (sh_frac_dist.gt.1.0) then
11306          scale_fac_dist=1.0d0
11307          do j=1,3
11308          sh_frac_dist_grad(j)=0.0d0
11309          enddo
11310         else
11311          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11312      &                   *(2.0*sh_frac_dist-3.0d0)
11313          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11314      &                  /dist_pep_side/buff_shield*0.5
11315 C remember for the final gradient multiply sh_frac_dist_grad(j)
11316 C for side_chain by factor -2 !
11317          do j=1,3
11318          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11319 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11320 C     &                    sh_frac_dist_grad(j)
11321          enddo
11322         endif
11323 C        if ((i.eq.3).and.(k.eq.2)) then
11324 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11325 C     & ,"TU"
11326 C        endif
11327
11328 C this is what is now we have the distance scaling now volume...
11329       short=short_r_sidechain(itype(k))
11330       long=long_r_sidechain(itype(k))
11331       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11332 C now costhet_grad
11333 C       costhet=0.0d0
11334        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11335 C       costhet_fac=0.0d0
11336        do j=1,3
11337          costhet_grad(j)=costhet_fac*pep_side(j)
11338        enddo
11339 C remember for the final gradient multiply costhet_grad(j)
11340 C for side_chain by factor -2 !
11341 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11342 C pep_side0pept_group is vector multiplication
11343       pep_side0pept_group=0.0
11344       do j=1,3
11345       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11346       enddo
11347       cosalfa=(pep_side0pept_group/
11348      & (dist_pep_side*dist_side_calf))
11349       fac_alfa_sin=1.0-cosalfa**2
11350       fac_alfa_sin=dsqrt(fac_alfa_sin)
11351       rkprim=fac_alfa_sin*(long-short)+short
11352 C now costhet_grad
11353        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11354        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11355
11356        do j=1,3
11357          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11358      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11359      &*(long-short)/fac_alfa_sin*cosalfa/
11360      &((dist_pep_side*dist_side_calf))*
11361      &((side_calf(j))-cosalfa*
11362      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11363
11364         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11365      &*(long-short)/fac_alfa_sin*cosalfa
11366      &/((dist_pep_side*dist_side_calf))*
11367      &(pep_side(j)-
11368      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11369        enddo
11370
11371       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11372      &                    /VSolvSphere_div
11373 C now the gradient...
11374 C grad_shield is gradient of Calfa for peptide groups
11375 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11376 C     &               costhet,cosphi
11377 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11378 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11379       do j=1,3
11380       grad_shield(j,i)=grad_shield(j,i)
11381 C gradient po skalowaniu
11382      &                +(sh_frac_dist_grad(j)
11383 C  gradient po costhet
11384      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11385      &-scale_fac_dist*(cosphi_grad_long(j))
11386      &/(1.0-cosphi) )*div77_81
11387      &*VofOverlap
11388 C grad_shield_side is Cbeta sidechain gradient
11389       grad_shield_side(j,ishield_list(i),i)=
11390      &        (sh_frac_dist_grad(j)*-2.0d0
11391      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11392      &       +scale_fac_dist*(cosphi_grad_long(j))
11393      &        *2.0d0/(1.0-cosphi))
11394      &        *div77_81*VofOverlap
11395
11396        grad_shield_loc(j,ishield_list(i),i)=
11397      &   scale_fac_dist*cosphi_grad_loc(j)
11398      &        *2.0d0/(1.0-cosphi)
11399      &        *div77_81*VofOverlap
11400       enddo
11401       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11402       enddo
11403       fac_shield(i)=VolumeTotal*div77_81+div4_81
11404 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11405       enddo
11406       return
11407       end
11408 C--------------------------------------------------------------------------
11409       double precision function tschebyshev(m,n,x,y)
11410       implicit none
11411       include "DIMENSIONS"
11412       integer i,m,n
11413       double precision x(n),y,yy(0:maxvar),aux
11414 c Tschebyshev polynomial. Note that the first term is omitted
11415 c m=0: the constant term is included
11416 c m=1: the constant term is not included
11417       yy(0)=1.0d0
11418       yy(1)=y
11419       do i=2,n
11420         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11421       enddo
11422       aux=0.0d0
11423       do i=m,n
11424         aux=aux+x(i)*yy(i)
11425       enddo
11426       tschebyshev=aux
11427       return
11428       end
11429 C--------------------------------------------------------------------------
11430       double precision function gradtschebyshev(m,n,x,y)
11431       implicit none
11432       include "DIMENSIONS"
11433       integer i,m,n
11434       double precision x(n+1),y,yy(0:maxvar),aux
11435 c Tschebyshev polynomial. Note that the first term is omitted
11436 c m=0: the constant term is included
11437 c m=1: the constant term is not included
11438       yy(0)=1.0d0
11439       yy(1)=2.0d0*y
11440       do i=2,n
11441         yy(i)=2*y*yy(i-1)-yy(i-2)
11442       enddo
11443       aux=0.0d0
11444       do i=m,n
11445         aux=aux+x(i+1)*yy(i)*(i+1)
11446 C        print *, x(i+1),yy(i),i
11447       enddo
11448       gradtschebyshev=aux
11449       return
11450       end
11451