source/unres/src_MD/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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137 c      if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334       if (dyn_ss) call dyn_set_nss
 335 c      print *," Processor",myrank," left SUM_ENERGY"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time_sumene=time_sumene+MPI_Wtime()-time00
 339 #else
 340       time_sumene=time_sumene+tcpu()-time00
 341 #endif
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395 #ifdef TSCSC
 396       evdw=energia(22)+wsct*energia(23)
 397 #else
 398       evdw=energia(1)
 399 #endif
 400 #ifdef SCP14
 401       evdw2=energia(2)+energia(18)
 402       evdw2_14=energia(18)
 403 #else
 404       evdw2=energia(2)
 405 #endif
 406 #ifdef SPLITELE
 407       ees=energia(3)
 408       evdw1=energia(16)
 409 #else
 410       ees=energia(3)
 411       evdw1=0.0d0
 412 #endif
 413       ecorr=energia(4)
 414       ecorr5=energia(5)
 415       ecorr6=energia(6)
 416       eel_loc=energia(7)
 417       eello_turn3=energia(8)
 418       eello_turn4=energia(9)
 419       eturn6=energia(10)
 420       ebe=energia(11)
 421       escloc=energia(12)
 422       etors=energia(13)
 423       etors_d=energia(14)
 424       ehpb=energia(15)
 425       edihcnstr=energia(19)
 426       estr=energia(17)
 427       Uconst=energia(20)
 428       esccor=energia(21)
 429 #ifdef SPLITELE
 430       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 431      & +wang*ebe+wtor*etors+wscloc*escloc
 432      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 433      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 434      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 435      & +wbond*estr+Uconst+wsccor*esccor
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor
 443 #endif
 444       energia(0)=etot
 445 c detecting NaNQ
 446 #ifdef ISNAN
 447 #ifdef AIX
 448       if (isnan(etot).ne.0) energia(0)=1.0d+99
 449 #else
 450       if (isnan(etot)) energia(0)=1.0d+99
 451 #endif
 452 #else
 453       i=0
 454 #ifdef WINPGI
 455       idumm=proc_proc(etot,i)
 456 #else
 457       call proc_proc(etot,i)
 458 #endif
 459       if(i.eq.1)energia(0)=1.0d+99
 460 #endif
 461 #ifdef MPI
 462       endif
 463 #endif
 464       return
 465       end
 466 c-------------------------------------------------------------------------------
 467       subroutine sum_gradient
 468       implicit real*8 (a-h,o-z)
 469       include 'DIMENSIONS'
 470 #ifndef ISNAN
 471       external proc_proc
 472 #ifdef WINPGI
 473 cMS$ATTRIBUTES C ::  proc_proc
 474 #endif
 475 #endif
 476 #ifdef MPI
 477       include 'mpif.h'
 478 #endif
 479       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 480      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 481       include 'COMMON.SETUP'
 482       include 'COMMON.IOUNITS'
 483       include 'COMMON.FFIELD'
 484       include 'COMMON.DERIV'
 485       include 'COMMON.INTERACT'
 486       include 'COMMON.SBRIDGE'
 487       include 'COMMON.CHAIN'
 488       include 'COMMON.VAR'
 489       include 'COMMON.CONTROL'
 490       include 'COMMON.TIME1'
 491       include 'COMMON.MAXGRAD'
 492       include 'COMMON.SCCOR'
 493 #ifdef TIMING
 494 #ifdef MPI
 495       time01=MPI_Wtime()
 496 #else
 497       time01=tcpu()
 498 #endif
 499 #endif
 500 #ifdef DEBUG
 501       write (iout,*) "sum_gradient gvdwc, gvdwx"
 502       do i=1,nres
 503         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 504      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 505      &   (gvdwcT(j,i),j=1,3)
 506       enddo
 507       call flush(iout)
 508 #endif
 509 #ifdef MPI
 510 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 511         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 512      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 513 #endif
 514 C
 515 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 516 C            in virtual-bond-vector coordinates
 517 C
 518 #ifdef DEBUG
 519 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 520 c      do i=1,nres-1
 521 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 522 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 523 c      enddo
 524 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 525 c      do i=1,nres-1
 526 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 527 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 528 c      enddo
 529       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 530       do i=1,nres
 531         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 532      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 533      &   g_corr5_loc(i)
 534       enddo
 535       call flush(iout)
 536 #endif
 537 #ifdef SPLITELE
 538 #ifdef TSCSC
 539       do i=1,nct
 540         do j=1,3
 541           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 542      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 543      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 544      &                wel_loc*gel_loc_long(j,i)+
 545      &                wcorr*gradcorr_long(j,i)+
 546      &                wcorr5*gradcorr5_long(j,i)+
 547      &                wcorr6*gradcorr6_long(j,i)+
 548      &                wturn6*gcorr6_turn_long(j,i)+
 549      &                wstrain*ghpbc(j,i)
 550         enddo
 551       enddo
 552 #else
 553       do i=1,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564         enddo
 565       enddo
 566 #endif
 567 #else
 568       do i=1,nct
 569         do j=1,3
 570           gradbufc(j,i)=wsc*gvdwc(j,i)+
 571      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 572      &                welec*gelc_long(j,i)+
 573      &                wbond*gradb(j,i)+
 574      &                wel_loc*gel_loc_long(j,i)+
 575      &                wcorr*gradcorr_long(j,i)+
 576      &                wcorr5*gradcorr5_long(j,i)+
 577      &                wcorr6*gradcorr6_long(j,i)+
 578      &                wturn6*gcorr6_turn_long(j,i)+
 579      &                wstrain*ghpbc(j,i)
 580         enddo
 581       enddo
 582 #endif
 583 #ifdef MPI
 584       if (nfgtasks.gt.1) then
 585       time00=MPI_Wtime()
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc before allreduce"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       do i=1,nres
 594         do j=1,3
 595           gradbufc_sum(j,i)=gradbufc(j,i)
 596         enddo
 597       enddo
 598 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 599 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 600 c      time_reduce=time_reduce+MPI_Wtime()-time00
 601 #ifdef DEBUG
 602 c      write (iout,*) "gradbufc_sum after allreduce"
 603 c      do i=1,nres
 604 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 605 c      enddo
 606 c      call flush(iout)
 607 #endif
 608 #ifdef TIMING
 609 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 610 #endif
 611       do i=nnt,nres
 612         do k=1,3
 613           gradbufc(k,i)=0.0d0
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 618       write (iout,*) (i," jgrad_start",jgrad_start(i),
 619      &                  " jgrad_end  ",jgrad_end(i),
 620      &                  i=igrad_start,igrad_end)
 621 #endif
 622 c
 623 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 624 c do not parallelize this part.
 625 c
 626 c      do i=igrad_start,igrad_end
 627 c        do j=jgrad_start(i),jgrad_end(i)
 628 c          do k=1,3
 629 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 630 c          enddo
 631 c        enddo
 632 c      enddo
 633       do j=1,3
 634         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 635       enddo
 636       do i=nres-2,nnt,-1
 637         do j=1,3
 638           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 639         enddo
 640       enddo
 641 #ifdef DEBUG
 642       write (iout,*) "gradbufc after summing"
 643       do i=1,nres
 644         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 645       enddo
 646       call flush(iout)
 647 #endif
 648       else
 649 #endif
 650 #ifdef DEBUG
 651       write (iout,*) "gradbufc"
 652       do i=1,nres
 653         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 654       enddo
 655       call flush(iout)
 656 #endif
 657       do i=1,nres
 658         do j=1,3
 659           gradbufc_sum(j,i)=gradbufc(j,i)
 660           gradbufc(j,i)=0.0d0
 661         enddo
 662       enddo
 663       do j=1,3
 664         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 665       enddo
 666       do i=nres-2,nnt,-1
 667         do j=1,3
 668           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 669         enddo
 670       enddo
 671 c      do i=nnt,nres-1
 672 c        do k=1,3
 673 c          gradbufc(k,i)=0.0d0
 674 c        enddo
 675 c        do j=i+1,nres
 676 c          do k=1,3
 677 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 678 c          enddo
 679 c        enddo
 680 c      enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gradbufc after summing"
 683       do i=1,nres
 684         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 685       enddo
 686       call flush(iout)
 687 #endif
 688 #ifdef MPI
 689       endif
 690 #endif
 691       do k=1,3
 692         gradbufc(k,nres)=0.0d0
 693       enddo
 694       do i=1,nct
 695         do j=1,3
 696 #ifdef SPLITELE
 697           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 698      &                wel_loc*gel_loc(j,i)+
 699      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 700      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 701      &                wel_loc*gel_loc_long(j,i)+
 702      &                wcorr*gradcorr_long(j,i)+
 703      &                wcorr5*gradcorr5_long(j,i)+
 704      &                wcorr6*gradcorr6_long(j,i)+
 705      &                wturn6*gcorr6_turn_long(j,i))+
 706      &                wbond*gradb(j,i)+
 707      &                wcorr*gradcorr(j,i)+
 708      &                wturn3*gcorr3_turn(j,i)+
 709      &                wturn4*gcorr4_turn(j,i)+
 710      &                wcorr5*gradcorr5(j,i)+
 711      &                wcorr6*gradcorr6(j,i)+
 712      &                wturn6*gcorr6_turn(j,i)+
 713      &                wsccor*gsccorc(j,i)
 714      &               +wscloc*gscloc(j,i)
 715 #else
 716           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 717      &                wel_loc*gel_loc(j,i)+
 718      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 719      &                welec*gelc_long(j,i)+
 720      &                wel_loc*gel_loc_long(j,i)+
 721      &                wcorr*gcorr_long(j,i)+
 722      &                wcorr5*gradcorr5_long(j,i)+
 723      &                wcorr6*gradcorr6_long(j,i)+
 724      &                wturn6*gcorr6_turn_long(j,i))+
 725      &                wbond*gradb(j,i)+
 726      &                wcorr*gradcorr(j,i)+
 727      &                wturn3*gcorr3_turn(j,i)+
 728      &                wturn4*gcorr4_turn(j,i)+
 729      &                wcorr5*gradcorr5(j,i)+
 730      &                wcorr6*gradcorr6(j,i)+
 731      &                wturn6*gcorr6_turn(j,i)+
 732      &                wsccor*gsccorc(j,i)
 733      &               +wscloc*gscloc(j,i)
 734 #endif
 735 #ifdef TSCSC
 736           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 737      &                  wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #else
 743           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 744      &                  wbond*gradbx(j,i)+
 745      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 746      &                  wsccor*gsccorx(j,i)
 747      &                 +wscloc*gsclocx(j,i)
 748 #endif
 749         enddo
 750       enddo
 751 #ifdef DEBUG
 752       write (iout,*) "gloc before adding corr"
 753       do i=1,4*nres
 754         write (iout,*) i,gloc(i,icg)
 755       enddo
 756 #endif
 757       do i=1,nres-3
 758         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 759      &   +wcorr5*g_corr5_loc(i)
 760      &   +wcorr6*g_corr6_loc(i)
 761      &   +wturn4*gel_loc_turn4(i)
 762      &   +wturn3*gel_loc_turn3(i)
 763      &   +wturn6*gel_loc_turn6(i)
 764      &   +wel_loc*gel_loc_loc(i)
 765       enddo
 766 #ifdef DEBUG
 767       write (iout,*) "gloc after adding corr"
 768       do i=1,4*nres
 769         write (iout,*) i,gloc(i,icg)
 770       enddo
 771 #endif
 772 #ifdef MPI
 773       if (nfgtasks.gt.1) then
 774         do j=1,3
 775           do i=1,nres
 776             gradbufc(j,i)=gradc(j,i,icg)
 777             gradbufx(j,i)=gradx(j,i,icg)
 778           enddo
 779         enddo
 780         do i=1,4*nres
 781           glocbuf(i)=gloc(i,icg)
 782         enddo
 783 #ifdef DEBUG
 784       write (iout,*) "gloc_sc before reduce"
 785       do i=1,nres
 786        do j=1,3
 787         write (iout,*) i,j,gloc_sc(j,i,icg)
 788        enddo
 789       enddo
 790 #endif
 791         do i=1,nres
 792          do j=1,3
 793           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 794          enddo
 795         enddo
 796         time00=MPI_Wtime()
 797         call MPI_Barrier(FG_COMM,IERR)
 798         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 799         time00=MPI_Wtime()
 800         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 #ifdef DEBUG
 810       write (iout,*) "gloc_sc after reduce"
 811       do i=1,nres
 812        do j=1,3
 813         write (iout,*) i,j,gloc_sc(j,i,icg)
 814        enddo
 815       enddo
 816 #endif
 817 #ifdef DEBUG
 818       write (iout,*) "gloc after reduce"
 819       do i=1,4*nres
 820         write (iout,*) i,gloc(i,icg)
 821       enddo
 822 #endif
 823       endif
 824 #endif
 825       if (gnorm_check) then
 826 c
 827 c Compute the maximum elements of the gradient
 828 c
 829       gvdwc_max=0.0d0
 830       gvdwc_scp_max=0.0d0
 831       gelc_max=0.0d0
 832       gvdwpp_max=0.0d0
 833       gradb_max=0.0d0
 834       ghpbc_max=0.0d0
 835       gradcorr_max=0.0d0
 836       gel_loc_max=0.0d0
 837       gcorr3_turn_max=0.0d0
 838       gcorr4_turn_max=0.0d0
 839       gradcorr5_max=0.0d0
 840       gradcorr6_max=0.0d0
 841       gcorr6_turn_max=0.0d0
 842       gsccorc_max=0.0d0
 843       gscloc_max=0.0d0
 844       gvdwx_max=0.0d0
 845       gradx_scp_max=0.0d0
 846       ghpbx_max=0.0d0
 847       gradxorr_max=0.0d0
 848       gsccorx_max=0.0d0
 849       gsclocx_max=0.0d0
 850       do i=1,nct
 851         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 852         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 853 #ifdef TSCSC
 854         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 855         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 856 #endif
 857         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 858         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 859      &   gvdwc_scp_max=gvdwc_scp_norm
 860         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 861         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 862         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 863         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 864         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 865         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 866         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 867         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 868         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 869         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 870         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 871         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 872         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 873      &    gcorr3_turn(1,i)))
 874         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 875      &    gcorr3_turn_max=gcorr3_turn_norm
 876         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 877      &    gcorr4_turn(1,i)))
 878         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 879      &    gcorr4_turn_max=gcorr4_turn_norm
 880         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 881         if (gradcorr5_norm.gt.gradcorr5_max)
 882      &    gradcorr5_max=gradcorr5_norm
 883         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 884         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 885         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 886      &    gcorr6_turn(1,i)))
 887         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 888      &    gcorr6_turn_max=gcorr6_turn_norm
 889         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 890         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 891         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 892         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 893         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 894         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 895 #ifdef TSCSC
 896         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898 #endif
 899         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 900         if (gradx_scp_norm.gt.gradx_scp_max)
 901      &    gradx_scp_max=gradx_scp_norm
 902         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 903         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 904         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 905         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 906         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 907         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 908         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 909         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 910       enddo
 911       if (gradout) then
 912 #ifdef AIX
 913         open(istat,file=statname,position="append")
 914 #else
 915         open(istat,file=statname,access="append")
 916 #endif
 917         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 918      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 919      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 920      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 921      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 922      &     gsccorx_max,gsclocx_max
 923         close(istat)
 924         if (gvdwc_max.gt.1.0d4) then
 925           write (iout,*) "gvdwc gvdwx gradb gradbx"
 926           do i=nnt,nct
 927             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 928      &        gradb(j,i),gradbx(j,i),j=1,3)
 929           enddo
 930           call pdbout(0.0d0,'cipiszcze',iout)
 931           call flush(iout)
 932         endif
 933       endif
 934       endif
 935 #ifdef DEBUG
 936       write (iout,*) "gradc gradx gloc"
 937       do i=1,nres
 938         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 939      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 940       enddo
 941 #endif
 942 #ifdef TIMING
 943 #ifdef MPI
 944       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 945 #else
 946       time_sumgradient=time_sumgradient+tcpu()-time01
 947 #endif
 948 #endif
 949       return
 950       end
 951 c-------------------------------------------------------------------------------
 952       subroutine rescale_weights(t_bath)
 953       implicit real*8 (a-h,o-z)
 954       include 'DIMENSIONS'
 955       include 'COMMON.IOUNITS'
 956       include 'COMMON.FFIELD'
 957       include 'COMMON.SBRIDGE'
 958       double precision kfac /2.4d0/
 959       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 960 c      facT=temp0/t_bath
 961 c      facT=2*temp0/(t_bath+temp0)
 962       if (rescale_mode.eq.0) then
 963         facT=1.0d0
 964         facT2=1.0d0
 965         facT3=1.0d0
 966         facT4=1.0d0
 967         facT5=1.0d0
 968       else if (rescale_mode.eq.1) then
 969         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 970         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 971         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 972         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 973         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 974       else if (rescale_mode.eq.2) then
 975         x=t_bath/temp0
 976         x2=x*x
 977         x3=x2*x
 978         x4=x3*x
 979         x5=x4*x
 980         facT=licznik/dlog(dexp(x)+dexp(-x))
 981         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 982         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 983         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 984         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 985       else
 986         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 987         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 988 #ifdef MPI
 989        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 990 #endif
 991        stop 555
 992       endif
 993       welec=weights(3)*fact
 994       wcorr=weights(4)*fact3
 995       wcorr5=weights(5)*fact4
 996       wcorr6=weights(6)*fact5
 997       wel_loc=weights(7)*fact2
 998       wturn3=weights(8)*fact2
 999       wturn4=weights(9)*fact3
1000       wturn6=weights(10)*fact5
1001       wtor=weights(13)*fact
1002       wtor_d=weights(14)*fact2
1003       wsccor=weights(21)*fact
1004 #ifdef TSCSC
1005 c      wsct=t_bath/temp0
1006       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1007 #endif
1008       return
1009       end
1010 C------------------------------------------------------------------------
1011       subroutine enerprint(energia)
1012       implicit real*8 (a-h,o-z)
1013       include 'DIMENSIONS'
1014       include 'COMMON.IOUNITS'
1015       include 'COMMON.FFIELD'
1016       include 'COMMON.SBRIDGE'
1017       include 'COMMON.MD'
1018       double precision energia(0:n_ene)
1019       etot=energia(0)
1020 #ifdef TSCSC
1021       evdw=energia(22)+wsct*energia(23)
1022 #else
1023       evdw=energia(1)
1024 #endif
1025       evdw2=energia(2)
1026 #ifdef SCP14
1027       evdw2=energia(2)+energia(18)
1028 #else
1029       evdw2=energia(2)
1030 #endif
1031       ees=energia(3)
1032 #ifdef SPLITELE
1033       evdw1=energia(16)
1034 #endif
1035       ecorr=energia(4)
1036       ecorr5=energia(5)
1037       ecorr6=energia(6)
1038       eel_loc=energia(7)
1039       eello_turn3=energia(8)
1040       eello_turn4=energia(9)
1041       eello_turn6=energia(10)
1042       ebe=energia(11)
1043       escloc=energia(12)
1044       etors=energia(13)
1045       etors_d=energia(14)
1046       ehpb=energia(15)
1047       edihcnstr=energia(19)
1048       estr=energia(17)
1049       Uconst=energia(20)
1050       esccor=energia(21)
1051 #ifdef SPLITELE
1052       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1053      &  estr,wbond,ebe,wang,
1054      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1055      &  ecorr,wcorr,
1056      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1057      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1058      &  edihcnstr,ebr*nss,
1059      &  Uconst,etot
1060    10 format (/'Virtual-chain energies:'//
1061      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1062      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1063      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1064      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1065      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1066      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1067      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1068      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1069      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1070      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1071      & ' (SS bridges & dist. cnstr.)'/
1072      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1075      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1076      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1077      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1078      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1079      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1080      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1081      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1082      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1083      & 'ETOT=  ',1pE16.6,' (total)')
1084 #else
1085       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1086      &  estr,wbond,ebe,wang,
1087      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1088      &  ecorr,wcorr,
1089      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1090      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1091      &  ebr*nss,Uconst,etot
1092    10 format (/'Virtual-chain energies:'//
1093      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1094      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1095      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1096      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1097      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1098      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1099      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1100      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1101      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1102      & ' (SS bridges & dist. cnstr.)'/
1103      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1106      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1107      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1108      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1109      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1110      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1111      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1112      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1113      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1114      & 'ETOT=  ',1pE16.6,' (total)')
1115 #endif
1116       return
1117       end
1118 C-----------------------------------------------------------------------
1119       subroutine elj(evdw,evdw_p,evdw_m)
1120 C
1121 C This subroutine calculates the interaction energy of nonbonded side chains
1122 C assuming the LJ potential of interaction.
1123 C
1124       implicit real*8 (a-h,o-z)
1125       include 'DIMENSIONS'
1126       parameter (accur=1.0d-10)
1127       include 'COMMON.GEO'
1128       include 'COMMON.VAR'
1129       include 'COMMON.LOCAL'
1130       include 'COMMON.CHAIN'
1131       include 'COMMON.DERIV'
1132       include 'COMMON.INTERACT'
1133       include 'COMMON.TORSION'
1134       include 'COMMON.SBRIDGE'
1135       include 'COMMON.NAMES'
1136       include 'COMMON.IOUNITS'
1137       include 'COMMON.CONTACTS'
1138       dimension gg(3)
1139 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1140       evdw=0.0D0
1141       do i=iatsc_s,iatsc_e
1142         itypi=itype(i)
1143         itypi1=itype(i+1)
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=itype(j)
1157             xj=c(1,nres+j)-xi
1158             yj=c(2,nres+j)-yi
1159             zj=c(3,nres+j)-zi
1160 C Change 12/1/95 to calculate four-body interactions
1161             rij=xj*xj+yj*yj+zj*zj
1162             rrij=1.0D0/rij
1163 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1164             eps0ij=eps(itypi,itypj)
1165             fac=rrij**expon2
1166             e1=fac*fac*aa(itypi,itypj)
1167             e2=fac*bb(itypi,itypj)
1168             evdwij=e1+e2
1169 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1170 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1171 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1172 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1173 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1174 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1175 #ifdef TSCSC
1176             if (bb(itypi,itypj).gt.0) then
1177                evdw_p=evdw_p+evdwij
1178             else
1179                evdw_m=evdw_m+evdwij
1180             endif
1181 #else
1182             evdw=evdw+evdwij
1183 #endif
1184 C
1185 C Calculate the components of the gradient in DC and X
1186 C
1187             fac=-rrij*(e1+evdwij)
1188             gg(1)=xj*fac
1189             gg(2)=yj*fac
1190             gg(3)=zj*fac
1191 #ifdef TSCSC
1192             if (bb(itypi,itypj).gt.0.0d0) then
1193               do k=1,3
1194                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1195                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1197                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1198               enddo
1199             else
1200               do k=1,3
1201                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1202                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1203                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1204                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1205               enddo
1206             endif
1207 #else
1208             do k=1,3
1209               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1210               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1211               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1212               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1213             enddo
1214 #endif
1215 cgrad            do k=i,j-1
1216 cgrad              do l=1,3
1217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1218 cgrad              enddo
1219 cgrad            enddo
1220 C
1221 C 12/1/95, revised on 5/20/97
1222 C
1223 C Calculate the contact function. The ith column of the array JCONT will
1224 C contain the numbers of atoms that make contacts with the atom I (of numbers
1225 C greater than I). The arrays FACONT and GACONT will contain the values of
1226 C the contact function and its derivative.
1227 C
1228 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1229 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1230 C Uncomment next line, if the correlation interactions are contact function only
1231             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1232               rij=dsqrt(rij)
1233               sigij=sigma(itypi,itypj)
1234               r0ij=rs0(itypi,itypj)
1235 C
1236 C Check whether the SC's are not too far to make a contact.
1237 C
1238               rcut=1.5d0*r0ij
1239               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1240 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1241 C
1242               if (fcont.gt.0.0D0) then
1243 C If the SC-SC distance if close to sigma, apply spline.
1244 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1245 cAdam &             fcont1,fprimcont1)
1246 cAdam           fcont1=1.0d0-fcont1
1247 cAdam           if (fcont1.gt.0.0d0) then
1248 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1249 cAdam             fcont=fcont*fcont1
1250 cAdam           endif
1251 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1252 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1253 cga             do k=1,3
1254 cga               gg(k)=gg(k)*eps0ij
1255 cga             enddo
1256 cga             eps0ij=-evdwij*eps0ij
1257 C Uncomment for AL's type of SC correlation interactions.
1258 cadam           eps0ij=-evdwij
1259                 num_conti=num_conti+1
1260                 jcont(num_conti,i)=j
1261                 facont(num_conti,i)=fcont*eps0ij
1262                 fprimcont=eps0ij*fprimcont/rij
1263                 fcont=expon*fcont
1264 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1265 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1266 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1267 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1268                 gacont(1,num_conti,i)=-fprimcont*xj
1269                 gacont(2,num_conti,i)=-fprimcont*yj
1270                 gacont(3,num_conti,i)=-fprimcont*zj
1271 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1272 cd              write (iout,'(2i3,3f10.5)')
1273 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1274               endif
1275             endif
1276           enddo      ! j
1277         enddo        ! iint
1278 C Change 12/1/95
1279         num_cont(i)=num_conti
1280       enddo          ! i
1281       do i=1,nct
1282         do j=1,3
1283           gvdwc(j,i)=expon*gvdwc(j,i)
1284           gvdwx(j,i)=expon*gvdwx(j,i)
1285         enddo
1286       enddo
1287 C******************************************************************************
1288 C
1289 C                              N O T E !!!
1290 C
1291 C To save time, the factor of EXPON has been extracted from ALL components
1292 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1293 C use!
1294 C
1295 C******************************************************************************
1296       return
1297       end
1298 C-----------------------------------------------------------------------------
1299       subroutine eljk(evdw,evdw_p,evdw_m)
1300 C
1301 C This subroutine calculates the interaction energy of nonbonded side chains
1302 C assuming the LJK potential of interaction.
1303 C
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.INTERACT'
1312       include 'COMMON.IOUNITS'
1313       include 'COMMON.NAMES'
1314       dimension gg(3)
1315       logical scheck
1316 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1317       evdw=0.0D0
1318       do i=iatsc_s,iatsc_e
1319         itypi=itype(i)
1320         itypi1=itype(i+1)
1321         xi=c(1,nres+i)
1322         yi=c(2,nres+i)
1323         zi=c(3,nres+i)
1324 C
1325 C Calculate SC interaction energy.
1326 C
1327         do iint=1,nint_gr(i)
1328           do j=istart(i,iint),iend(i,iint)
1329             itypj=itype(j)
1330             xj=c(1,nres+j)-xi
1331             yj=c(2,nres+j)-yi
1332             zj=c(3,nres+j)-zi
1333             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1334             fac_augm=rrij**expon
1335             e_augm=augm(itypi,itypj)*fac_augm
1336             r_inv_ij=dsqrt(rrij)
1337             rij=1.0D0/r_inv_ij
1338             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1339             fac=r_shift_inv**expon
1340             e1=fac*fac*aa(itypi,itypj)
1341             e2=fac*bb(itypi,itypj)
1342             evdwij=e_augm+e1+e2
1343 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1344 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1345 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1346 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1347 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1348 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1349 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1350 #ifdef TSCSC
1351             if (bb(itypi,itypj).gt.0) then
1352                evdw_p=evdw_p+evdwij
1353             else
1354                evdw_m=evdw_m+evdwij
1355             endif
1356 #else
1357             evdw=evdw+evdwij
1358 #endif
1359 C
1360 C Calculate the components of the gradient in DC and X
1361 C
1362             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1363             gg(1)=xj*fac
1364             gg(2)=yj*fac
1365             gg(3)=zj*fac
1366 #ifdef TSCSC
1367             if (bb(itypi,itypj).gt.0.0d0) then
1368               do k=1,3
1369                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1370                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1371                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1372                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1373               enddo
1374             else
1375               do k=1,3
1376                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1377                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1378                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1379                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1380               enddo
1381             endif
1382 #else
1383             do k=1,3
1384               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1385               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1386               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1387               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1388             enddo
1389 #endif
1390 cgrad            do k=i,j-1
1391 cgrad              do l=1,3
1392 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1393 cgrad              enddo
1394 cgrad            enddo
1395           enddo      ! j
1396         enddo        ! iint
1397       enddo          ! i
1398       do i=1,nct
1399         do j=1,3
1400           gvdwc(j,i)=expon*gvdwc(j,i)
1401           gvdwx(j,i)=expon*gvdwx(j,i)
1402         enddo
1403       enddo
1404       return
1405       end
1406 C-----------------------------------------------------------------------------
1407       subroutine ebp(evdw,evdw_p,evdw_m)
1408 C
1409 C This subroutine calculates the interaction energy of nonbonded side chains
1410 C assuming the Berne-Pechukas potential of interaction.
1411 C
1412       implicit real*8 (a-h,o-z)
1413       include 'DIMENSIONS'
1414       include 'COMMON.GEO'
1415       include 'COMMON.VAR'
1416       include 'COMMON.LOCAL'
1417       include 'COMMON.CHAIN'
1418       include 'COMMON.DERIV'
1419       include 'COMMON.NAMES'
1420       include 'COMMON.INTERACT'
1421       include 'COMMON.IOUNITS'
1422       include 'COMMON.CALC'
1423       common /srutu/ icall
1424 c     double precision rrsave(maxdim)
1425       logical lprn
1426       evdw=0.0D0
1427 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1428       evdw=0.0D0
1429 c     if (icall.eq.0) then
1430 c       lprn=.true.
1431 c     else
1432         lprn=.false.
1433 c     endif
1434       ind=0
1435       do i=iatsc_s,iatsc_e
1436         itypi=itype(i)
1437         itypi1=itype(i+1)
1438         xi=c(1,nres+i)
1439         yi=c(2,nres+i)
1440         zi=c(3,nres+i)
1441         dxi=dc_norm(1,nres+i)
1442         dyi=dc_norm(2,nres+i)
1443         dzi=dc_norm(3,nres+i)
1444 c        dsci_inv=dsc_inv(itypi)
1445         dsci_inv=vbld_inv(i+nres)
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450           do j=istart(i,iint),iend(i,iint)
1451             ind=ind+1
1452             itypj=itype(j)
1453 c            dscj_inv=dsc_inv(itypj)
1454             dscj_inv=vbld_inv(j+nres)
1455             chi1=chi(itypi,itypj)
1456             chi2=chi(itypj,itypi)
1457             chi12=chi1*chi2
1458             chip1=chip(itypi)
1459             chip2=chip(itypj)
1460             chip12=chip1*chip2
1461             alf1=alp(itypi)
1462             alf2=alp(itypj)
1463             alf12=0.5D0*(alf1+alf2)
1464 C For diagnostics only!!!
1465 c           chi1=0.0D0
1466 c           chi2=0.0D0
1467 c           chi12=0.0D0
1468 c           chip1=0.0D0
1469 c           chip2=0.0D0
1470 c           chip12=0.0D0
1471 c           alf1=0.0D0
1472 c           alf2=0.0D0
1473 c           alf12=0.0D0
1474             xj=c(1,nres+j)-xi
1475             yj=c(2,nres+j)-yi
1476             zj=c(3,nres+j)-zi
1477             dxj=dc_norm(1,nres+j)
1478             dyj=dc_norm(2,nres+j)
1479             dzj=dc_norm(3,nres+j)
1480             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1481 cd          if (icall.eq.0) then
1482 cd            rrsave(ind)=rrij
1483 cd          else
1484 cd            rrij=rrsave(ind)
1485 cd          endif
1486             rij=dsqrt(rrij)
1487 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1488             call sc_angular
1489 C Calculate whole angle-dependent part of epsilon and contributions
1490 C to its derivatives
1491             fac=(rrij*sigsq)**expon2
1492             e1=fac*fac*aa(itypi,itypj)
1493             e2=fac*bb(itypi,itypj)
1494             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1495             eps2der=evdwij*eps3rt
1496             eps3der=evdwij*eps2rt
1497             evdwij=evdwij*eps2rt*eps3rt
1498 #ifdef TSCSC
1499             if (bb(itypi,itypj).gt.0) then
1500                evdw_p=evdw_p+evdwij
1501             else
1502                evdw_m=evdw_m+evdwij
1503             endif
1504 #else
1505             evdw=evdw+evdwij
1506 #endif
1507             if (lprn) then
1508             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1509             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1510 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1511 cd     &        restyp(itypi),i,restyp(itypj),j,
1512 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1513 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1514 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1515 cd     &        evdwij
1516             endif
1517 C Calculate gradient components.
1518             e1=e1*eps1*eps2rt**2*eps3rt**2
1519             fac=-expon*(e1+evdwij)
1520             sigder=fac/sigsq
1521             fac=rrij*fac
1522 C Calculate radial part of the gradient
1523             gg(1)=xj*fac
1524             gg(2)=yj*fac
1525             gg(3)=zj*fac
1526 C Calculate the angular part of the gradient and sum add the contributions
1527 C to the appropriate components of the Cartesian gradient.
1528 #ifdef TSCSC
1529             if (bb(itypi,itypj).gt.0) then
1530                call sc_grad
1531             else
1532                call sc_grad_T
1533             endif
1534 #else
1535             call sc_grad
1536 #endif
1537           enddo      ! j
1538         enddo        ! iint
1539       enddo          ! i
1540 c     stop
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egb(evdw,evdw_p,evdw_m)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       include 'COMMON.CONTROL'
1561       include 'COMMON.SBRIDGE'
1562       logical lprn
1563       evdw=0.0D0
1564 ccccc      energy_dec=.false.
1565 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1566       evdw=0.0D0
1567       evdw_p=0.0D0
1568       evdw_m=0.0D0
1569       lprn=.false.
1570 c     if (icall.eq.0) lprn=.false.
1571       ind=0
1572       do i=iatsc_s,iatsc_e
1573         itypi=itype(i)
1574         itypi1=itype(i+1)
1575         xi=c(1,nres+i)
1576         yi=c(2,nres+i)
1577         zi=c(3,nres+i)
1578         dxi=dc_norm(1,nres+i)
1579         dyi=dc_norm(2,nres+i)
1580         dzi=dc_norm(3,nres+i)
1581 c        dsci_inv=dsc_inv(itypi)
1582         dsci_inv=vbld_inv(i+nres)
1583 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1584 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1585 C
1586 C Calculate SC interaction energy.
1587 C
1588         do iint=1,nint_gr(i)
1589           do j=istart(i,iint),iend(i,iint)
1590             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1591               call dyn_ssbond_ene(i,j,evdwij)
1592               evdw=evdw+evdwij
1593               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1594      &                        'evdw',i,j,evdwij,' ss'
1595             ELSE
1596             ind=ind+1
1597             itypj=itype(j)
1598 c            dscj_inv=dsc_inv(itypj)
1599             dscj_inv=vbld_inv(j+nres)
1600 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1601 c     &       1.0d0/vbld(j+nres)
1602 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1603             sig0ij=sigma(itypi,itypj)
1604             chi1=chi(itypi,itypj)
1605             chi2=chi(itypj,itypi)
1606             chi12=chi1*chi2
1607             chip1=chip(itypi)
1608             chip2=chip(itypj)
1609             chip12=chip1*chip2
1610             alf1=alp(itypi)
1611             alf2=alp(itypj)
1612             alf12=0.5D0*(alf1+alf2)
1613 C For diagnostics only!!!
1614 c           chi1=0.0D0
1615 c           chi2=0.0D0
1616 c           chi12=0.0D0
1617 c           chip1=0.0D0
1618 c           chip2=0.0D0
1619 c           chip12=0.0D0
1620 c           alf1=0.0D0
1621 c           alf2=0.0D0
1622 c           alf12=0.0D0
1623             xj=c(1,nres+j)-xi
1624             yj=c(2,nres+j)-yi
1625             zj=c(3,nres+j)-zi
1626             dxj=dc_norm(1,nres+j)
1627             dyj=dc_norm(2,nres+j)
1628             dzj=dc_norm(3,nres+j)
1629 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1630 c            write (iout,*) "j",j," dc_norm",
1631 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1632             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1633             rij=dsqrt(rrij)
1634 C Calculate angle-dependent terms of energy and contributions to their
1635 C derivatives.
1636             call sc_angular
1637             sigsq=1.0D0/sigsq
1638             sig=sig0ij*dsqrt(sigsq)
1639             rij_shift=1.0D0/rij-sig+sig0ij
1640 c for diagnostics; uncomment
1641 c            rij_shift=1.2*sig0ij
1642 C I hate to put IF's in the loops, but here don't have another choice!!!!
1643             if (rij_shift.le.0.0D0) then
1644               evdw=1.0D20
1645 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1646 cd     &        restyp(itypi),i,restyp(itypj),j,
1647 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1648               return
1649             endif
1650             sigder=-sig*sigsq
1651 c---------------------------------------------------------------
1652             rij_shift=1.0D0/rij_shift
1653             fac=rij_shift**expon
1654             e1=fac*fac*aa(itypi,itypj)
1655             e2=fac*bb(itypi,itypj)
1656             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1657             eps2der=evdwij*eps3rt
1658             eps3der=evdwij*eps2rt
1659 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1660 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1661             evdwij=evdwij*eps2rt*eps3rt
1662 #ifdef TSCSC
1663             if (bb(itypi,itypj).gt.0) then
1664                evdw_p=evdw_p+evdwij
1665             else
1666                evdw_m=evdw_m+evdwij
1667             endif
1668 #else
1669             evdw=evdw+evdwij
1670 #endif
1671             if (lprn) then
1672             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1673             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1674             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1675      &        restyp(itypi),i,restyp(itypj),j,
1676      &        epsi,sigm,chi1,chi2,chip1,chip2,
1677      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1678      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1679      &        evdwij
1680             endif
1681
1682             if (energy_dec) then
1683               write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1684               call flush(iout)
1685             endif
1686 C Calculate gradient components.
1687             e1=e1*eps1*eps2rt**2*eps3rt**2
1688             fac=-expon*(e1+evdwij)*rij_shift
1689             sigder=fac*sigder
1690             fac=rij*fac
1691 c            fac=0.0d0
1692 C Calculate the radial part of the gradient
1693             gg(1)=xj*fac
1694             gg(2)=yj*fac
1695             gg(3)=zj*fac
1696 C Calculate angular part of the gradient.
1697 #ifdef TSCSC
1698             if (bb(itypi,itypj).gt.0) then
1699                call sc_grad
1700             else
1701                call sc_grad_T
1702             endif
1703 #else
1704             call sc_grad
1705 #endif
1706             ENDIF    ! dyn_ss
1707           enddo      ! j
1708         enddo        ! iint
1709       enddo          ! i
1710 c      write (iout,*) "Number of loop steps in EGB:",ind
1711 cccc      energy_dec=.false.
1712       return
1713       end
1714 C-----------------------------------------------------------------------------
1715       subroutine egbv(evdw,evdw_p,evdw_m)
1716 C
1717 C This subroutine calculates the interaction energy of nonbonded side chains
1718 C assuming the Gay-Berne-Vorobjev potential of interaction.
1719 C
1720       implicit real*8 (a-h,o-z)
1721       include 'DIMENSIONS'
1722       include 'COMMON.GEO'
1723       include 'COMMON.VAR'
1724       include 'COMMON.LOCAL'
1725       include 'COMMON.CHAIN'
1726       include 'COMMON.DERIV'
1727       include 'COMMON.NAMES'
1728       include 'COMMON.INTERACT'
1729       include 'COMMON.IOUNITS'
1730       include 'COMMON.CALC'
1731       common /srutu/ icall
1732       logical lprn
1733       evdw=0.0D0
1734 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1735       evdw=0.0D0
1736       lprn=.false.
1737 c     if (icall.eq.0) lprn=.true.
1738       ind=0
1739       do i=iatsc_s,iatsc_e
1740         itypi=itype(i)
1741         itypi1=itype(i+1)
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745         dxi=dc_norm(1,nres+i)
1746         dyi=dc_norm(2,nres+i)
1747         dzi=dc_norm(3,nres+i)
1748 c        dsci_inv=dsc_inv(itypi)
1749         dsci_inv=vbld_inv(i+nres)
1750 C
1751 C Calculate SC interaction energy.
1752 C
1753         do iint=1,nint_gr(i)
1754           do j=istart(i,iint),iend(i,iint)
1755             ind=ind+1
1756             itypj=itype(j)
1757 c            dscj_inv=dsc_inv(itypj)
1758             dscj_inv=vbld_inv(j+nres)
1759             sig0ij=sigma(itypi,itypj)
1760             r0ij=r0(itypi,itypj)
1761             chi1=chi(itypi,itypj)
1762             chi2=chi(itypj,itypi)
1763             chi12=chi1*chi2
1764             chip1=chip(itypi)
1765             chip2=chip(itypj)
1766             chip12=chip1*chip2
1767             alf1=alp(itypi)
1768             alf2=alp(itypj)
1769             alf12=0.5D0*(alf1+alf2)
1770 C For diagnostics only!!!
1771 c           chi1=0.0D0
1772 c           chi2=0.0D0
1773 c           chi12=0.0D0
1774 c           chip1=0.0D0
1775 c           chip2=0.0D0
1776 c           chip12=0.0D0
1777 c           alf1=0.0D0
1778 c           alf2=0.0D0
1779 c           alf12=0.0D0
1780             xj=c(1,nres+j)-xi
1781             yj=c(2,nres+j)-yi
1782             zj=c(3,nres+j)-zi
1783             dxj=dc_norm(1,nres+j)
1784             dyj=dc_norm(2,nres+j)
1785             dzj=dc_norm(3,nres+j)
1786             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1787             rij=dsqrt(rrij)
1788 C Calculate angle-dependent terms of energy and contributions to their
1789 C derivatives.
1790             call sc_angular
1791             sigsq=1.0D0/sigsq
1792             sig=sig0ij*dsqrt(sigsq)
1793             rij_shift=1.0D0/rij-sig+r0ij
1794 C I hate to put IF's in the loops, but here don't have another choice!!!!
1795             if (rij_shift.le.0.0D0) then
1796               evdw=1.0D20
1797               return
1798             endif
1799             sigder=-sig*sigsq
1800 c---------------------------------------------------------------
1801             rij_shift=1.0D0/rij_shift
1802             fac=rij_shift**expon
1803             e1=fac*fac*aa(itypi,itypj)
1804             e2=fac*bb(itypi,itypj)
1805             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1806             eps2der=evdwij*eps3rt
1807             eps3der=evdwij*eps2rt
1808             fac_augm=rrij**expon
1809             e_augm=augm(itypi,itypj)*fac_augm
1810             evdwij=evdwij*eps2rt*eps3rt
1811 #ifdef TSCSC
1812             if (bb(itypi,itypj).gt.0) then
1813                evdw_p=evdw_p+evdwij+e_augm
1814             else
1815                evdw_m=evdw_m+evdwij+e_augm
1816             endif
1817 #else
1818             evdw=evdw+evdwij+e_augm
1819 #endif
1820             if (lprn) then
1821             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1822             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1823             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1824      &        restyp(itypi),i,restyp(itypj),j,
1825      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1826      &        chi1,chi2,chip1,chip2,
1827      &        eps1,eps2rt**2,eps3rt**2,
1828      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1829      &        evdwij+e_augm
1830             endif
1831 C Calculate gradient components.
1832             e1=e1*eps1*eps2rt**2*eps3rt**2
1833             fac=-expon*(e1+evdwij)*rij_shift
1834             sigder=fac*sigder
1835             fac=rij*fac-2*expon*rrij*e_augm
1836 C Calculate the radial part of the gradient
1837             gg(1)=xj*fac
1838             gg(2)=yj*fac
1839             gg(3)=zj*fac
1840 C Calculate angular part of the gradient.
1841 #ifdef TSCSC
1842             if (bb(itypi,itypj).gt.0) then
1843                call sc_grad
1844             else
1845                call sc_grad_T
1846             endif
1847 #else
1848             call sc_grad
1849 #endif
1850           enddo      ! j
1851         enddo        ! iint
1852       enddo          ! i
1853       end
1854 C-----------------------------------------------------------------------------
1855       subroutine sc_angular
1856 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1857 C om12. Called by ebp, egb, and egbv.
1858       implicit none
1859       include 'COMMON.CALC'
1860       include 'COMMON.IOUNITS'
1861       erij(1)=xj*rij
1862       erij(2)=yj*rij
1863       erij(3)=zj*rij
1864       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1865       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1866       om12=dxi*dxj+dyi*dyj+dzi*dzj
1867       chiom12=chi12*om12
1868 C Calculate eps1(om12) and its derivative in om12
1869       faceps1=1.0D0-om12*chiom12
1870       faceps1_inv=1.0D0/faceps1
1871       eps1=dsqrt(faceps1_inv)
1872 C Following variable is eps1*deps1/dom12
1873       eps1_om12=faceps1_inv*chiom12
1874 c diagnostics only
1875 c      faceps1_inv=om12
1876 c      eps1=om12
1877 c      eps1_om12=1.0d0
1878 c      write (iout,*) "om12",om12," eps1",eps1
1879 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1880 C and om12.
1881       om1om2=om1*om2
1882       chiom1=chi1*om1
1883       chiom2=chi2*om2
1884       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1885       sigsq=1.0D0-facsig*faceps1_inv
1886       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1887       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1888       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1889 c diagnostics only
1890 c      sigsq=1.0d0
1891 c      sigsq_om1=0.0d0
1892 c      sigsq_om2=0.0d0
1893 c      sigsq_om12=0.0d0
1894 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1895 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1896 c     &    " eps1",eps1
1897 C Calculate eps2 and its derivatives in om1, om2, and om12.
1898       chipom1=chip1*om1
1899       chipom2=chip2*om2
1900       chipom12=chip12*om12
1901       facp=1.0D0-om12*chipom12
1902       facp_inv=1.0D0/facp
1903       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1904 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1905 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1906 C Following variable is the square root of eps2
1907       eps2rt=1.0D0-facp1*facp_inv
1908 C Following three variables are the derivatives of the square root of eps
1909 C in om1, om2, and om12.
1910       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1911       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1912       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1913 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1914       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1915 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1916 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1917 c     &  " eps2rt_om12",eps2rt_om12
1918 C Calculate whole angle-dependent part of epsilon and contributions
1919 C to its derivatives
1920       return
1921       end
1922
1923 C----------------------------------------------------------------------------
1924       subroutine sc_grad_T
1925       implicit real*8 (a-h,o-z)
1926       include 'DIMENSIONS'
1927       include 'COMMON.CHAIN'
1928       include 'COMMON.DERIV'
1929       include 'COMMON.CALC'
1930       include 'COMMON.IOUNITS'
1931       double precision dcosom1(3),dcosom2(3)
1932       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1933       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1934       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1935      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1936 c diagnostics only
1937 c      eom1=0.0d0
1938 c      eom2=0.0d0
1939 c      eom12=evdwij*eps1_om12
1940 c end diagnostics
1941 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1942 c     &  " sigder",sigder
1943 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1944 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1945       do k=1,3
1946         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1947         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1948       enddo
1949       do k=1,3
1950         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1951       enddo
1952 c      write (iout,*) "gg",(gg(k),k=1,3)
1953       do k=1,3
1954         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1955      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1956      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1957         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1958      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1961 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1962 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1963 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1964       enddo
1965 C
1966 C Calculate the components of the gradient in DC and X
1967 C
1968 cgrad      do k=i,j-1
1969 cgrad        do l=1,3
1970 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1971 cgrad        enddo
1972 cgrad      enddo
1973       do l=1,3
1974         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1975         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1976       enddo
1977       return
1978       end
1979
1980 C----------------------------------------------------------------------------
1981       subroutine sc_grad
1982       implicit real*8 (a-h,o-z)
1983       include 'DIMENSIONS'
1984       include 'COMMON.CHAIN'
1985       include 'COMMON.DERIV'
1986       include 'COMMON.CALC'
1987       include 'COMMON.IOUNITS'
1988       double precision dcosom1(3),dcosom2(3)
1989       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1990       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1991       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1992      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1993 c diagnostics only
1994 c      eom1=0.0d0
1995 c      eom2=0.0d0
1996 c      eom12=evdwij*eps1_om12
1997 c end diagnostics
1998 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1999 c     &  " sigder",sigder
2000 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2001 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2002       do k=1,3
2003         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2004         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2005       enddo
2006       do k=1,3
2007         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2008       enddo
2009 c      write (iout,*) "gg",(gg(k),k=1,3)
2010       do k=1,3
2011         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2012      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2013      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2014         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2015      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2018 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2019 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2020 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2021       enddo
2022 C
2023 C Calculate the components of the gradient in DC and X
2024 C
2025 cgrad      do k=i,j-1
2026 cgrad        do l=1,3
2027 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2028 cgrad        enddo
2029 cgrad      enddo
2030       do l=1,3
2031         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2032         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2033       enddo
2034       return
2035       end
2036 C-----------------------------------------------------------------------
2037       subroutine e_softsphere(evdw)
2038 C
2039 C This subroutine calculates the interaction energy of nonbonded side chains
2040 C assuming the LJ potential of interaction.
2041 C
2042       implicit real*8 (a-h,o-z)
2043       include 'DIMENSIONS'
2044       parameter (accur=1.0d-10)
2045       include 'COMMON.GEO'
2046       include 'COMMON.VAR'
2047       include 'COMMON.LOCAL'
2048       include 'COMMON.CHAIN'
2049       include 'COMMON.DERIV'
2050       include 'COMMON.INTERACT'
2051       include 'COMMON.TORSION'
2052       include 'COMMON.SBRIDGE'
2053       include 'COMMON.NAMES'
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.CONTACTS'
2056       dimension gg(3)
2057 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2058       evdw=0.0D0
2059       do i=iatsc_s,iatsc_e
2060         itypi=itype(i)
2061         itypi1=itype(i+1)
2062         xi=c(1,nres+i)
2063         yi=c(2,nres+i)
2064         zi=c(3,nres+i)
2065 C
2066 C Calculate SC interaction energy.
2067 C
2068         do iint=1,nint_gr(i)
2069 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2070 cd   &                  'iend=',iend(i,iint)
2071           do j=istart(i,iint),iend(i,iint)
2072             itypj=itype(j)
2073             xj=c(1,nres+j)-xi
2074             yj=c(2,nres+j)-yi
2075             zj=c(3,nres+j)-zi
2076             rij=xj*xj+yj*yj+zj*zj
2077 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2078             r0ij=r0(itypi,itypj)
2079             r0ijsq=r0ij*r0ij
2080 c            print *,i,j,r0ij,dsqrt(rij)
2081             if (rij.lt.r0ijsq) then
2082               evdwij=0.25d0*(rij-r0ijsq)**2
2083               fac=rij-r0ijsq
2084             else
2085               evdwij=0.0d0
2086               fac=0.0d0
2087             endif
2088             evdw=evdw+evdwij
2089 C
2090 C Calculate the components of the gradient in DC and X
2091 C
2092             gg(1)=xj*fac
2093             gg(2)=yj*fac
2094             gg(3)=zj*fac
2095             do k=1,3
2096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2100             enddo
2101 cgrad            do k=i,j-1
2102 cgrad              do l=1,3
2103 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2104 cgrad              enddo
2105 cgrad            enddo
2106           enddo ! j
2107         enddo ! iint
2108       enddo ! i
2109       return
2110       end
2111 C--------------------------------------------------------------------------
2112       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2113      &              eello_turn4)
2114 C
2115 C Soft-sphere potential of p-p interaction
2116 C
2117       implicit real*8 (a-h,o-z)
2118       include 'DIMENSIONS'
2119       include 'COMMON.CONTROL'
2120       include 'COMMON.IOUNITS'
2121       include 'COMMON.GEO'
2122       include 'COMMON.VAR'
2123       include 'COMMON.LOCAL'
2124       include 'COMMON.CHAIN'
2125       include 'COMMON.DERIV'
2126       include 'COMMON.INTERACT'
2127       include 'COMMON.CONTACTS'
2128       include 'COMMON.TORSION'
2129       include 'COMMON.VECTORS'
2130       include 'COMMON.FFIELD'
2131       dimension ggg(3)
2132 cd      write(iout,*) 'In EELEC_soft_sphere'
2133       ees=0.0D0
2134       evdw1=0.0D0
2135       eel_loc=0.0d0
2136       eello_turn3=0.0d0
2137       eello_turn4=0.0d0
2138       ind=0
2139       do i=iatel_s,iatel_e
2140         dxi=dc(1,i)
2141         dyi=dc(2,i)
2142         dzi=dc(3,i)
2143         xmedi=c(1,i)+0.5d0*dxi
2144         ymedi=c(2,i)+0.5d0*dyi
2145         zmedi=c(3,i)+0.5d0*dzi
2146         num_conti=0
2147 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2148         do j=ielstart(i),ielend(i)
2149           ind=ind+1
2150           iteli=itel(i)
2151           itelj=itel(j)
2152           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2153           r0ij=rpp(iteli,itelj)
2154           r0ijsq=r0ij*r0ij
2155           dxj=dc(1,j)
2156           dyj=dc(2,j)
2157           dzj=dc(3,j)
2158           xj=c(1,j)+0.5D0*dxj-xmedi
2159           yj=c(2,j)+0.5D0*dyj-ymedi
2160           zj=c(3,j)+0.5D0*dzj-zmedi
2161           rij=xj*xj+yj*yj+zj*zj
2162           if (rij.lt.r0ijsq) then
2163             evdw1ij=0.25d0*(rij-r0ijsq)**2
2164             fac=rij-r0ijsq
2165           else
2166             evdw1ij=0.0d0
2167             fac=0.0d0
2168           endif
2169           evdw1=evdw1+evdw1ij
2170 C
2171 C Calculate contributions to the Cartesian gradient.
2172 C
2173           ggg(1)=fac*xj
2174           ggg(2)=fac*yj
2175           ggg(3)=fac*zj
2176           do k=1,3
2177             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2178             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2179           enddo
2180 *
2181 * Loop over residues i+1 thru j-1.
2182 *
2183 cgrad          do k=i+1,j-1
2184 cgrad            do l=1,3
2185 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2186 cgrad            enddo
2187 cgrad          enddo
2188         enddo ! j
2189       enddo   ! i
2190 cgrad      do i=nnt,nct-1
2191 cgrad        do k=1,3
2192 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2193 cgrad        enddo
2194 cgrad        do j=i+1,nct-1
2195 cgrad          do k=1,3
2196 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2197 cgrad          enddo
2198 cgrad        enddo
2199 cgrad      enddo
2200       return
2201       end
2202 c------------------------------------------------------------------------------
2203       subroutine vec_and_deriv
2204       implicit real*8 (a-h,o-z)
2205       include 'DIMENSIONS'
2206 #ifdef MPI
2207       include 'mpif.h'
2208 #endif
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.GEO'
2211       include 'COMMON.VAR'
2212       include 'COMMON.LOCAL'
2213       include 'COMMON.CHAIN'
2214       include 'COMMON.VECTORS'
2215       include 'COMMON.SETUP'
2216       include 'COMMON.TIME1'
2217       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2218 C Compute the local reference systems. For reference system (i), the
2219 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2220 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2221 #ifdef PARVEC
2222       do i=ivec_start,ivec_end
2223 #else
2224       do i=1,nres-1
2225 #endif
2226           if (i.eq.nres-1) then
2227 C Case of the last full residue
2228 C Compute the Z-axis
2229             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2230             costh=dcos(pi-theta(nres))
2231             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2232             do k=1,3
2233               uz(k,i)=fac*uz(k,i)
2234             enddo
2235 C Compute the derivatives of uz
2236             uzder(1,1,1)= 0.0d0
2237             uzder(2,1,1)=-dc_norm(3,i-1)
2238             uzder(3,1,1)= dc_norm(2,i-1)
2239             uzder(1,2,1)= dc_norm(3,i-1)
2240             uzder(2,2,1)= 0.0d0
2241             uzder(3,2,1)=-dc_norm(1,i-1)
2242             uzder(1,3,1)=-dc_norm(2,i-1)
2243             uzder(2,3,1)= dc_norm(1,i-1)
2244             uzder(3,3,1)= 0.0d0
2245             uzder(1,1,2)= 0.0d0
2246             uzder(2,1,2)= dc_norm(3,i)
2247             uzder(3,1,2)=-dc_norm(2,i)
2248             uzder(1,2,2)=-dc_norm(3,i)
2249             uzder(2,2,2)= 0.0d0
2250             uzder(3,2,2)= dc_norm(1,i)
2251             uzder(1,3,2)= dc_norm(2,i)
2252             uzder(2,3,2)=-dc_norm(1,i)
2253             uzder(3,3,2)= 0.0d0
2254 C Compute the Y-axis
2255             facy=fac
2256             do k=1,3
2257               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2258             enddo
2259 C Compute the derivatives of uy
2260             do j=1,3
2261               do k=1,3
2262                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2263      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2264                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2265               enddo
2266               uyder(j,j,1)=uyder(j,j,1)-costh
2267               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2268             enddo
2269             do j=1,2
2270               do k=1,3
2271                 do l=1,3
2272                   uygrad(l,k,j,i)=uyder(l,k,j)
2273                   uzgrad(l,k,j,i)=uzder(l,k,j)
2274                 enddo
2275               enddo
2276             enddo
2277             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2278             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2279             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2280             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2281           else
2282 C Other residues
2283 C Compute the Z-axis
2284             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2285             costh=dcos(pi-theta(i+2))
2286             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2287             do k=1,3
2288               uz(k,i)=fac*uz(k,i)
2289             enddo
2290 C Compute the derivatives of uz
2291             uzder(1,1,1)= 0.0d0
2292             uzder(2,1,1)=-dc_norm(3,i+1)
2293             uzder(3,1,1)= dc_norm(2,i+1)
2294             uzder(1,2,1)= dc_norm(3,i+1)
2295             uzder(2,2,1)= 0.0d0
2296             uzder(3,2,1)=-dc_norm(1,i+1)
2297             uzder(1,3,1)=-dc_norm(2,i+1)
2298             uzder(2,3,1)= dc_norm(1,i+1)
2299             uzder(3,3,1)= 0.0d0
2300             uzder(1,1,2)= 0.0d0
2301             uzder(2,1,2)= dc_norm(3,i)
2302             uzder(3,1,2)=-dc_norm(2,i)
2303             uzder(1,2,2)=-dc_norm(3,i)
2304             uzder(2,2,2)= 0.0d0
2305             uzder(3,2,2)= dc_norm(1,i)
2306             uzder(1,3,2)= dc_norm(2,i)
2307             uzder(2,3,2)=-dc_norm(1,i)
2308             uzder(3,3,2)= 0.0d0
2309 C Compute the Y-axis
2310             facy=fac
2311             do k=1,3
2312               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2313             enddo
2314 C Compute the derivatives of uy
2315             do j=1,3
2316               do k=1,3
2317                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2318      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2319                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2320               enddo
2321               uyder(j,j,1)=uyder(j,j,1)-costh
2322               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2323             enddo
2324             do j=1,2
2325               do k=1,3
2326                 do l=1,3
2327                   uygrad(l,k,j,i)=uyder(l,k,j)
2328                   uzgrad(l,k,j,i)=uzder(l,k,j)
2329                 enddo
2330               enddo
2331             enddo
2332             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2333             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2334             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2335             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2336           endif
2337       enddo
2338       do i=1,nres-1
2339         vbld_inv_temp(1)=vbld_inv(i+1)
2340         if (i.lt.nres-1) then
2341           vbld_inv_temp(2)=vbld_inv(i+2)
2342           else
2343           vbld_inv_temp(2)=vbld_inv(i)
2344           endif
2345         do j=1,2
2346           do k=1,3
2347             do l=1,3
2348               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2349               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2350             enddo
2351           enddo
2352         enddo
2353       enddo
2354 #if defined(PARVEC) && defined(MPI)
2355       if (nfgtasks1.gt.1) then
2356         time00=MPI_Wtime()
2357 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2358 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2359 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2360         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2361      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2362      &   FG_COMM1,IERR)
2363         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2364      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2365      &   FG_COMM1,IERR)
2366         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2367      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2368      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2369         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2370      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2371      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2372         time_gather=time_gather+MPI_Wtime()-time00
2373       endif
2374 c      if (fg_rank.eq.0) then
2375 c        write (iout,*) "Arrays UY and UZ"
2376 c        do i=1,nres-1
2377 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2378 c     &     (uz(k,i),k=1,3)
2379 c        enddo
2380 c      endif
2381 #endif
2382       return
2383       end
2384 C-----------------------------------------------------------------------------
2385       subroutine check_vecgrad
2386       implicit real*8 (a-h,o-z)
2387       include 'DIMENSIONS'
2388       include 'COMMON.IOUNITS'
2389       include 'COMMON.GEO'
2390       include 'COMMON.VAR'
2391       include 'COMMON.LOCAL'
2392       include 'COMMON.CHAIN'
2393       include 'COMMON.VECTORS'
2394       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2395       dimension uyt(3,maxres),uzt(3,maxres)
2396       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2397       double precision delta /1.0d-7/
2398       call vec_and_deriv
2399 cd      do i=1,nres
2400 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2401 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2402 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2403 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2404 cd     &     (dc_norm(if90,i),if90=1,3)
2405 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2406 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2407 cd          write(iout,'(a)')
2408 cd      enddo
2409       do i=1,nres
2410         do j=1,2
2411           do k=1,3
2412             do l=1,3
2413               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2414               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2415             enddo
2416           enddo
2417         enddo
2418       enddo
2419       call vec_and_deriv
2420       do i=1,nres
2421         do j=1,3
2422           uyt(j,i)=uy(j,i)
2423           uzt(j,i)=uz(j,i)
2424         enddo
2425       enddo
2426       do i=1,nres
2427 cd        write (iout,*) 'i=',i
2428         do k=1,3
2429           erij(k)=dc_norm(k,i)
2430         enddo
2431         do j=1,3
2432           do k=1,3
2433             dc_norm(k,i)=erij(k)
2434           enddo
2435           dc_norm(j,i)=dc_norm(j,i)+delta
2436 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2437 c          do k=1,3
2438 c            dc_norm(k,i)=dc_norm(k,i)/fac
2439 c          enddo
2440 c          write (iout,*) (dc_norm(k,i),k=1,3)
2441 c          write (iout,*) (erij(k),k=1,3)
2442           call vec_and_deriv
2443           do k=1,3
2444             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2445             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2446             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2447             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2448           enddo
2449 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2451 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2452         enddo
2453         do k=1,3
2454           dc_norm(k,i)=erij(k)
2455         enddo
2456 cd        do k=1,3
2457 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2458 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2459 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2460 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2461 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2462 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2463 cd          write (iout,'(a)')
2464 cd        enddo
2465       enddo
2466       return
2467       end
2468 C--------------------------------------------------------------------------
2469       subroutine set_matrices
2470       implicit real*8 (a-h,o-z)
2471       include 'DIMENSIONS'
2472 #ifdef MPI
2473       include "mpif.h"
2474       include "COMMON.SETUP"
2475       integer IERR
2476       integer status(MPI_STATUS_SIZE)
2477 #endif
2478       include 'COMMON.IOUNITS'
2479       include 'COMMON.GEO'
2480       include 'COMMON.VAR'
2481       include 'COMMON.LOCAL'
2482       include 'COMMON.CHAIN'
2483       include 'COMMON.DERIV'
2484       include 'COMMON.INTERACT'
2485       include 'COMMON.CONTACTS'
2486       include 'COMMON.TORSION'
2487       include 'COMMON.VECTORS'
2488       include 'COMMON.FFIELD'
2489       double precision auxvec(2),auxmat(2,2)
2490 C
2491 C Compute the virtual-bond-torsional-angle dependent quantities needed
2492 C to calculate the el-loc multibody terms of various order.
2493 C
2494 #ifdef PARMAT
2495       do i=ivec_start+2,ivec_end+2
2496 #else
2497       do i=3,nres+1
2498 #endif
2499         if (i .lt. nres+1) then
2500           sin1=dsin(phi(i))
2501           cos1=dcos(phi(i))
2502           sintab(i-2)=sin1
2503           costab(i-2)=cos1
2504           obrot(1,i-2)=cos1
2505           obrot(2,i-2)=sin1
2506           sin2=dsin(2*phi(i))
2507           cos2=dcos(2*phi(i))
2508           sintab2(i-2)=sin2
2509           costab2(i-2)=cos2
2510           obrot2(1,i-2)=cos2
2511           obrot2(2,i-2)=sin2
2512           Ug(1,1,i-2)=-cos1
2513           Ug(1,2,i-2)=-sin1
2514           Ug(2,1,i-2)=-sin1
2515           Ug(2,2,i-2)= cos1
2516           Ug2(1,1,i-2)=-cos2
2517           Ug2(1,2,i-2)=-sin2
2518           Ug2(2,1,i-2)=-sin2
2519           Ug2(2,2,i-2)= cos2
2520         else
2521           costab(i-2)=1.0d0
2522           sintab(i-2)=0.0d0
2523           obrot(1,i-2)=1.0d0
2524           obrot(2,i-2)=0.0d0
2525           obrot2(1,i-2)=0.0d0
2526           obrot2(2,i-2)=0.0d0
2527           Ug(1,1,i-2)=1.0d0
2528           Ug(1,2,i-2)=0.0d0
2529           Ug(2,1,i-2)=0.0d0
2530           Ug(2,2,i-2)=1.0d0
2531           Ug2(1,1,i-2)=0.0d0
2532           Ug2(1,2,i-2)=0.0d0
2533           Ug2(2,1,i-2)=0.0d0
2534           Ug2(2,2,i-2)=0.0d0
2535         endif
2536         if (i .gt. 3 .and. i .lt. nres+1) then
2537           obrot_der(1,i-2)=-sin1
2538           obrot_der(2,i-2)= cos1
2539           Ugder(1,1,i-2)= sin1
2540           Ugder(1,2,i-2)=-cos1
2541           Ugder(2,1,i-2)=-cos1
2542           Ugder(2,2,i-2)=-sin1
2543           dwacos2=cos2+cos2
2544           dwasin2=sin2+sin2
2545           obrot2_der(1,i-2)=-dwasin2
2546           obrot2_der(2,i-2)= dwacos2
2547           Ug2der(1,1,i-2)= dwasin2
2548           Ug2der(1,2,i-2)=-dwacos2
2549           Ug2der(2,1,i-2)=-dwacos2
2550           Ug2der(2,2,i-2)=-dwasin2
2551         else
2552           obrot_der(1,i-2)=0.0d0
2553           obrot_der(2,i-2)=0.0d0
2554           Ugder(1,1,i-2)=0.0d0
2555           Ugder(1,2,i-2)=0.0d0
2556           Ugder(2,1,i-2)=0.0d0
2557           Ugder(2,2,i-2)=0.0d0
2558           obrot2_der(1,i-2)=0.0d0
2559           obrot2_der(2,i-2)=0.0d0
2560           Ug2der(1,1,i-2)=0.0d0
2561           Ug2der(1,2,i-2)=0.0d0
2562           Ug2der(2,1,i-2)=0.0d0
2563           Ug2der(2,2,i-2)=0.0d0
2564         endif
2565 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2566         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2567           iti = itortyp(itype(i-2))
2568         else
2569           iti=ntortyp+1
2570         endif
2571 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2572         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2573           iti1 = itortyp(itype(i-1))
2574         else
2575           iti1=ntortyp+1
2576         endif
2577 cd        write (iout,*) '*******i',i,' iti1',iti
2578 cd        write (iout,*) 'b1',b1(:,iti)
2579 cd        write (iout,*) 'b2',b2(:,iti)
2580 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2581 c        if (i .gt. iatel_s+2) then
2582         if (i .gt. nnt+2) then
2583           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2584           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2585           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2586      &    then
2587           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2588           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2589           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2590           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2591           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2592           endif
2593         else
2594           do k=1,2
2595             Ub2(k,i-2)=0.0d0
2596             Ctobr(k,i-2)=0.0d0
2597             Dtobr2(k,i-2)=0.0d0
2598             do l=1,2
2599               EUg(l,k,i-2)=0.0d0
2600               CUg(l,k,i-2)=0.0d0
2601               DUg(l,k,i-2)=0.0d0
2602               DtUg2(l,k,i-2)=0.0d0
2603             enddo
2604           enddo
2605         endif
2606         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2607         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2608         do k=1,2
2609           muder(k,i-2)=Ub2der(k,i-2)
2610         enddo
2611 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2612         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2613           iti1 = itortyp(itype(i-1))
2614         else
2615           iti1=ntortyp+1
2616         endif
2617         do k=1,2
2618           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2619         enddo
2620 cd        write (iout,*) 'mu ',mu(:,i-2)
2621 cd        write (iout,*) 'mu1',mu1(:,i-2)
2622 cd        write (iout,*) 'mu2',mu2(:,i-2)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2624      &  then
2625         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2626         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2627         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2628         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2629         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2630 C Vectors and matrices dependent on a single virtual-bond dihedral.
2631         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2632         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2633         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2634         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2635         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2636         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2637         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2638         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2639         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2640         endif
2641       enddo
2642 C Matrices dependent on two consecutive virtual-bond dihedrals.
2643 C The order of matrices is from left to right.
2644       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2645      &then
2646 c      do i=max0(ivec_start,2),ivec_end
2647       do i=2,nres-1
2648         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2649         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2650         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2651         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2652         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2653         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2654         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2655         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2656       enddo
2657       endif
2658 #if defined(MPI) && defined(PARMAT)
2659 #ifdef DEBUG
2660 c      if (fg_rank.eq.0) then
2661         write (iout,*) "Arrays UG and UGDER before GATHER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug(l,k,i),l=1,2),k=1,2),
2665      &     ((ugder(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays UG2 and UG2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     ((ug2(l,k,i),l=1,2),k=1,2),
2671      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2677      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2678         enddo
2679         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2680         do i=1,nres-1
2681           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2682      &     costab(i),sintab(i),costab2(i),sintab2(i)
2683         enddo
2684         write (iout,*) "Array MUDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2687         enddo
2688 c      endif
2689 #endif
2690       if (nfgtasks.gt.1) then
2691         time00=MPI_Wtime()
2692 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2693 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2694 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2695 #ifdef MATGATHER
2696         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2706      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2707      &   FG_COMM1,IERR)
2708         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2709      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2710      &   FG_COMM1,IERR)
2711         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2712      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2713      &   FG_COMM1,IERR)
2714         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2715      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2716      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2717         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2718      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2719      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2720         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2721      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2722      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2723         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2724      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2725      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2726         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2727      &  then
2728         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2736      &   FG_COMM1,IERR)
2737        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2744      &   ivec_count(fg_rank1),
2745      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2758      &   FG_COMM1,IERR)
2759         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2769      &   ivec_count(fg_rank1),
2770      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2771      &   FG_COMM1,IERR)
2772         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2774      &   FG_COMM1,IERR)
2775        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2797      &   ivec_count(fg_rank1),
2798      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2799      &   MPI_MAT2,FG_COMM1,IERR)
2800         endif
2801 #else
2802 c Passes matrix info through the ring
2803       isend=fg_rank1
2804       irecv=fg_rank1-1
2805       if (irecv.lt.0) irecv=nfgtasks1-1
2806       iprev=irecv
2807       inext=fg_rank1+1
2808       if (inext.ge.nfgtasks1) inext=0
2809       do i=1,nfgtasks1-1
2810 c        write (iout,*) "isend",isend," irecv",irecv
2811 c        call flush(iout)
2812         lensend=lentyp(isend)
2813         lenrecv=lentyp(irecv)
2814 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2815 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2816 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2817 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2818 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2819 c        write (iout,*) "Gather ROTAT1"
2820 c        call flush(iout)
2821 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2822 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2823 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2824 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2825 c        write (iout,*) "Gather ROTAT2"
2826 c        call flush(iout)
2827         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2828      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2829      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2830      &   iprev,4400+irecv,FG_COMM,status,IERR)
2831 c        write (iout,*) "Gather ROTAT_OLD"
2832 c        call flush(iout)
2833         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2834      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2835      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2836      &   iprev,5500+irecv,FG_COMM,status,IERR)
2837 c        write (iout,*) "Gather PRECOMP11"
2838 c        call flush(iout)
2839         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2840      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2841      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2842      &   iprev,6600+irecv,FG_COMM,status,IERR)
2843 c        write (iout,*) "Gather PRECOMP12"
2844 c        call flush(iout)
2845         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2846      &  then
2847         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2848      &   MPI_ROTAT2(lensend),inext,7700+isend,
2849      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2850      &   iprev,7700+irecv,FG_COMM,status,IERR)
2851 c        write (iout,*) "Gather PRECOMP21"
2852 c        call flush(iout)
2853         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2854      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2855      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2856      &   iprev,8800+irecv,FG_COMM,status,IERR)
2857 c        write (iout,*) "Gather PRECOMP22"
2858 c        call flush(iout)
2859         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2860      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2861      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2862      &   MPI_PRECOMP23(lenrecv),
2863      &   iprev,9900+irecv,FG_COMM,status,IERR)
2864 c        write (iout,*) "Gather PRECOMP23"
2865 c        call flush(iout)
2866         endif
2867         isend=irecv
2868         irecv=irecv-1
2869         if (irecv.lt.0) irecv=nfgtasks1-1
2870       enddo
2871 #endif
2872         time_gather=time_gather+MPI_Wtime()-time00
2873       endif
2874 #ifdef DEBUG
2875 c      if (fg_rank.eq.0) then
2876         write (iout,*) "Arrays UG and UGDER"
2877         do i=1,nres-1
2878           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2879      &     ((ug(l,k,i),l=1,2),k=1,2),
2880      &     ((ugder(l,k,i),l=1,2),k=1,2)
2881         enddo
2882         write (iout,*) "Arrays UG2 and UG2DER"
2883         do i=1,nres-1
2884           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2885      &     ((ug2(l,k,i),l=1,2),k=1,2),
2886      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2887         enddo
2888         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2889         do i=1,nres-1
2890           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2891      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2892      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2893         enddo
2894         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2895         do i=1,nres-1
2896           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2897      &     costab(i),sintab(i),costab2(i),sintab2(i)
2898         enddo
2899         write (iout,*) "Array MUDER"
2900         do i=1,nres-1
2901           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2902         enddo
2903 c      endif
2904 #endif
2905 #endif
2906 cd      do i=1,nres
2907 cd        iti = itortyp(itype(i))
2908 cd        write (iout,*) i
2909 cd        do j=1,2
2910 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2911 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2912 cd        enddo
2913 cd      enddo
2914       return
2915       end
2916 C--------------------------------------------------------------------------
2917       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2918 C
2919 C This subroutine calculates the average interaction energy and its gradient
2920 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2921 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2922 C The potential depends both on the distance of peptide-group centers and on
2923 C the orientation of the CA-CA virtual bonds.
2924 C
2925       implicit real*8 (a-h,o-z)
2926 #ifdef MPI
2927       include 'mpif.h'
2928 #endif
2929       include 'DIMENSIONS'
2930       include 'COMMON.CONTROL'
2931       include 'COMMON.SETUP'
2932       include 'COMMON.IOUNITS'
2933       include 'COMMON.GEO'
2934       include 'COMMON.VAR'
2935       include 'COMMON.LOCAL'
2936       include 'COMMON.CHAIN'
2937       include 'COMMON.DERIV'
2938       include 'COMMON.INTERACT'
2939       include 'COMMON.CONTACTS'
2940       include 'COMMON.TORSION'
2941       include 'COMMON.VECTORS'
2942       include 'COMMON.FFIELD'
2943       include 'COMMON.TIME1'
2944       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2945      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2946       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2947      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2948       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2949      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2950      &    num_conti,j1,j2
2951 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2952 #ifdef MOMENT
2953       double precision scal_el /1.0d0/
2954 #else
2955       double precision scal_el /0.5d0/
2956 #endif
2957 C 12/13/98
2958 C 13-go grudnia roku pamietnego...
2959       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2960      &                   0.0d0,1.0d0,0.0d0,
2961      &                   0.0d0,0.0d0,1.0d0/
2962 cd      write(iout,*) 'In EELEC'
2963 cd      do i=1,nloctyp
2964 cd        write(iout,*) 'Type',i
2965 cd        write(iout,*) 'B1',B1(:,i)
2966 cd        write(iout,*) 'B2',B2(:,i)
2967 cd        write(iout,*) 'CC',CC(:,:,i)
2968 cd        write(iout,*) 'DD',DD(:,:,i)
2969 cd        write(iout,*) 'EE',EE(:,:,i)
2970 cd      enddo
2971 cd      call check_vecgrad
2972 cd      stop
2973       if (icheckgrad.eq.1) then
2974         do i=1,nres-1
2975           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2976           do k=1,3
2977             dc_norm(k,i)=dc(k,i)*fac
2978           enddo
2979 c          write (iout,*) 'i',i,' fac',fac
2980         enddo
2981       endif
2982       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2983      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2984      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2985 c        call vec_and_deriv
2986 #ifdef TIMING
2987         time01=MPI_Wtime()
2988 #endif
2989         call set_matrices
2990 #ifdef TIMING
2991         time_mat=time_mat+MPI_Wtime()-time01
2992 #endif
2993       endif
2994 cd      do i=1,nres-1
2995 cd        write (iout,*) 'i=',i
2996 cd        do k=1,3
2997 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2998 cd        enddo
2999 cd        do k=1,3
3000 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3001 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3002 cd        enddo
3003 cd      enddo
3004       t_eelecij=0.0d0
3005       ees=0.0D0
3006       evdw1=0.0D0
3007       eel_loc=0.0d0
3008       eello_turn3=0.0d0
3009       eello_turn4=0.0d0
3010       ind=0
3011       do i=1,nres
3012         num_cont_hb(i)=0
3013       enddo
3014 cd      print '(a)','Enter EELEC'
3015 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3016       do i=1,nres
3017         gel_loc_loc(i)=0.0d0
3018         gcorr_loc(i)=0.0d0
3019       enddo
3020 c
3021 c
3022 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3023 C
3024 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3025 C
3026       do i=iturn3_start,iturn3_end
3027 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3028 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21)
3029 C     &  cycle
3030         dxi=dc(1,i)
3031         dyi=dc(2,i)
3032         dzi=dc(3,i)
3033         dx_normi=dc_norm(1,i)
3034         dy_normi=dc_norm(2,i)
3035         dz_normi=dc_norm(3,i)
3036         xmedi=c(1,i)+0.5d0*dxi
3037         ymedi=c(2,i)+0.5d0*dyi
3038         zmedi=c(3,i)+0.5d0*dzi
3039         num_conti=0
3040         call eelecij(i,i+2,ees,evdw1,eel_loc)
3041         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3042         num_cont_hb(i)=num_conti
3043       enddo
3044       do i=iturn4_start,iturn4_end
3045 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3046 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21
3047 C     &  .or. itype(i+5).eq.21)
3048 C     & cycle
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058         num_conti=num_cont_hb(i)
3059         call eelecij(i,i+3,ees,evdw1,eel_loc)
3060         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3061         num_cont_hb(i)=num_conti
3062       enddo   ! i
3063 c
3064 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3065 c
3066       do i=iatel_s,iatel_e
3067 C          if (itype(i).eq.21 .or. itype(i+1).eq.21
3068 C     &.or.itype(i+2)) cycle
3069         dxi=dc(1,i)
3070         dyi=dc(2,i)
3071         dzi=dc(3,i)
3072         dx_normi=dc_norm(1,i)
3073         dy_normi=dc_norm(2,i)
3074         dz_normi=dc_norm(3,i)
3075         xmedi=c(1,i)+0.5d0*dxi
3076         ymedi=c(2,i)+0.5d0*dyi
3077         zmedi=c(3,i)+0.5d0*dzi
3078 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3079         num_conti=num_cont_hb(i)
3080         do j=ielstart(i),ielend(i)
3081 C          if (itype(j).eq.21 .or. itype(j+1).eq.21
3082 C     &.or.itype(j+2)) cycle
3083           call eelecij(i,j,ees,evdw1,eel_loc)
3084         enddo ! j
3085         num_cont_hb(i)=num_conti
3086       enddo   ! i
3087 c      write (iout,*) "Number of loop steps in EELEC:",ind
3088 cd      do i=1,nres
3089 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3090 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3091 cd      enddo
3092 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3093 ccc      eel_loc=eel_loc+eello_turn3
3094 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3095       return
3096       end
3097 C-------------------------------------------------------------------------------
3098       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3099       implicit real*8 (a-h,o-z)
3100       include 'DIMENSIONS'
3101 #ifdef MPI
3102       include "mpif.h"
3103 #endif
3104       include 'COMMON.CONTROL'
3105       include 'COMMON.IOUNITS'
3106       include 'COMMON.GEO'
3107       include 'COMMON.VAR'
3108       include 'COMMON.LOCAL'
3109       include 'COMMON.CHAIN'
3110       include 'COMMON.DERIV'
3111       include 'COMMON.INTERACT'
3112       include 'COMMON.CONTACTS'
3113       include 'COMMON.TORSION'
3114       include 'COMMON.VECTORS'
3115       include 'COMMON.FFIELD'
3116       include 'COMMON.TIME1'
3117       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3118      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3119       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3120      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3121       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3122      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3123      &    num_conti,j1,j2
3124 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3125 #ifdef MOMENT
3126       double precision scal_el /1.0d0/
3127 #else
3128       double precision scal_el /0.5d0/
3129 #endif
3130 C 12/13/98
3131 C 13-go grudnia roku pamietnego...
3132       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3133      &                   0.0d0,1.0d0,0.0d0,
3134      &                   0.0d0,0.0d0,1.0d0/
3135 c          time00=MPI_Wtime()
3136 cd      write (iout,*) "eelecij",i,j
3137 c          ind=ind+1
3138           iteli=itel(i)
3139           itelj=itel(j)
3140           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3141           aaa=app(iteli,itelj)
3142           bbb=bpp(iteli,itelj)
3143           ael6i=ael6(iteli,itelj)
3144           ael3i=ael3(iteli,itelj)
3145           dxj=dc(1,j)
3146           dyj=dc(2,j)
3147           dzj=dc(3,j)
3148           dx_normj=dc_norm(1,j)
3149           dy_normj=dc_norm(2,j)
3150           dz_normj=dc_norm(3,j)
3151           xj=c(1,j)+0.5D0*dxj-xmedi
3152           yj=c(2,j)+0.5D0*dyj-ymedi
3153           zj=c(3,j)+0.5D0*dzj-zmedi
3154           rij=xj*xj+yj*yj+zj*zj
3155           rrmij=1.0D0/rij
3156           rij=dsqrt(rij)
3157           rmij=1.0D0/rij
3158           r3ij=rrmij*rmij
3159           r6ij=r3ij*r3ij
3160           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3161           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3162           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3163           fac=cosa-3.0D0*cosb*cosg
3164           ev1=aaa*r6ij*r6ij
3165 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3166           if (j.eq.i+2) ev1=scal_el*ev1
3167           ev2=bbb*r6ij
3168           fac3=ael6i*r6ij
3169           fac4=ael3i*r3ij
3170           evdwij=ev1+ev2
3171           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3172           el2=fac4*fac
3173           eesij=el1+el2
3174 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3175           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3176           ees=ees+eesij
3177           evdw1=evdw1+evdwij
3178 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3179 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3180 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3181 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3182
3183           if (energy_dec) then
3184               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3185               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3186           endif
3187
3188 C
3189 C Calculate contributions to the Cartesian gradient.
3190 C
3191 #ifdef SPLITELE
3192           facvdw=-6*rrmij*(ev1+evdwij)
3193           facel=-3*rrmij*(el1+eesij)
3194           fac1=fac
3195           erij(1)=xj*rmij
3196           erij(2)=yj*rmij
3197           erij(3)=zj*rmij
3198 *
3199 * Radial derivatives. First process both termini of the fragment (i,j)
3200 *
3201           ggg(1)=facel*xj
3202           ggg(2)=facel*yj
3203           ggg(3)=facel*zj
3204 c          do k=1,3
3205 c            ghalf=0.5D0*ggg(k)
3206 c            gelc(k,i)=gelc(k,i)+ghalf
3207 c            gelc(k,j)=gelc(k,j)+ghalf
3208 c          enddo
3209 c 9/28/08 AL Gradient compotents will be summed only at the end
3210           do k=1,3
3211             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3212             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3213           enddo
3214 *
3215 * Loop over residues i+1 thru j-1.
3216 *
3217 cgrad          do k=i+1,j-1
3218 cgrad            do l=1,3
3219 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3220 cgrad            enddo
3221 cgrad          enddo
3222           ggg(1)=facvdw*xj
3223           ggg(2)=facvdw*yj
3224           ggg(3)=facvdw*zj
3225 c          do k=1,3
3226 c            ghalf=0.5D0*ggg(k)
3227 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3228 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3229 c          enddo
3230 c 9/28/08 AL Gradient compotents will be summed only at the end
3231           do k=1,3
3232             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3233             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3234           enddo
3235 *
3236 * Loop over residues i+1 thru j-1.
3237 *
3238 cgrad          do k=i+1,j-1
3239 cgrad            do l=1,3
3240 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3241 cgrad            enddo
3242 cgrad          enddo
3243 #else
3244           facvdw=ev1+evdwij
3245           facel=el1+eesij
3246           fac1=fac
3247           fac=-3*rrmij*(facvdw+facvdw+facel)
3248           erij(1)=xj*rmij
3249           erij(2)=yj*rmij
3250           erij(3)=zj*rmij
3251 *
3252 * Radial derivatives. First process both termini of the fragment (i,j)
3253 *
3254           ggg(1)=fac*xj
3255           ggg(2)=fac*yj
3256           ggg(3)=fac*zj
3257 c          do k=1,3
3258 c            ghalf=0.5D0*ggg(k)
3259 c            gelc(k,i)=gelc(k,i)+ghalf
3260 c            gelc(k,j)=gelc(k,j)+ghalf
3261 c          enddo
3262 c 9/28/08 AL Gradient compotents will be summed only at the end
3263           do k=1,3
3264             gelc_long(k,j)=gelc(k,j)+ggg(k)
3265             gelc_long(k,i)=gelc(k,i)-ggg(k)
3266           enddo
3267 *
3268 * Loop over residues i+1 thru j-1.
3269 *
3270 cgrad          do k=i+1,j-1
3271 cgrad            do l=1,3
3272 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3273 cgrad            enddo
3274 cgrad          enddo
3275 c 9/28/08 AL Gradient compotents will be summed only at the end
3276           ggg(1)=facvdw*xj
3277           ggg(2)=facvdw*yj
3278           ggg(3)=facvdw*zj
3279           do k=1,3
3280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3281             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3282           enddo
3283 #endif
3284 *
3285 * Angular part
3286 *
3287           ecosa=2.0D0*fac3*fac1+fac4
3288           fac4=-3.0D0*fac4
3289           fac3=-6.0D0*fac3
3290           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3291           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3292           do k=1,3
3293             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3294             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3295           enddo
3296 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3297 cd   &          (dcosg(k),k=1,3)
3298           do k=1,3
3299             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3300           enddo
3301 c          do k=1,3
3302 c            ghalf=0.5D0*ggg(k)
3303 c            gelc(k,i)=gelc(k,i)+ghalf
3304 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3305 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3306 c            gelc(k,j)=gelc(k,j)+ghalf
3307 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3308 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3309 c          enddo
3310 cgrad          do k=i+1,j-1
3311 cgrad            do l=1,3
3312 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3313 cgrad            enddo
3314 cgrad          enddo
3315           do k=1,3
3316             gelc(k,i)=gelc(k,i)
3317      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3318      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3319             gelc(k,j)=gelc(k,j)
3320      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3321      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3322             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3323             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3324           enddo
3325           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3326      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3327      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3328 C
3329 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3330 C   energy of a peptide unit is assumed in the form of a second-order
3331 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3332 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3333 C   are computed for EVERY pair of non-contiguous peptide groups.
3334 C
3335           if (j.lt.nres-1) then
3336             j1=j+1
3337             j2=j-1
3338           else
3339             j1=j-1
3340             j2=j-2
3341           endif
3342           kkk=0
3343           do k=1,2
3344             do l=1,2
3345               kkk=kkk+1
3346               muij(kkk)=mu(k,i)*mu(l,j)
3347             enddo
3348           enddo
3349 cd         write (iout,*) 'EELEC: i',i,' j',j
3350 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3351 cd          write(iout,*) 'muij',muij
3352           ury=scalar(uy(1,i),erij)
3353           urz=scalar(uz(1,i),erij)
3354           vry=scalar(uy(1,j),erij)
3355           vrz=scalar(uz(1,j),erij)
3356           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3357           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3358           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3359           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3360           fac=dsqrt(-ael6i)*r3ij
3361           a22=a22*fac
3362           a23=a23*fac
3363           a32=a32*fac
3364           a33=a33*fac
3365 cd          write (iout,'(4i5,4f10.5)')
3366 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3367 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3368 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3369 cd     &      uy(:,j),uz(:,j)
3370 cd          write (iout,'(4f10.5)')
3371 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3372 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3373 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3374 cd           write (iout,'(9f10.5/)')
3375 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3376 C Derivatives of the elements of A in virtual-bond vectors
3377           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3378           do k=1,3
3379             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3380             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3381             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3382             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3383             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3384             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3385             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3386             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3387             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3388             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3389             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3390             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3391           enddo
3392 C Compute radial contributions to the gradient
3393           facr=-3.0d0*rrmij
3394           a22der=a22*facr
3395           a23der=a23*facr
3396           a32der=a32*facr
3397           a33der=a33*facr
3398           agg(1,1)=a22der*xj
3399           agg(2,1)=a22der*yj
3400           agg(3,1)=a22der*zj
3401           agg(1,2)=a23der*xj
3402           agg(2,2)=a23der*yj
3403           agg(3,2)=a23der*zj
3404           agg(1,3)=a32der*xj
3405           agg(2,3)=a32der*yj
3406           agg(3,3)=a32der*zj
3407           agg(1,4)=a33der*xj
3408           agg(2,4)=a33der*yj
3409           agg(3,4)=a33der*zj
3410 C Add the contributions coming from er
3411           fac3=-3.0d0*fac
3412           do k=1,3
3413             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3414             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3415             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3416             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3417           enddo
3418           do k=1,3
3419 C Derivatives in DC(i)
3420 cgrad            ghalf1=0.5d0*agg(k,1)
3421 cgrad            ghalf2=0.5d0*agg(k,2)
3422 cgrad            ghalf3=0.5d0*agg(k,3)
3423 cgrad            ghalf4=0.5d0*agg(k,4)
3424             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3425      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3426             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3427      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3428             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3429      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3430             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3431      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3432 C Derivatives in DC(i+1)
3433             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3434      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3435             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3436      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3437             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3438      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3439             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3440      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3441 C Derivatives in DC(j)
3442             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3443      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3444             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3445      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3446             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3447      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3448             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3449      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3450 C Derivatives in DC(j+1) or DC(nres-1)
3451             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3452      &      -3.0d0*vryg(k,3)*ury)
3453             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3454      &      -3.0d0*vrzg(k,3)*ury)
3455             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3456      &      -3.0d0*vryg(k,3)*urz)
3457             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3458      &      -3.0d0*vrzg(k,3)*urz)
3459 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3460 cgrad              do l=1,4
3461 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3462 cgrad              enddo
3463 cgrad            endif
3464           enddo
3465           acipa(1,1)=a22
3466           acipa(1,2)=a23
3467           acipa(2,1)=a32
3468           acipa(2,2)=a33
3469           a22=-a22
3470           a23=-a23
3471           do l=1,2
3472             do k=1,3
3473               agg(k,l)=-agg(k,l)
3474               aggi(k,l)=-aggi(k,l)
3475               aggi1(k,l)=-aggi1(k,l)
3476               aggj(k,l)=-aggj(k,l)
3477               aggj1(k,l)=-aggj1(k,l)
3478             enddo
3479           enddo
3480           if (j.lt.nres-1) then
3481             a22=-a22
3482             a32=-a32
3483             do l=1,3,2
3484               do k=1,3
3485                 agg(k,l)=-agg(k,l)
3486                 aggi(k,l)=-aggi(k,l)
3487                 aggi1(k,l)=-aggi1(k,l)
3488                 aggj(k,l)=-aggj(k,l)
3489                 aggj1(k,l)=-aggj1(k,l)
3490               enddo
3491             enddo
3492           else
3493             a22=-a22
3494             a23=-a23
3495             a32=-a32
3496             a33=-a33
3497             do l=1,4
3498               do k=1,3
3499                 agg(k,l)=-agg(k,l)
3500                 aggi(k,l)=-aggi(k,l)
3501                 aggi1(k,l)=-aggi1(k,l)
3502                 aggj(k,l)=-aggj(k,l)
3503                 aggj1(k,l)=-aggj1(k,l)
3504               enddo
3505             enddo
3506           endif
3507           ENDIF ! WCORR
3508           IF (wel_loc.gt.0.0d0) THEN
3509 C Contribution to the local-electrostatic energy coming from the i-j pair
3510           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3511      &     +a33*muij(4)
3512 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3513
3514           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3515      &            'eelloc',i,j,eel_loc_ij
3516
3517           eel_loc=eel_loc+eel_loc_ij
3518 C Partial derivatives in virtual-bond dihedral angles gamma
3519           if (i.gt.1)
3520      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3521      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3522      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3523           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3524      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3525      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3526 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3527           do l=1,3
3528             ggg(l)=agg(l,1)*muij(1)+
3529      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3530             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3531             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3532 cgrad            ghalf=0.5d0*ggg(l)
3533 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3534 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3535           enddo
3536 cgrad          do k=i+1,j2
3537 cgrad            do l=1,3
3538 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3539 cgrad            enddo
3540 cgrad          enddo
3541 C Remaining derivatives of eello
3542           do l=1,3
3543             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3544      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3545             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3546      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3547             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3548      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3549             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3550      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3551           enddo
3552           ENDIF
3553 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3554 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3555           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3556      &       .and. num_conti.le.maxconts) then
3557 c            write (iout,*) i,j," entered corr"
3558 C
3559 C Calculate the contact function. The ith column of the array JCONT will
3560 C contain the numbers of atoms that make contacts with the atom I (of numbers
3561 C greater than I). The arrays FACONT and GACONT will contain the values of
3562 C the contact function and its derivative.
3563 c           r0ij=1.02D0*rpp(iteli,itelj)
3564 c           r0ij=1.11D0*rpp(iteli,itelj)
3565             r0ij=2.20D0*rpp(iteli,itelj)
3566 c           r0ij=1.55D0*rpp(iteli,itelj)
3567             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3568             if (fcont.gt.0.0D0) then
3569               num_conti=num_conti+1
3570               if (num_conti.gt.maxconts) then
3571                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3572      &                         ' will skip next contacts for this conf.'
3573               else
3574                 jcont_hb(num_conti,i)=j
3575 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3576 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3577                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3578      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3579 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3580 C  terms.
3581                 d_cont(num_conti,i)=rij
3582 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3583 C     --- Electrostatic-interaction matrix ---
3584                 a_chuj(1,1,num_conti,i)=a22
3585                 a_chuj(1,2,num_conti,i)=a23
3586                 a_chuj(2,1,num_conti,i)=a32
3587                 a_chuj(2,2,num_conti,i)=a33
3588 C     --- Gradient of rij
3589                 do kkk=1,3
3590                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3591                 enddo
3592                 kkll=0
3593                 do k=1,2
3594                   do l=1,2
3595                     kkll=kkll+1
3596                     do m=1,3
3597                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3598                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3599                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3600                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3601                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3602                     enddo
3603                   enddo
3604                 enddo
3605                 ENDIF
3606                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3607 C Calculate contact energies
3608                 cosa4=4.0D0*cosa
3609                 wij=cosa-3.0D0*cosb*cosg
3610                 cosbg1=cosb+cosg
3611                 cosbg2=cosb-cosg
3612 c               fac3=dsqrt(-ael6i)/r0ij**3
3613                 fac3=dsqrt(-ael6i)*r3ij
3614 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3615                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3616                 if (ees0tmp.gt.0) then
3617                   ees0pij=dsqrt(ees0tmp)
3618                 else
3619                   ees0pij=0
3620                 endif
3621 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3622                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3623                 if (ees0tmp.gt.0) then
3624                   ees0mij=dsqrt(ees0tmp)
3625                 else
3626                   ees0mij=0
3627                 endif
3628 c               ees0mij=0.0D0
3629                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3630                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3631 C Diagnostics. Comment out or remove after debugging!
3632 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3633 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3634 c               ees0m(num_conti,i)=0.0D0
3635 C End diagnostics.
3636 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3637 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3638 C Angular derivatives of the contact function
3639                 ees0pij1=fac3/ees0pij
3640                 ees0mij1=fac3/ees0mij
3641                 fac3p=-3.0D0*fac3*rrmij
3642                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3643                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3644 c               ees0mij1=0.0D0
3645                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3646                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3647                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3648                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3649                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3650                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3651                 ecosap=ecosa1+ecosa2
3652                 ecosbp=ecosb1+ecosb2
3653                 ecosgp=ecosg1+ecosg2
3654                 ecosam=ecosa1-ecosa2
3655                 ecosbm=ecosb1-ecosb2
3656                 ecosgm=ecosg1-ecosg2
3657 C Diagnostics
3658 c               ecosap=ecosa1
3659 c               ecosbp=ecosb1
3660 c               ecosgp=ecosg1
3661 c               ecosam=0.0D0
3662 c               ecosbm=0.0D0
3663 c               ecosgm=0.0D0
3664 C End diagnostics
3665                 facont_hb(num_conti,i)=fcont
3666                 fprimcont=fprimcont/rij
3667 cd              facont_hb(num_conti,i)=1.0D0
3668 C Following line is for diagnostics.
3669 cd              fprimcont=0.0D0
3670                 do k=1,3
3671                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3672                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3673                 enddo
3674                 do k=1,3
3675                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3676                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3677                 enddo
3678                 gggp(1)=gggp(1)+ees0pijp*xj
3679                 gggp(2)=gggp(2)+ees0pijp*yj
3680                 gggp(3)=gggp(3)+ees0pijp*zj
3681                 gggm(1)=gggm(1)+ees0mijp*xj
3682                 gggm(2)=gggm(2)+ees0mijp*yj
3683                 gggm(3)=gggm(3)+ees0mijp*zj
3684 C Derivatives due to the contact function
3685                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3686                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3687                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3688                 do k=1,3
3689 c
3690 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3691 c          following the change of gradient-summation algorithm.
3692 c
3693 cgrad                  ghalfp=0.5D0*gggp(k)
3694 cgrad                  ghalfm=0.5D0*gggm(k)
3695                   gacontp_hb1(k,num_conti,i)=!ghalfp
3696      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3697      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3698                   gacontp_hb2(k,num_conti,i)=!ghalfp
3699      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3700      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3701                   gacontp_hb3(k,num_conti,i)=gggp(k)
3702                   gacontm_hb1(k,num_conti,i)=!ghalfm
3703      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3704      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3705                   gacontm_hb2(k,num_conti,i)=!ghalfm
3706      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3707      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3708                   gacontm_hb3(k,num_conti,i)=gggm(k)
3709                 enddo
3710 C Diagnostics. Comment out or remove after debugging!
3711 cdiag           do k=1,3
3712 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3713 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3714 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3715 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3716 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3717 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3718 cdiag           enddo
3719               ENDIF ! wcorr
3720               endif  ! num_conti.le.maxconts
3721             endif  ! fcont.gt.0
3722           endif    ! j.gt.i+1
3723           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3724             do k=1,4
3725               do l=1,3
3726                 ghalf=0.5d0*agg(l,k)
3727                 aggi(l,k)=aggi(l,k)+ghalf
3728                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3729                 aggj(l,k)=aggj(l,k)+ghalf
3730               enddo
3731             enddo
3732             if (j.eq.nres-1 .and. i.lt.j-2) then
3733               do k=1,4
3734                 do l=1,3
3735                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3736                 enddo
3737               enddo
3738             endif
3739           endif
3740 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3741       return
3742       end
3743 C-----------------------------------------------------------------------------
3744       subroutine eturn3(i,eello_turn3)
3745 C Third- and fourth-order contributions from turns
3746       implicit real*8 (a-h,o-z)
3747       include 'DIMENSIONS'
3748       include 'COMMON.IOUNITS'
3749       include 'COMMON.GEO'
3750       include 'COMMON.VAR'
3751       include 'COMMON.LOCAL'
3752       include 'COMMON.CHAIN'
3753       include 'COMMON.DERIV'
3754       include 'COMMON.INTERACT'
3755       include 'COMMON.CONTACTS'
3756       include 'COMMON.TORSION'
3757       include 'COMMON.VECTORS'
3758       include 'COMMON.FFIELD'
3759       include 'COMMON.CONTROL'
3760       dimension ggg(3)
3761       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3762      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3763      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3764       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3765      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3766       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3767      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3768      &    num_conti,j1,j2
3769       j=i+2
3770 c      write (iout,*) "eturn3",i,j,j1,j2
3771       a_temp(1,1)=a22
3772       a_temp(1,2)=a23
3773       a_temp(2,1)=a32
3774       a_temp(2,2)=a33
3775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3776 C
3777 C               Third-order contributions
3778 C
3779 C                 (i+2)o----(i+3)
3780 C                      | |
3781 C                      | |
3782 C                 (i+1)o----i
3783 C
3784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3785 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3786         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3787         call transpose2(auxmat(1,1),auxmat1(1,1))
3788         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3789         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3790         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3791      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3792 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3793 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3794 cd     &    ' eello_turn3_num',4*eello_turn3_num
3795 C Derivatives in gamma(i)
3796         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3797         call transpose2(auxmat2(1,1),auxmat3(1,1))
3798         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3799         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3800 C Derivatives in gamma(i+1)
3801         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3802         call transpose2(auxmat2(1,1),auxmat3(1,1))
3803         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3804         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3805      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3806 C Cartesian derivatives
3807         do l=1,3
3808 c            ghalf1=0.5d0*agg(l,1)
3809 c            ghalf2=0.5d0*agg(l,2)
3810 c            ghalf3=0.5d0*agg(l,3)
3811 c            ghalf4=0.5d0*agg(l,4)
3812           a_temp(1,1)=aggi(l,1)!+ghalf1
3813           a_temp(1,2)=aggi(l,2)!+ghalf2
3814           a_temp(2,1)=aggi(l,3)!+ghalf3
3815           a_temp(2,2)=aggi(l,4)!+ghalf4
3816           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3817           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3818      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3819           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3820           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3821           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3822           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3824           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3825      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3826           a_temp(1,1)=aggj(l,1)!+ghalf1
3827           a_temp(1,2)=aggj(l,2)!+ghalf2
3828           a_temp(2,1)=aggj(l,3)!+ghalf3
3829           a_temp(2,2)=aggj(l,4)!+ghalf4
3830           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3831           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3832      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3833           a_temp(1,1)=aggj1(l,1)
3834           a_temp(1,2)=aggj1(l,2)
3835           a_temp(2,1)=aggj1(l,3)
3836           a_temp(2,2)=aggj1(l,4)
3837           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3838           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3839      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3840         enddo
3841       return
3842       end
3843 C-------------------------------------------------------------------------------
3844       subroutine eturn4(i,eello_turn4)
3845 C Third- and fourth-order contributions from turns
3846       implicit real*8 (a-h,o-z)
3847       include 'DIMENSIONS'
3848       include 'COMMON.IOUNITS'
3849       include 'COMMON.GEO'
3850       include 'COMMON.VAR'
3851       include 'COMMON.LOCAL'
3852       include 'COMMON.CHAIN'
3853       include 'COMMON.DERIV'
3854       include 'COMMON.INTERACT'
3855       include 'COMMON.CONTACTS'
3856       include 'COMMON.TORSION'
3857       include 'COMMON.VECTORS'
3858       include 'COMMON.FFIELD'
3859       include 'COMMON.CONTROL'
3860       dimension ggg(3)
3861       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3862      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3863      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3864       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3865      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3866       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3867      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3868      &    num_conti,j1,j2
3869       j=i+3
3870 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3871 C
3872 C               Fourth-order contributions
3873 C
3874 C                 (i+3)o----(i+4)
3875 C                     /  |
3876 C               (i+2)o   |
3877 C                     \  |
3878 C                 (i+1)o----i
3879 C
3880 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3881 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3882 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3883         a_temp(1,1)=a22
3884         a_temp(1,2)=a23
3885         a_temp(2,1)=a32
3886         a_temp(2,2)=a33
3887         iti1=itortyp(itype(i+1))
3888         iti2=itortyp(itype(i+2))
3889         iti3=itortyp(itype(i+3))
3890 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3891         call transpose2(EUg(1,1,i+1),e1t(1,1))
3892         call transpose2(Eug(1,1,i+2),e2t(1,1))
3893         call transpose2(Eug(1,1,i+3),e3t(1,1))
3894         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896         s1=scalar2(b1(1,iti2),auxvec(1))
3897         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899         s2=scalar2(b1(1,iti1),auxvec(1))
3900         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903         eello_turn4=eello_turn4-(s1+s2+s3)
3904         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3905      &      'eturn4',i,j,-(s1+s2+s3)
3906 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3907 cd     &    ' eello_turn4_num',8*eello_turn4_num
3908 C Derivatives in gamma(i)
3909         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3910         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3911         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3912         s1=scalar2(b1(1,iti2),auxvec(1))
3913         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3914         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3915         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3916 C Derivatives in gamma(i+1)
3917         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3918         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3919         s2=scalar2(b1(1,iti1),auxvec(1))
3920         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3921         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3922         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3923         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3924 C Derivatives in gamma(i+2)
3925         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3926         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3927         s1=scalar2(b1(1,iti2),auxvec(1))
3928         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3929         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3930         s2=scalar2(b1(1,iti1),auxvec(1))
3931         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3932         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3933         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3934         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3935 C Cartesian derivatives
3936 C Derivatives of this turn contributions in DC(i+2)
3937         if (j.lt.nres-1) then
3938           do l=1,3
3939             a_temp(1,1)=agg(l,1)
3940             a_temp(1,2)=agg(l,2)
3941             a_temp(2,1)=agg(l,3)
3942             a_temp(2,2)=agg(l,4)
3943             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3944             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3945             s1=scalar2(b1(1,iti2),auxvec(1))
3946             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3947             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3948             s2=scalar2(b1(1,iti1),auxvec(1))
3949             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3950             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3951             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3952             ggg(l)=-(s1+s2+s3)
3953             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3954           enddo
3955         endif
3956 C Remaining derivatives of this turn contribution
3957         do l=1,3
3958           a_temp(1,1)=aggi(l,1)
3959           a_temp(1,2)=aggi(l,2)
3960           a_temp(2,1)=aggi(l,3)
3961           a_temp(2,2)=aggi(l,4)
3962           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3963           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3964           s1=scalar2(b1(1,iti2),auxvec(1))
3965           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3966           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3967           s2=scalar2(b1(1,iti1),auxvec(1))
3968           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3969           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3970           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3971           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3972           a_temp(1,1)=aggi1(l,1)
3973           a_temp(1,2)=aggi1(l,2)
3974           a_temp(2,1)=aggi1(l,3)
3975           a_temp(2,2)=aggi1(l,4)
3976           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3977           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3978           s1=scalar2(b1(1,iti2),auxvec(1))
3979           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3980           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3981           s2=scalar2(b1(1,iti1),auxvec(1))
3982           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3983           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3984           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3986           a_temp(1,1)=aggj(l,1)
3987           a_temp(1,2)=aggj(l,2)
3988           a_temp(2,1)=aggj(l,3)
3989           a_temp(2,2)=aggj(l,4)
3990           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3991           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3992           s1=scalar2(b1(1,iti2),auxvec(1))
3993           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3994           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3995           s2=scalar2(b1(1,iti1),auxvec(1))
3996           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3997           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3998           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3999           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4000           a_temp(1,1)=aggj1(l,1)
4001           a_temp(1,2)=aggj1(l,2)
4002           a_temp(2,1)=aggj1(l,3)
4003           a_temp(2,2)=aggj1(l,4)
4004           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4005           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4006           s1=scalar2(b1(1,iti2),auxvec(1))
4007           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4008           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4009           s2=scalar2(b1(1,iti1),auxvec(1))
4010           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4011           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4012           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4013 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4014           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4015         enddo
4016       return
4017       end
4018 C-----------------------------------------------------------------------------
4019       subroutine vecpr(u,v,w)
4020       implicit real*8(a-h,o-z)
4021       dimension u(3),v(3),w(3)
4022       w(1)=u(2)*v(3)-u(3)*v(2)
4023       w(2)=-u(1)*v(3)+u(3)*v(1)
4024       w(3)=u(1)*v(2)-u(2)*v(1)
4025       return
4026       end
4027 C-----------------------------------------------------------------------------
4028       subroutine unormderiv(u,ugrad,unorm,ungrad)
4029 C This subroutine computes the derivatives of a normalized vector u, given
4030 C the derivatives computed without normalization conditions, ugrad. Returns
4031 C ungrad.
4032       implicit none
4033       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4034       double precision vec(3)
4035       double precision scalar
4036       integer i,j
4037 c      write (2,*) 'ugrad',ugrad
4038 c      write (2,*) 'u',u
4039       do i=1,3
4040         vec(i)=scalar(ugrad(1,i),u(1))
4041       enddo
4042 c      write (2,*) 'vec',vec
4043       do i=1,3
4044         do j=1,3
4045           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4046         enddo
4047       enddo
4048 c      write (2,*) 'ungrad',ungrad
4049       return
4050       end
4051 C-----------------------------------------------------------------------------
4052       subroutine escp_soft_sphere(evdw2,evdw2_14)
4053 C
4054 C This subroutine calculates the excluded-volume interaction energy between
4055 C peptide-group centers and side chains and its gradient in virtual-bond and
4056 C side-chain vectors.
4057 C
4058       implicit real*8 (a-h,o-z)
4059       include 'DIMENSIONS'
4060       include 'COMMON.GEO'
4061       include 'COMMON.VAR'
4062       include 'COMMON.LOCAL'
4063       include 'COMMON.CHAIN'
4064       include 'COMMON.DERIV'
4065       include 'COMMON.INTERACT'
4066       include 'COMMON.FFIELD'
4067       include 'COMMON.IOUNITS'
4068       include 'COMMON.CONTROL'
4069       dimension ggg(3)
4070       evdw2=0.0D0
4071       evdw2_14=0.0d0
4072       r0_scp=4.5d0
4073 cd    print '(a)','Enter ESCP'
4074 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4075       do i=iatscp_s,iatscp_e
4076         iteli=itel(i)
4077         xi=0.5D0*(c(1,i)+c(1,i+1))
4078         yi=0.5D0*(c(2,i)+c(2,i+1))
4079         zi=0.5D0*(c(3,i)+c(3,i+1))
4080
4081         do iint=1,nscp_gr(i)
4082
4083         do j=iscpstart(i,iint),iscpend(i,iint)
4084           itypj=itype(j)
4085 C Uncomment following three lines for SC-p interactions
4086 c         xj=c(1,nres+j)-xi
4087 c         yj=c(2,nres+j)-yi
4088 c         zj=c(3,nres+j)-zi
4089 C Uncomment following three lines for Ca-p interactions
4090           xj=c(1,j)-xi
4091           yj=c(2,j)-yi
4092           zj=c(3,j)-zi
4093           rij=xj*xj+yj*yj+zj*zj
4094           r0ij=r0_scp
4095           r0ijsq=r0ij*r0ij
4096           if (rij.lt.r0ijsq) then
4097             evdwij=0.25d0*(rij-r0ijsq)**2
4098             fac=rij-r0ijsq
4099           else
4100             evdwij=0.0d0
4101             fac=0.0d0
4102           endif
4103           evdw2=evdw2+evdwij
4104 C
4105 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4106 C
4107           ggg(1)=xj*fac
4108           ggg(2)=yj*fac
4109           ggg(3)=zj*fac
4110 cgrad          if (j.lt.i) then
4111 cd          write (iout,*) 'j<i'
4112 C Uncomment following three lines for SC-p interactions
4113 c           do k=1,3
4114 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4115 c           enddo
4116 cgrad          else
4117 cd          write (iout,*) 'j>i'
4118 cgrad            do k=1,3
4119 cgrad              ggg(k)=-ggg(k)
4120 C Uncomment following line for SC-p interactions
4121 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4122 cgrad            enddo
4123 cgrad          endif
4124 cgrad          do k=1,3
4125 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4126 cgrad          enddo
4127 cgrad          kstart=min0(i+1,j)
4128 cgrad          kend=max0(i-1,j-1)
4129 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4130 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4131 cgrad          do k=kstart,kend
4132 cgrad            do l=1,3
4133 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4134 cgrad            enddo
4135 cgrad          enddo
4136           do k=1,3
4137             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4138             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4139           enddo
4140         enddo
4141
4142         enddo ! iint
4143       enddo ! i
4144       return
4145       end
4146 C-----------------------------------------------------------------------------
4147       subroutine escp(evdw2,evdw2_14)
4148 C
4149 C This subroutine calculates the excluded-volume interaction energy between
4150 C peptide-group centers and side chains and its gradient in virtual-bond and
4151 C side-chain vectors.
4152 C
4153       implicit real*8 (a-h,o-z)
4154       include 'DIMENSIONS'
4155       include 'COMMON.GEO'
4156       include 'COMMON.VAR'
4157       include 'COMMON.LOCAL'
4158       include 'COMMON.CHAIN'
4159       include 'COMMON.DERIV'
4160       include 'COMMON.INTERACT'
4161       include 'COMMON.FFIELD'
4162       include 'COMMON.IOUNITS'
4163       include 'COMMON.CONTROL'
4164       dimension ggg(3)
4165       evdw2=0.0D0
4166       evdw2_14=0.0d0
4167 cd    print '(a)','Enter ESCP'
4168 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4169       do i=iatscp_s,iatscp_e
4170         iteli=itel(i)
4171         xi=0.5D0*(c(1,i)+c(1,i+1))
4172         yi=0.5D0*(c(2,i)+c(2,i+1))
4173         zi=0.5D0*(c(3,i)+c(3,i+1))
4174
4175         do iint=1,nscp_gr(i)
4176
4177         do j=iscpstart(i,iint),iscpend(i,iint)
4178           itypj=itype(j)
4179 C Uncomment following three lines for SC-p interactions
4180 c         xj=c(1,nres+j)-xi
4181 c         yj=c(2,nres+j)-yi
4182 c         zj=c(3,nres+j)-zi
4183 C Uncomment following three lines for Ca-p interactions
4184           xj=c(1,j)-xi
4185           yj=c(2,j)-yi
4186           zj=c(3,j)-zi
4187           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4188           fac=rrij**expon2
4189           e1=fac*fac*aad(itypj,iteli)
4190           e2=fac*bad(itypj,iteli)
4191           if (iabs(j-i) .le. 2) then
4192             e1=scal14*e1
4193             e2=scal14*e2
4194             evdw2_14=evdw2_14+e1+e2
4195           endif
4196           evdwij=e1+e2
4197           evdw2=evdw2+evdwij
4198           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4199      &        'evdw2',i,j,evdwij
4200 C
4201 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4202 C
4203           fac=-(evdwij+e1)*rrij
4204           ggg(1)=xj*fac
4205           ggg(2)=yj*fac
4206           ggg(3)=zj*fac
4207 cgrad          if (j.lt.i) then
4208 cd          write (iout,*) 'j<i'
4209 C Uncomment following three lines for SC-p interactions
4210 c           do k=1,3
4211 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4212 c           enddo
4213 cgrad          else
4214 cd          write (iout,*) 'j>i'
4215 cgrad            do k=1,3
4216 cgrad              ggg(k)=-ggg(k)
4217 C Uncomment following line for SC-p interactions
4218 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4219 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4220 cgrad            enddo
4221 cgrad          endif
4222 cgrad          do k=1,3
4223 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4224 cgrad          enddo
4225 cgrad          kstart=min0(i+1,j)
4226 cgrad          kend=max0(i-1,j-1)
4227 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4228 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4229 cgrad          do k=kstart,kend
4230 cgrad            do l=1,3
4231 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4232 cgrad            enddo
4233 cgrad          enddo
4234           do k=1,3
4235             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4236             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4237           enddo
4238         enddo
4239
4240         enddo ! iint
4241       enddo ! i
4242       do i=1,nct
4243         do j=1,3
4244           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4245           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4246           gradx_scp(j,i)=expon*gradx_scp(j,i)
4247         enddo
4248       enddo
4249 C******************************************************************************
4250 C
4251 C                              N O T E !!!
4252 C
4253 C To save time the factor EXPON has been extracted from ALL components
4254 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4255 C use!
4256 C
4257 C******************************************************************************
4258       return
4259       end
4260 C--------------------------------------------------------------------------
4261       subroutine edis(ehpb)
4262 C
4263 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4264 C
4265       implicit real*8 (a-h,o-z)
4266       include 'DIMENSIONS'
4267       include 'COMMON.SBRIDGE'
4268       include 'COMMON.CHAIN'
4269       include 'COMMON.DERIV'
4270       include 'COMMON.VAR'
4271       include 'COMMON.INTERACT'
4272       include 'COMMON.IOUNITS'
4273       dimension ggg(3)
4274       ehpb=0.0D0
4275 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4276 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4277       if (link_end.eq.0) return
4278       do i=link_start,link_end
4279 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4280 C CA-CA distance used in regularization of structure.
4281         ii=ihpb(i)
4282         jj=jhpb(i)
4283 C iii and jjj point to the residues for which the distance is assigned.
4284         if (ii.gt.nres) then
4285           iii=ii-nres
4286           jjj=jj-nres
4287         else
4288           iii=ii
4289           jjj=jj
4290         endif
4291 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4292 c     &    dhpb(i),dhpb1(i),forcon(i)
4293 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4294 C    distance and angle dependent SS bond potential.
4295 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4296 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4297         if (.not.dyn_ss .and. i.le.nss) then
4298 C 15/02/13 CC dynamic SSbond - additional check
4299          if (ii.gt.nres
4300      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4301           call ssbond_ene(iii,jjj,eij)
4302           ehpb=ehpb+2*eij
4303          endif
4304 cd          write (iout,*) "eij",eij
4305         else if (ii.gt.nres .and. jj.gt.nres) then
4306 c Restraints from contact prediction
4307           dd=dist(ii,jj)
4308           if (dhpb1(i).gt.0.0d0) then
4309             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4310             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4311 c            write (iout,*) "beta nmr",
4312 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4313           else
4314             dd=dist(ii,jj)
4315             rdis=dd-dhpb(i)
4316 C Get the force constant corresponding to this distance.
4317             waga=forcon(i)
4318 C Calculate the contribution to energy.
4319             ehpb=ehpb+waga*rdis*rdis
4320 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4321 C
4322 C Evaluate gradient.
4323 C
4324             fac=waga*rdis/dd
4325           endif
4326           do j=1,3
4327             ggg(j)=fac*(c(j,jj)-c(j,ii))
4328           enddo
4329           do j=1,3
4330             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4331             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4332           enddo
4333           do k=1,3
4334             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4335             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4336           enddo
4337         else
4338 C Calculate the distance between the two points and its difference from the
4339 C target distance.
4340           dd=dist(ii,jj)
4341           if (dhpb1(i).gt.0.0d0) then
4342             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4343             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4344 c            write (iout,*) "alph nmr",
4345 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4346           else
4347             rdis=dd-dhpb(i)
4348 C Get the force constant corresponding to this distance.
4349             waga=forcon(i)
4350 C Calculate the contribution to energy.
4351             ehpb=ehpb+waga*rdis*rdis
4352 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4353 C
4354 C Evaluate gradient.
4355 C
4356             fac=waga*rdis/dd
4357           endif
4358 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4359 cd   &   ' waga=',waga,' fac=',fac
4360             do j=1,3
4361               ggg(j)=fac*(c(j,jj)-c(j,ii))
4362             enddo
4363 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4364 C If this is a SC-SC distance, we need to calculate the contributions to the
4365 C Cartesian gradient in the SC vectors (ghpbx).
4366           if (iii.lt.ii) then
4367           do j=1,3
4368             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4369             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4370           enddo
4371           endif
4372 cgrad        do j=iii,jjj-1
4373 cgrad          do k=1,3
4374 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4375 cgrad          enddo
4376 cgrad        enddo
4377           do k=1,3
4378             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4379             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4380           enddo
4381         endif
4382       enddo
4383       ehpb=0.5D0*ehpb
4384       return
4385       end
4386 C--------------------------------------------------------------------------
4387       subroutine ssbond_ene(i,j,eij)
4388 C
4389 C Calculate the distance and angle dependent SS-bond potential energy
4390 C using a free-energy function derived based on RHF/6-31G** ab initio
4391 C calculations of diethyl disulfide.
4392 C
4393 C A. Liwo and U. Kozlowska, 11/24/03
4394 C
4395       implicit real*8 (a-h,o-z)
4396       include 'DIMENSIONS'
4397       include 'COMMON.SBRIDGE'
4398       include 'COMMON.CHAIN'
4399       include 'COMMON.DERIV'
4400       include 'COMMON.LOCAL'
4401       include 'COMMON.INTERACT'
4402       include 'COMMON.VAR'
4403       include 'COMMON.IOUNITS'
4404       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4405       itypi=itype(i)
4406       xi=c(1,nres+i)
4407       yi=c(2,nres+i)
4408       zi=c(3,nres+i)
4409       dxi=dc_norm(1,nres+i)
4410       dyi=dc_norm(2,nres+i)
4411       dzi=dc_norm(3,nres+i)
4412 c      dsci_inv=dsc_inv(itypi)
4413       dsci_inv=vbld_inv(nres+i)
4414       itypj=itype(j)
4415 c      dscj_inv=dsc_inv(itypj)
4416       dscj_inv=vbld_inv(nres+j)
4417       xj=c(1,nres+j)-xi
4418       yj=c(2,nres+j)-yi
4419       zj=c(3,nres+j)-zi
4420       dxj=dc_norm(1,nres+j)
4421       dyj=dc_norm(2,nres+j)
4422       dzj=dc_norm(3,nres+j)
4423       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4424       rij=dsqrt(rrij)
4425       erij(1)=xj*rij
4426       erij(2)=yj*rij
4427       erij(3)=zj*rij
4428       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4429       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4430       om12=dxi*dxj+dyi*dyj+dzi*dzj
4431       do k=1,3
4432         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4433         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4434       enddo
4435       rij=1.0d0/rij
4436       deltad=rij-d0cm
4437       deltat1=1.0d0-om1
4438       deltat2=1.0d0+om2
4439       deltat12=om2-om1+2.0d0
4440       cosphi=om12-om1*om2
4441       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4442      &  +akct*deltad*deltat12+ebr
4443      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4444 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4445 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4446 c     &  " deltat12",deltat12," eij",eij
4447       ed=2*akcm*deltad+akct*deltat12
4448       pom1=akct*deltad
4449       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4450       eom1=-2*akth*deltat1-pom1-om2*pom2
4451       eom2= 2*akth*deltat2+pom1-om1*pom2
4452       eom12=pom2
4453       do k=1,3
4454         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4455         ghpbx(k,i)=ghpbx(k,i)-ggk
4456      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4457      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4458         ghpbx(k,j)=ghpbx(k,j)+ggk
4459      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4460      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4461         ghpbc(k,i)=ghpbc(k,i)-ggk
4462         ghpbc(k,j)=ghpbc(k,j)+ggk
4463       enddo
4464 C
4465 C Calculate the components of the gradient in DC and X
4466 C
4467 cgrad      do k=i,j-1
4468 cgrad        do l=1,3
4469 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4470 cgrad        enddo
4471 cgrad      enddo
4472       return
4473       end
4474 C--------------------------------------------------------------------------
4475       subroutine ebond(estr)
4476 c
4477 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4478 c
4479       implicit real*8 (a-h,o-z)
4480       include 'DIMENSIONS'
4481       include 'COMMON.LOCAL'
4482       include 'COMMON.GEO'
4483       include 'COMMON.INTERACT'
4484       include 'COMMON.DERIV'
4485       include 'COMMON.VAR'
4486       include 'COMMON.CHAIN'
4487       include 'COMMON.IOUNITS'
4488       include 'COMMON.NAMES'
4489       include 'COMMON.FFIELD'
4490       include 'COMMON.CONTROL'
4491       include 'COMMON.SETUP'
4492       double precision u(3),ud(3)
4493       estr=0.0d0
4494       do i=ibondp_start,ibondp_end
4495         diff = vbld(i)-vbldp0
4496 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4497         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4498      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4499         estr=estr+diff*diff
4500         do j=1,3
4501           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4502         enddo
4503 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4504       enddo
4505       estr=0.5d0*AKP*estr
4506 c
4507 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4508 c
4509       do i=ibond_start,ibond_end
4510         iti=itype(i)
4511         if (iti.ne.10) then
4512           nbi=nbondterm(iti)
4513           if (nbi.eq.1) then
4514             diff=vbld(i+nres)-vbldsc0(1,iti)
4515 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4516 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4517             if (energy_dec)  then
4518               write (iout,*)
4519      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4520      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4521               call flush(iout)
4522             endif
4523             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4524             do j=1,3
4525               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4526             enddo
4527           else
4528             do j=1,nbi
4529               diff=vbld(i+nres)-vbldsc0(j,iti)
4530               ud(j)=aksc(j,iti)*diff
4531               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4532             enddo
4533             uprod=u(1)
4534             do j=2,nbi
4535               uprod=uprod*u(j)
4536             enddo
4537             usum=0.0d0
4538             usumsqder=0.0d0
4539             do j=1,nbi
4540               uprod1=1.0d0
4541               uprod2=1.0d0
4542               do k=1,nbi
4543                 if (k.ne.j) then
4544                   uprod1=uprod1*u(k)
4545                   uprod2=uprod2*u(k)*u(k)
4546                 endif
4547               enddo
4548               usum=usum+uprod1
4549               usumsqder=usumsqder+ud(j)*uprod2
4550             enddo
4551             estr=estr+uprod/usum
4552             do j=1,3
4553              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4554             enddo
4555           endif
4556         endif
4557       enddo
4558       return
4559       end
4560 #ifdef CRYST_THETA
4561 C--------------------------------------------------------------------------
4562       subroutine ebend(etheta)
4563 C
4564 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4565 C angles gamma and its derivatives in consecutive thetas and gammas.
4566 C
4567       implicit real*8 (a-h,o-z)
4568       include 'DIMENSIONS'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.GEO'
4571       include 'COMMON.INTERACT'
4572       include 'COMMON.DERIV'
4573       include 'COMMON.VAR'
4574       include 'COMMON.CHAIN'
4575       include 'COMMON.IOUNITS'
4576       include 'COMMON.NAMES'
4577       include 'COMMON.FFIELD'
4578       include 'COMMON.CONTROL'
4579       common /calcthet/ term1,term2,termm,diffak,ratak,
4580      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4581      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4582       double precision y(2),z(2)
4583       delta=0.02d0*pi
4584 c      time11=dexp(-2*time)
4585 c      time12=1.0d0
4586       etheta=0.0D0
4587 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4588       do i=ithet_start,ithet_end
4589 C Zero the energy function and its derivative at 0 or pi.
4590         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4591         it=itype(i-1)
4592         if (i.gt.3) then
4593 #ifdef OSF
4594           phii=phi(i)
4595           if (phii.ne.phii) phii=150.0
4596 #else
4597           phii=phi(i)
4598 #endif
4599           y(1)=dcos(phii)
4600           y(2)=dsin(phii)
4601         else
4602           y(1)=0.0D0
4603           y(2)=0.0D0
4604         endif
4605         if (i.lt.nres) then
4606 #ifdef OSF
4607           phii1=phi(i+1)
4608           if (phii1.ne.phii1) phii1=150.0
4609           phii1=pinorm(phii1)
4610           z(1)=cos(phii1)
4611 #else
4612           phii1=phi(i+1)
4613           z(1)=dcos(phii1)
4614 #endif
4615           z(2)=dsin(phii1)
4616         else
4617           z(1)=0.0D0
4618           z(2)=0.0D0
4619         endif
4620 C Calculate the "mean" value of theta from the part of the distribution
4621 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4622 C In following comments this theta will be referred to as t_c.
4623         thet_pred_mean=0.0d0
4624         do k=1,2
4625           athetk=athet(k,it)
4626           bthetk=bthet(k,it)
4627           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4628         enddo
4629         dthett=thet_pred_mean*ssd
4630         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4631 C Derivatives of the "mean" values in gamma1 and gamma2.
4632         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4633         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4634         if (theta(i).gt.pi-delta) then
4635           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4636      &         E_tc0)
4637           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4638           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4639           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4640      &        E_theta)
4641           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4642      &        E_tc)
4643         else if (theta(i).lt.delta) then
4644           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4645           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4646           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4647      &        E_theta)
4648           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4649           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4650      &        E_tc)
4651         else
4652           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4653      &        E_theta,E_tc)
4654         endif
4655         etheta=etheta+ethetai
4656         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4657      &      'ebend',i,ethetai
4658         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4659         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4660         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4661       enddo
4662 C Ufff.... We've done all this!!!
4663       return
4664       end
4665 C---------------------------------------------------------------------------
4666       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4667      &     E_tc)
4668       implicit real*8 (a-h,o-z)
4669       include 'DIMENSIONS'
4670       include 'COMMON.LOCAL'
4671       include 'COMMON.IOUNITS'
4672       common /calcthet/ term1,term2,termm,diffak,ratak,
4673      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4674      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4675 C Calculate the contributions to both Gaussian lobes.
4676 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4677 C The "polynomial part" of the "standard deviation" of this part of
4678 C the distribution.
4679         sig=polthet(3,it)
4680         do j=2,0,-1
4681           sig=sig*thet_pred_mean+polthet(j,it)
4682         enddo
4683 C Derivative of the "interior part" of the "standard deviation of the"
4684 C gamma-dependent Gaussian lobe in t_c.
4685         sigtc=3*polthet(3,it)
4686         do j=2,1,-1
4687           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4688         enddo
4689         sigtc=sig*sigtc
4690 C Set the parameters of both Gaussian lobes of the distribution.
4691 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4692         fac=sig*sig+sigc0(it)
4693         sigcsq=fac+fac
4694         sigc=1.0D0/sigcsq
4695 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4696         sigsqtc=-4.0D0*sigcsq*sigtc
4697 c       print *,i,sig,sigtc,sigsqtc
4698 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4699         sigtc=-sigtc/(fac*fac)
4700 C Following variable is sigma(t_c)**(-2)
4701         sigcsq=sigcsq*sigcsq
4702         sig0i=sig0(it)
4703         sig0inv=1.0D0/sig0i**2
4704         delthec=thetai-thet_pred_mean
4705         delthe0=thetai-theta0i
4706         term1=-0.5D0*sigcsq*delthec*delthec
4707         term2=-0.5D0*sig0inv*delthe0*delthe0
4708 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4709 C NaNs in taking the logarithm. We extract the largest exponent which is added
4710 C to the energy (this being the log of the distribution) at the end of energy
4711 C term evaluation for this virtual-bond angle.
4712         if (term1.gt.term2) then
4713           termm=term1
4714           term2=dexp(term2-termm)
4715           term1=1.0d0
4716         else
4717           termm=term2
4718           term1=dexp(term1-termm)
4719           term2=1.0d0
4720         endif
4721 C The ratio between the gamma-independent and gamma-dependent lobes of
4722 C the distribution is a Gaussian function of thet_pred_mean too.
4723         diffak=gthet(2,it)-thet_pred_mean
4724         ratak=diffak/gthet(3,it)**2
4725         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4726 C Let's differentiate it in thet_pred_mean NOW.
4727         aktc=ak*ratak
4728 C Now put together the distribution terms to make complete distribution.
4729         termexp=term1+ak*term2
4730         termpre=sigc+ak*sig0i
4731 C Contribution of the bending energy from this theta is just the -log of
4732 C the sum of the contributions from the two lobes and the pre-exponential
4733 C factor. Simple enough, isn't it?
4734         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4735 C NOW the derivatives!!!
4736 C 6/6/97 Take into account the deformation.
4737         E_theta=(delthec*sigcsq*term1
4738      &       +ak*delthe0*sig0inv*term2)/termexp
4739         E_tc=((sigtc+aktc*sig0i)/termpre
4740      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4741      &       aktc*term2)/termexp)
4742       return
4743       end
4744 c-----------------------------------------------------------------------------
4745       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4746       implicit real*8 (a-h,o-z)
4747       include 'DIMENSIONS'
4748       include 'COMMON.LOCAL'
4749       include 'COMMON.IOUNITS'
4750       common /calcthet/ term1,term2,termm,diffak,ratak,
4751      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4752      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4753       delthec=thetai-thet_pred_mean
4754       delthe0=thetai-theta0i
4755 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4756       t3 = thetai-thet_pred_mean
4757       t6 = t3**2
4758       t9 = term1
4759       t12 = t3*sigcsq
4760       t14 = t12+t6*sigsqtc
4761       t16 = 1.0d0
4762       t21 = thetai-theta0i
4763       t23 = t21**2
4764       t26 = term2
4765       t27 = t21*t26
4766       t32 = termexp
4767       t40 = t32**2
4768       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4769      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4770      & *(-t12*t9-ak*sig0inv*t27)
4771       return
4772       end
4773 #else
4774 C--------------------------------------------------------------------------
4775       subroutine ebend(etheta)
4776 C
4777 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4778 C angles gamma and its derivatives in consecutive thetas and gammas.
4779 C ab initio-derived potentials from
4780 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4781 C
4782       implicit real*8 (a-h,o-z)
4783       include 'DIMENSIONS'
4784       include 'COMMON.LOCAL'
4785       include 'COMMON.GEO'
4786       include 'COMMON.INTERACT'
4787       include 'COMMON.DERIV'
4788       include 'COMMON.VAR'
4789       include 'COMMON.CHAIN'
4790       include 'COMMON.IOUNITS'
4791       include 'COMMON.NAMES'
4792       include 'COMMON.FFIELD'
4793       include 'COMMON.CONTROL'
4794       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4795      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4796      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4797      & sinph1ph2(maxdouble,maxdouble)
4798       logical lprn /.false./, lprn1 /.false./
4799       etheta=0.0D0
4800       do i=ithet_start,ithet_end
4801         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4802      &(itype(i).eq.ntyp1)) cycle
4803         dethetai=0.0d0
4804         dephii=0.0d0
4805         dephii1=0.0d0
4806         theti2=0.5d0*theta(i)
4807         ityp2=ithetyp(itype(i-1))
4808         do k=1,nntheterm
4809           coskt(k)=dcos(k*theti2)
4810           sinkt(k)=dsin(k*theti2)
4811         enddo
4812 C        if (i.gt.3) then
4813         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4814 #ifdef OSF
4815           phii=phi(i)
4816           if (phii.ne.phii) phii=150.0
4817 #else
4818           phii=phi(i)
4819 #endif
4820           ityp1=ithetyp(itype(i-2))
4821           do k=1,nsingle
4822             cosph1(k)=dcos(k*phii)
4823             sinph1(k)=dsin(k*phii)
4824           enddo
4825         else
4826           phii=0.0d0
4827           ityp1=ithetyp(itype(i-2))
4828           do k=1,nsingle
4829             cosph1(k)=0.0d0
4830             sinph1(k)=0.0d0
4831           enddo
4832         endif
4833         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4834 #ifdef OSF
4835           phii1=phi(i+1)
4836           if (phii1.ne.phii1) phii1=150.0
4837           phii1=pinorm(phii1)
4838 #else
4839           phii1=phi(i+1)
4840 #endif
4841           ityp3=ithetyp(itype(i))
4842           do k=1,nsingle
4843             cosph2(k)=dcos(k*phii1)
4844             sinph2(k)=dsin(k*phii1)
4845           enddo
4846         else
4847           phii1=0.0d0
4848           ityp3=ithetyp(itype(i))
4849           do k=1,nsingle
4850             cosph2(k)=0.0d0
4851             sinph2(k)=0.0d0
4852           enddo
4853         endif
4854         ethetai=aa0thet(ityp1,ityp2,ityp3)
4855         do k=1,ndouble
4856           do l=1,k-1
4857             ccl=cosph1(l)*cosph2(k-l)
4858             ssl=sinph1(l)*sinph2(k-l)
4859             scl=sinph1(l)*cosph2(k-l)
4860             csl=cosph1(l)*sinph2(k-l)
4861             cosph1ph2(l,k)=ccl-ssl
4862             cosph1ph2(k,l)=ccl+ssl
4863             sinph1ph2(l,k)=scl+csl
4864             sinph1ph2(k,l)=scl-csl
4865           enddo
4866         enddo
4867         if (lprn) then
4868         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4869      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4870         write (iout,*) "coskt and sinkt"
4871         do k=1,nntheterm
4872           write (iout,*) k,coskt(k),sinkt(k)
4873         enddo
4874         endif
4875         do k=1,ntheterm
4876           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4877           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4878      &      *coskt(k)
4879           if (lprn)
4880      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4881      &     " ethetai",ethetai
4882         enddo
4883         if (lprn) then
4884         write (iout,*) "cosph and sinph"
4885         do k=1,nsingle
4886           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4887         enddo
4888         write (iout,*) "cosph1ph2 and sinph2ph2"
4889         do k=2,ndouble
4890           do l=1,k-1
4891             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4892      &         sinph1ph2(l,k),sinph1ph2(k,l)
4893           enddo
4894         enddo
4895         write(iout,*) "ethetai",ethetai
4896         endif
4897         do m=1,ntheterm2
4898           do k=1,nsingle
4899             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4900      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4901      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4902      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4903             ethetai=ethetai+sinkt(m)*aux
4904             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4905             dephii=dephii+k*sinkt(m)*(
4906      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4907      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4908             dephii1=dephii1+k*sinkt(m)*(
4909      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4910      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4911             if (lprn)
4912      &      write (iout,*) "m",m," k",k," bbthet",
4913      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4914      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4915      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4916      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4917           enddo
4918         enddo
4919         if (lprn)
4920      &  write(iout,*) "ethetai",ethetai
4921         do m=1,ntheterm3
4922           do k=2,ndouble
4923             do l=1,k-1
4924               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4925      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4926      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4927      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4928               ethetai=ethetai+sinkt(m)*aux
4929               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4930               dephii=dephii+l*sinkt(m)*(
4931      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4932      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4933      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4934      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4935               dephii1=dephii1+(k-l)*sinkt(m)*(
4936      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4937      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4938      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4939      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4940               if (lprn) then
4941               write (iout,*) "m",m," k",k," l",l," ffthet",
4942      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4943      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4944      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4945      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4946               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4947      &            cosph1ph2(k,l)*sinkt(m),
4948      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4949               endif
4950             enddo
4951           enddo
4952         enddo
4953 10      continue
4954         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4955      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4956      &   phii1*rad2deg,ethetai
4957         etheta=etheta+ethetai
4958         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4959      &      'ebend',i,ethetai
4960         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4961         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4962         gloc(nphi+i-2,icg)=wang*dethetai
4963       enddo
4964       return
4965       end
4966 #endif
4967 #ifdef CRYST_SC
4968 c-----------------------------------------------------------------------------
4969       subroutine esc(escloc)
4970 C Calculate the local energy of a side chain and its derivatives in the
4971 C corresponding virtual-bond valence angles THETA and the spherical angles
4972 C ALPHA and OMEGA.
4973       implicit real*8 (a-h,o-z)
4974       include 'DIMENSIONS'
4975       include 'COMMON.GEO'
4976       include 'COMMON.LOCAL'
4977       include 'COMMON.VAR'
4978       include 'COMMON.INTERACT'
4979       include 'COMMON.DERIV'
4980       include 'COMMON.CHAIN'
4981       include 'COMMON.IOUNITS'
4982       include 'COMMON.NAMES'
4983       include 'COMMON.FFIELD'
4984       include 'COMMON.CONTROL'
4985       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4986      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4987       common /sccalc/ time11,time12,time112,theti,it,nlobit
4988       delta=0.02d0*pi
4989       escloc=0.0D0
4990 c     write (iout,'(a)') 'ESC'
4991       do i=loc_start,loc_end
4992         it=itype(i)
4993         if (it.eq.10) goto 1
4994         nlobit=nlob(it)
4995 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4996 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4997         theti=theta(i+1)-pipol
4998         x(1)=dtan(theti)
4999         x(2)=alph(i)
5000         x(3)=omeg(i)
5001
5002         if (x(2).gt.pi-delta) then
5003           xtemp(1)=x(1)
5004           xtemp(2)=pi-delta
5005           xtemp(3)=x(3)
5006           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5007           xtemp(2)=pi
5008           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5009           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5010      &        escloci,dersc(2))
5011           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5012      &        ddersc0(1),dersc(1))
5013           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5014      &        ddersc0(3),dersc(3))
5015           xtemp(2)=pi-delta
5016           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5017           xtemp(2)=pi
5018           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5019           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5020      &            dersc0(2),esclocbi,dersc02)
5021           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5022      &            dersc12,dersc01)
5023           call splinthet(x(2),0.5d0*delta,ss,ssd)
5024           dersc0(1)=dersc01
5025           dersc0(2)=dersc02
5026           dersc0(3)=0.0d0
5027           do k=1,3
5028             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5029           enddo
5030           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5031 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5032 c    &             esclocbi,ss,ssd
5033           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5034 c         escloci=esclocbi
5035 c         write (iout,*) escloci
5036         else if (x(2).lt.delta) then
5037           xtemp(1)=x(1)
5038           xtemp(2)=delta
5039           xtemp(3)=x(3)
5040           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5041           xtemp(2)=0.0d0
5042           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5043           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5044      &        escloci,dersc(2))
5045           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5046      &        ddersc0(1),dersc(1))
5047           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5048      &        ddersc0(3),dersc(3))
5049           xtemp(2)=delta
5050           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5051           xtemp(2)=0.0d0
5052           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5053           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5054      &            dersc0(2),esclocbi,dersc02)
5055           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5056      &            dersc12,dersc01)
5057           dersc0(1)=dersc01
5058           dersc0(2)=dersc02
5059           dersc0(3)=0.0d0
5060           call splinthet(x(2),0.5d0*delta,ss,ssd)
5061           do k=1,3
5062             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5063           enddo
5064           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5065 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5066 c    &             esclocbi,ss,ssd
5067           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5068 c         write (iout,*) escloci
5069         else
5070           call enesc(x,escloci,dersc,ddummy,.false.)
5071         endif
5072
5073         escloc=escloc+escloci
5074         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5075      &     'escloc',i,escloci
5076 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5077
5078         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5079      &   wscloc*dersc(1)
5080         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5081         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5082     1   continue
5083       enddo
5084       return
5085       end
5086 C---------------------------------------------------------------------------
5087       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5088       implicit real*8 (a-h,o-z)
5089       include 'DIMENSIONS'
5090       include 'COMMON.GEO'
5091       include 'COMMON.LOCAL'
5092       include 'COMMON.IOUNITS'
5093       common /sccalc/ time11,time12,time112,theti,it,nlobit
5094       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5095       double precision contr(maxlob,-1:1)
5096       logical mixed
5097 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5098         escloc_i=0.0D0
5099         do j=1,3
5100           dersc(j)=0.0D0
5101           if (mixed) ddersc(j)=0.0d0
5102         enddo
5103         x3=x(3)
5104
5105 C Because of periodicity of the dependence of the SC energy in omega we have
5106 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5107 C To avoid underflows, first compute & store the exponents.
5108
5109         do iii=-1,1
5110
5111           x(3)=x3+iii*dwapi
5112
5113           do j=1,nlobit
5114             do k=1,3
5115               z(k)=x(k)-censc(k,j,it)
5116             enddo
5117             do k=1,3
5118               Axk=0.0D0
5119               do l=1,3
5120                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5121               enddo
5122               Ax(k,j,iii)=Axk
5123             enddo
5124             expfac=0.0D0
5125             do k=1,3
5126               expfac=expfac+Ax(k,j,iii)*z(k)
5127             enddo
5128             contr(j,iii)=expfac
5129           enddo ! j
5130
5131         enddo ! iii
5132
5133         x(3)=x3
5134 C As in the case of ebend, we want to avoid underflows in exponentiation and
5135 C subsequent NaNs and INFs in energy calculation.
5136 C Find the largest exponent
5137         emin=contr(1,-1)
5138         do iii=-1,1
5139           do j=1,nlobit
5140             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5141           enddo
5142         enddo
5143         emin=0.5D0*emin
5144 cd      print *,'it=',it,' emin=',emin
5145
5146 C Compute the contribution to SC energy and derivatives
5147         do iii=-1,1
5148
5149           do j=1,nlobit
5150 #ifdef OSF
5151             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5152             if(adexp.ne.adexp) adexp=1.0
5153             expfac=dexp(adexp)
5154 #else
5155             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5156 #endif
5157 cd          print *,'j=',j,' expfac=',expfac
5158             escloc_i=escloc_i+expfac
5159             do k=1,3
5160               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5161             enddo
5162             if (mixed) then
5163               do k=1,3,2
5164                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5165      &            +gaussc(k,2,j,it))*expfac
5166               enddo
5167             endif
5168           enddo
5169
5170         enddo ! iii
5171
5172         dersc(1)=dersc(1)/cos(theti)**2
5173         ddersc(1)=ddersc(1)/cos(theti)**2
5174         ddersc(3)=ddersc(3)
5175
5176         escloci=-(dlog(escloc_i)-emin)
5177         do j=1,3
5178           dersc(j)=dersc(j)/escloc_i
5179         enddo
5180         if (mixed) then
5181           do j=1,3,2
5182             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5183           enddo
5184         endif
5185       return
5186       end
5187 C------------------------------------------------------------------------------
5188       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5189       implicit real*8 (a-h,o-z)
5190       include 'DIMENSIONS'
5191       include 'COMMON.GEO'
5192       include 'COMMON.LOCAL'
5193       include 'COMMON.IOUNITS'
5194       common /sccalc/ time11,time12,time112,theti,it,nlobit
5195       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5196       double precision contr(maxlob)
5197       logical mixed
5198
5199       escloc_i=0.0D0
5200
5201       do j=1,3
5202         dersc(j)=0.0D0
5203       enddo
5204
5205       do j=1,nlobit
5206         do k=1,2
5207           z(k)=x(k)-censc(k,j,it)
5208         enddo
5209         z(3)=dwapi
5210         do k=1,3
5211           Axk=0.0D0
5212           do l=1,3
5213             Axk=Axk+gaussc(l,k,j,it)*z(l)
5214           enddo
5215           Ax(k,j)=Axk
5216         enddo
5217         expfac=0.0D0
5218         do k=1,3
5219           expfac=expfac+Ax(k,j)*z(k)
5220         enddo
5221         contr(j)=expfac
5222       enddo ! j
5223
5224 C As in the case of ebend, we want to avoid underflows in exponentiation and
5225 C subsequent NaNs and INFs in energy calculation.
5226 C Find the largest exponent
5227       emin=contr(1)
5228       do j=1,nlobit
5229         if (emin.gt.contr(j)) emin=contr(j)
5230       enddo
5231       emin=0.5D0*emin
5232
5233 C Compute the contribution to SC energy and derivatives
5234
5235       dersc12=0.0d0
5236       do j=1,nlobit
5237         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5238         escloc_i=escloc_i+expfac
5239         do k=1,2
5240           dersc(k)=dersc(k)+Ax(k,j)*expfac
5241         enddo
5242         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5243      &            +gaussc(1,2,j,it))*expfac
5244         dersc(3)=0.0d0
5245       enddo
5246
5247       dersc(1)=dersc(1)/cos(theti)**2
5248       dersc12=dersc12/cos(theti)**2
5249       escloci=-(dlog(escloc_i)-emin)
5250       do j=1,2
5251         dersc(j)=dersc(j)/escloc_i
5252       enddo
5253       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5254       return
5255       end
5256 #else
5257 c----------------------------------------------------------------------------------
5258       subroutine esc(escloc)
5259 C Calculate the local energy of a side chain and its derivatives in the
5260 C corresponding virtual-bond valence angles THETA and the spherical angles
5261 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5262 C added by Urszula Kozlowska. 07/11/2007
5263 C
5264       implicit real*8 (a-h,o-z)
5265       include 'DIMENSIONS'
5266       include 'COMMON.GEO'
5267       include 'COMMON.LOCAL'
5268       include 'COMMON.VAR'
5269       include 'COMMON.SCROT'
5270       include 'COMMON.INTERACT'
5271       include 'COMMON.DERIV'
5272       include 'COMMON.CHAIN'
5273       include 'COMMON.IOUNITS'
5274       include 'COMMON.NAMES'
5275       include 'COMMON.FFIELD'
5276       include 'COMMON.CONTROL'
5277       include 'COMMON.VECTORS'
5278       double precision x_prime(3),y_prime(3),z_prime(3)
5279      &    , sumene,dsc_i,dp2_i,x(65),
5280      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5281      &    de_dxx,de_dyy,de_dzz,de_dt
5282       double precision s1_t,s1_6_t,s2_t,s2_6_t
5283       double precision
5284      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5285      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5286      & dt_dCi(3),dt_dCi1(3)
5287       common /sccalc/ time11,time12,time112,theti,it,nlobit
5288       delta=0.02d0*pi
5289       escloc=0.0D0
5290       do i=loc_start,loc_end
5291         costtab(i+1) =dcos(theta(i+1))
5292         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5293         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5294         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5295         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5296         cosfac=dsqrt(cosfac2)
5297         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5298         sinfac=dsqrt(sinfac2)
5299         it=itype(i)
5300         if (it.eq.10) goto 1
5301 c
5302 C  Compute the axes of tghe local cartesian coordinates system; store in
5303 c   x_prime, y_prime and z_prime
5304 c
5305         do j=1,3
5306           x_prime(j) = 0.00
5307           y_prime(j) = 0.00
5308           z_prime(j) = 0.00
5309         enddo
5310 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5311 C     &   dc_norm(3,i+nres)
5312         do j = 1,3
5313           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5314           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5315         enddo
5316         do j = 1,3
5317           z_prime(j) = -uz(j,i-1)
5318         enddo
5319 c       write (2,*) "i",i
5320 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5321 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5322 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5323 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5324 c      & " xy",scalar(x_prime(1),y_prime(1)),
5325 c      & " xz",scalar(x_prime(1),z_prime(1)),
5326 c      & " yy",scalar(y_prime(1),y_prime(1)),
5327 c      & " yz",scalar(y_prime(1),z_prime(1)),
5328 c      & " zz",scalar(z_prime(1),z_prime(1))
5329 c
5330 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5331 C to local coordinate system. Store in xx, yy, zz.
5332 c
5333         xx=0.0d0
5334         yy=0.0d0
5335         zz=0.0d0
5336         do j = 1,3
5337           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5338           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5339           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5340         enddo
5341
5342         xxtab(i)=xx
5343         yytab(i)=yy
5344         zztab(i)=zz
5345 C
5346 C Compute the energy of the ith side cbain
5347 C
5348 c        write (2,*) "xx",xx," yy",yy," zz",zz
5349         it=itype(i)
5350         do j = 1,65
5351           x(j) = sc_parmin(j,it)
5352         enddo
5353 #ifdef CHECK_COORD
5354 Cc diagnostics - remove later
5355         xx1 = dcos(alph(2))
5356         yy1 = dsin(alph(2))*dcos(omeg(2))
5357         zz1 = -dsin(alph(2))*dsin(omeg(2))
5358         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5359      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5360      &    xx1,yy1,zz1
5361 C,"  --- ", xx_w,yy_w,zz_w
5362 c end diagnostics
5363 #endif
5364         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5365      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5366      &   + x(10)*yy*zz
5367         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5368      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5369      & + x(20)*yy*zz
5370         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5371      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5372      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5373      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5374      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5375      &  +x(40)*xx*yy*zz
5376         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5377      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5378      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5379      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5380      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5381      &  +x(60)*xx*yy*zz
5382         dsc_i   = 0.743d0+x(61)
5383         dp2_i   = 1.9d0+x(62)
5384         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5385      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5386         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5387      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5388         s1=(1+x(63))/(0.1d0 + dscp1)
5389         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5390         s2=(1+x(65))/(0.1d0 + dscp2)
5391         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5392         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5393      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5394 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5395 c     &   sumene4,
5396 c     &   dscp1,dscp2,sumene
5397 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5398         escloc = escloc + sumene
5399 c        write (2,*) "i",i," escloc",sumene,escloc
5400 #ifdef DEBUG
5401 C
5402 C This section to check the numerical derivatives of the energy of ith side
5403 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5404 C #define DEBUG in the code to turn it on.
5405 C
5406         write (2,*) "sumene               =",sumene
5407         aincr=1.0d-7
5408         xxsave=xx
5409         xx=xx+aincr
5410         write (2,*) xx,yy,zz
5411         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5412         de_dxx_num=(sumenep-sumene)/aincr
5413         xx=xxsave
5414         write (2,*) "xx+ sumene from enesc=",sumenep
5415         yysave=yy
5416         yy=yy+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dyy_num=(sumenep-sumene)/aincr
5420         yy=yysave
5421         write (2,*) "yy+ sumene from enesc=",sumenep
5422         zzsave=zz
5423         zz=zz+aincr
5424         write (2,*) xx,yy,zz
5425         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5426         de_dzz_num=(sumenep-sumene)/aincr
5427         zz=zzsave
5428         write (2,*) "zz+ sumene from enesc=",sumenep
5429         costsave=cost2tab(i+1)
5430         sintsave=sint2tab(i+1)
5431         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5432         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5433         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5434         de_dt_num=(sumenep-sumene)/aincr
5435         write (2,*) " t+ sumene from enesc=",sumenep
5436         cost2tab(i+1)=costsave
5437         sint2tab(i+1)=sintsave
5438 C End of diagnostics section.
5439 #endif
5440 C
5441 C Compute the gradient of esc
5442 C
5443         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5444         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5445         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5446         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5447         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5448         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5449         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5450         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5451         pom1=(sumene3*sint2tab(i+1)+sumene1)
5452      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5453         pom2=(sumene4*cost2tab(i+1)+sumene2)
5454      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5455         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5456         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5457      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5458      &  +x(40)*yy*zz
5459         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5460         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5461      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5462      &  +x(60)*yy*zz
5463         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5464      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5465      &        +(pom1+pom2)*pom_dx
5466 #ifdef DEBUG
5467         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5468 #endif
5469 C
5470         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5471         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5472      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5473      &  +x(40)*xx*zz
5474         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5475         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5476      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5477      &  +x(59)*zz**2 +x(60)*xx*zz
5478         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5479      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5480      &        +(pom1-pom2)*pom_dy
5481 #ifdef DEBUG
5482         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5483 #endif
5484 C
5485         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5486      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5487      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5488      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5489      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5490      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5491      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5492      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5493 #ifdef DEBUG
5494         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5495 #endif
5496 C
5497         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5498      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5499      &  +pom1*pom_dt1+pom2*pom_dt2
5500 #ifdef DEBUG
5501         write(2,*), "de_dt = ", de_dt,de_dt_num
5502 #endif
5503 c
5504 C
5505        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5506        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5507        cosfac2xx=cosfac2*xx
5508        sinfac2yy=sinfac2*yy
5509        do k = 1,3
5510          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5511      &      vbld_inv(i+1)
5512          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5513      &      vbld_inv(i)
5514          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5515          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5516 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5517 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5518 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5519 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5520          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5521          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5522          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5523          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5524          dZZ_Ci1(k)=0.0d0
5525          dZZ_Ci(k)=0.0d0
5526          do j=1,3
5527            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5528            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5529          enddo
5530
5531          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5532          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5533          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5534 c
5535          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5536          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5537        enddo
5538
5539        do k=1,3
5540          dXX_Ctab(k,i)=dXX_Ci(k)
5541          dXX_C1tab(k,i)=dXX_Ci1(k)
5542          dYY_Ctab(k,i)=dYY_Ci(k)
5543          dYY_C1tab(k,i)=dYY_Ci1(k)
5544          dZZ_Ctab(k,i)=dZZ_Ci(k)
5545          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5546          dXX_XYZtab(k,i)=dXX_XYZ(k)
5547          dYY_XYZtab(k,i)=dYY_XYZ(k)
5548          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5549        enddo
5550
5551        do k = 1,3
5552 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5553 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5554 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5555 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5556 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5557 c     &    dt_dci(k)
5558 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5559 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5560          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5561      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5562          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5563      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5564          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5565      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5566        enddo
5567 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5568 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5569
5570 C to check gradient call subroutine check_grad
5571
5572     1 continue
5573       enddo
5574       return
5575       end
5576 c------------------------------------------------------------------------------
5577       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5578       implicit none
5579       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5580      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5581       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5582      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5583      &   + x(10)*yy*zz
5584       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5585      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5586      & + x(20)*yy*zz
5587       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5588      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5589      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5590      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5591      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5592      &  +x(40)*xx*yy*zz
5593       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5594      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5595      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5596      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5597      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5598      &  +x(60)*xx*yy*zz
5599       dsc_i   = 0.743d0+x(61)
5600       dp2_i   = 1.9d0+x(62)
5601       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5602      &          *(xx*cost2+yy*sint2))
5603       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5604      &          *(xx*cost2-yy*sint2))
5605       s1=(1+x(63))/(0.1d0 + dscp1)
5606       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5607       s2=(1+x(65))/(0.1d0 + dscp2)
5608       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5609       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5610      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5611       enesc=sumene
5612       return
5613       end
5614 #endif
5615 c------------------------------------------------------------------------------
5616       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5617 C
5618 C This procedure calculates two-body contact function g(rij) and its derivative:
5619 C
5620 C           eps0ij                                     !       x < -1
5621 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5622 C            0                                         !       x > 1
5623 C
5624 C where x=(rij-r0ij)/delta
5625 C
5626 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5627 C
5628       implicit none
5629       double precision rij,r0ij,eps0ij,fcont,fprimcont
5630       double precision x,x2,x4,delta
5631 c     delta=0.02D0*r0ij
5632 c      delta=0.2D0*r0ij
5633       x=(rij-r0ij)/delta
5634       if (x.lt.-1.0D0) then
5635         fcont=eps0ij
5636         fprimcont=0.0D0
5637       else if (x.le.1.0D0) then
5638         x2=x*x
5639         x4=x2*x2
5640         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5641         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5642       else
5643         fcont=0.0D0
5644         fprimcont=0.0D0
5645       endif
5646       return
5647       end
5648 c------------------------------------------------------------------------------
5649       subroutine splinthet(theti,delta,ss,ssder)
5650       implicit real*8 (a-h,o-z)
5651       include 'DIMENSIONS'
5652       include 'COMMON.VAR'
5653       include 'COMMON.GEO'
5654       thetup=pi-delta
5655       thetlow=delta
5656       if (theti.gt.pipol) then
5657         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5658       else
5659         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5660         ssder=-ssder
5661       endif
5662       return
5663       end
5664 c------------------------------------------------------------------------------
5665       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5666       implicit none
5667       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5668       double precision ksi,ksi2,ksi3,a1,a2,a3
5669       a1=fprim0*delta/(f1-f0)
5670       a2=3.0d0-2.0d0*a1
5671       a3=a1-2.0d0
5672       ksi=(x-x0)/delta
5673       ksi2=ksi*ksi
5674       ksi3=ksi2*ksi
5675       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5676       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5677       return
5678       end
5679 c------------------------------------------------------------------------------
5680       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5681       implicit none
5682       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5683       double precision ksi,ksi2,ksi3,a1,a2,a3
5684       ksi=(x-x0)/delta
5685       ksi2=ksi*ksi
5686       ksi3=ksi2*ksi
5687       a1=fprim0x*delta
5688       a2=3*(f1x-f0x)-2*fprim0x*delta
5689       a3=fprim0x*delta-2*(f1x-f0x)
5690       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5691       return
5692       end
5693 C-----------------------------------------------------------------------------
5694 #ifdef CRYST_TOR
5695 C-----------------------------------------------------------------------------
5696       subroutine etor(etors,edihcnstr)
5697       implicit real*8 (a-h,o-z)
5698       include 'DIMENSIONS'
5699       include 'COMMON.VAR'
5700       include 'COMMON.GEO'
5701       include 'COMMON.LOCAL'
5702       include 'COMMON.TORSION'
5703       include 'COMMON.INTERACT'
5704       include 'COMMON.DERIV'
5705       include 'COMMON.CHAIN'
5706       include 'COMMON.NAMES'
5707       include 'COMMON.IOUNITS'
5708       include 'COMMON.FFIELD'
5709       include 'COMMON.TORCNSTR'
5710       include 'COMMON.CONTROL'
5711       logical lprn
5712 C Set lprn=.true. for debugging
5713       lprn=.false.
5714 c      lprn=.true.
5715       etors=0.0D0
5716       do i=iphi_start,iphi_end
5717       etors_ii=0.0D0
5718         itori=itortyp(itype(i-2))
5719         itori1=itortyp(itype(i-1))
5720         phii=phi(i)
5721         gloci=0.0D0
5722 C Proline-Proline pair is a special case...
5723         if (itori.eq.3 .and. itori1.eq.3) then
5724           if (phii.gt.-dwapi3) then
5725             cosphi=dcos(3*phii)
5726             fac=1.0D0/(1.0D0-cosphi)
5727             etorsi=v1(1,3,3)*fac
5728             etorsi=etorsi+etorsi
5729             etors=etors+etorsi-v1(1,3,3)
5730             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5731             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5732           endif
5733           do j=1,3
5734             v1ij=v1(j+1,itori,itori1)
5735             v2ij=v2(j+1,itori,itori1)
5736             cosphi=dcos(j*phii)
5737             sinphi=dsin(j*phii)
5738             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5739             if (energy_dec) etors_ii=etors_ii+
5740      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5741             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5742           enddo
5743         else
5744           do j=1,nterm_old
5745             v1ij=v1(j,itori,itori1)
5746             v2ij=v2(j,itori,itori1)
5747             cosphi=dcos(j*phii)
5748             sinphi=dsin(j*phii)
5749             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5750             if (energy_dec) etors_ii=etors_ii+
5751      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5752             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5753           enddo
5754         endif
5755         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5756      &        'etor',i,etors_ii
5757         if (lprn)
5758      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5759      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5760      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5761         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5762         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5763       enddo
5764 ! 6/20/98 - dihedral angle constraints
5765       edihcnstr=0.0d0
5766       do i=1,ndih_constr
5767         itori=idih_constr(i)
5768         phii=phi(itori)
5769         difi=phii-phi0(i)
5770         if (difi.gt.drange(i)) then
5771           difi=difi-drange(i)
5772           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5773           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5774         else if (difi.lt.-drange(i)) then
5775           difi=difi+drange(i)
5776           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5777           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5778         endif
5779 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5780 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5781       enddo
5782 !      write (iout,*) 'edihcnstr',edihcnstr
5783       return
5784       end
5785 c------------------------------------------------------------------------------
5786       subroutine etor_d(etors_d)
5787       etors_d=0.0d0
5788       return
5789       end
5790 c----------------------------------------------------------------------------
5791 #else
5792       subroutine etor(etors,edihcnstr)
5793       implicit real*8 (a-h,o-z)
5794       include 'DIMENSIONS'
5795       include 'COMMON.VAR'
5796       include 'COMMON.GEO'
5797       include 'COMMON.LOCAL'
5798       include 'COMMON.TORSION'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.CHAIN'
5802       include 'COMMON.NAMES'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.FFIELD'
5805       include 'COMMON.TORCNSTR'
5806       include 'COMMON.CONTROL'
5807       logical lprn
5808 C Set lprn=.true. for debugging
5809       lprn=.false.
5810 c     lprn=.true.
5811       etors=0.0D0
5812       do i=iphi_start,iphi_end
5813       etors_ii=0.0D0
5814         itori=itortyp(itype(i-2))
5815         itori1=itortyp(itype(i-1))
5816         phii=phi(i)
5817         gloci=0.0D0
5818 C Regular cosine and sine terms
5819         do j=1,nterm(itori,itori1)
5820           v1ij=v1(j,itori,itori1)
5821           v2ij=v2(j,itori,itori1)
5822           cosphi=dcos(j*phii)
5823           sinphi=dsin(j*phii)
5824           etors=etors+v1ij*cosphi+v2ij*sinphi
5825           if (energy_dec) etors_ii=etors_ii+
5826      &                v1ij*cosphi+v2ij*sinphi
5827           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5828         enddo
5829 C Lorentz terms
5830 C                         v1
5831 C  E = SUM ----------------------------------- - v1
5832 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5833 C
5834         cosphi=dcos(0.5d0*phii)
5835         sinphi=dsin(0.5d0*phii)
5836         do j=1,nlor(itori,itori1)
5837           vl1ij=vlor1(j,itori,itori1)
5838           vl2ij=vlor2(j,itori,itori1)
5839           vl3ij=vlor3(j,itori,itori1)
5840           pom=vl2ij*cosphi+vl3ij*sinphi
5841           pom1=1.0d0/(pom*pom+1.0d0)
5842           etors=etors+vl1ij*pom1
5843           if (energy_dec) etors_ii=etors_ii+
5844      &                vl1ij*pom1
5845           pom=-pom*pom1*pom1
5846           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5847         enddo
5848 C Subtract the constant term
5849         etors=etors-v0(itori,itori1)
5850           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5851      &         'etor',i,etors_ii-v0(itori,itori1)
5852         if (lprn)
5853      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5854      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5855      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5856         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5857 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5858       enddo
5859 ! 6/20/98 - dihedral angle constraints
5860       edihcnstr=0.0d0
5861 c      do i=1,ndih_constr
5862       do i=idihconstr_start,idihconstr_end
5863         itori=idih_constr(i)
5864         phii=phi(itori)
5865         difi=pinorm(phii-phi0(i))
5866         if (difi.gt.drange(i)) then
5867           difi=difi-drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else if (difi.lt.-drange(i)) then
5871           difi=difi+drange(i)
5872           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5873           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5874         else
5875           difi=0.0
5876         endif
5877 c        write (iout,*) "gloci", gloc(i-3,icg)
5878 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5879 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5880 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5881       enddo
5882 cd       write (iout,*) 'edihcnstr',edihcnstr
5883       return
5884       end
5885 c----------------------------------------------------------------------------
5886       subroutine etor_d(etors_d)
5887 C 6/23/01 Compute double torsional energy
5888       implicit real*8 (a-h,o-z)
5889       include 'DIMENSIONS'
5890       include 'COMMON.VAR'
5891       include 'COMMON.GEO'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.TORSION'
5894       include 'COMMON.INTERACT'
5895       include 'COMMON.DERIV'
5896       include 'COMMON.CHAIN'
5897       include 'COMMON.NAMES'
5898       include 'COMMON.IOUNITS'
5899       include 'COMMON.FFIELD'
5900       include 'COMMON.TORCNSTR'
5901       include 'COMMON.CONTROL'
5902       logical lprn
5903 C Set lprn=.true. for debugging
5904       lprn=.false.
5905 c     lprn=.true.
5906       etors_d=0.0D0
5907       do i=iphid_start,iphid_end
5908         etors_d_ii=0.0D0
5909         itori=itortyp(itype(i-2))
5910         itori1=itortyp(itype(i-1))
5911         itori2=itortyp(itype(i))
5912         phii=phi(i)
5913         phii1=phi(i+1)
5914         gloci1=0.0D0
5915         gloci2=0.0D0
5916         do j=1,ntermd_1(itori,itori1,itori2)
5917           v1cij=v1c(1,j,itori,itori1,itori2)
5918           v1sij=v1s(1,j,itori,itori1,itori2)
5919           v2cij=v1c(2,j,itori,itori1,itori2)
5920           v2sij=v1s(2,j,itori,itori1,itori2)
5921           cosphi1=dcos(j*phii)
5922           sinphi1=dsin(j*phii)
5923           cosphi2=dcos(j*phii1)
5924           sinphi2=dsin(j*phii1)
5925           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5926      &     v2cij*cosphi2+v2sij*sinphi2
5927           if (energy_dec) etors_d_ii=etors_d_ii+
5928      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5929           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5930           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5931         enddo
5932         do k=2,ntermd_2(itori,itori1,itori2)
5933           do l=1,k-1
5934             v1cdij = v2c(k,l,itori,itori1,itori2)
5935             v2cdij = v2c(l,k,itori,itori1,itori2)
5936             v1sdij = v2s(k,l,itori,itori1,itori2)
5937             v2sdij = v2s(l,k,itori,itori1,itori2)
5938             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5939             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5940             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5941             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5942             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5943      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5944             if (energy_dec) etors_d_ii=etors_d_ii+
5945      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5946      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5947             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5948      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5949             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5950      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5951           enddo
5952         enddo
5953         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5954      &        'etor_d',i,etors_d_ii
5955         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5956         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5957 c        write (iout,*) "gloci", gloc(i-3,icg)
5958       enddo
5959       return
5960       end
5961 #endif
5962 c------------------------------------------------------------------------------
5963       subroutine eback_sc_corr(esccor)
5964 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5965 c        conformational states; temporarily implemented as differences
5966 c        between UNRES torsional potentials (dependent on three types of
5967 c        residues) and the torsional potentials dependent on all 20 types
5968 c        of residues computed from AM1  energy surfaces of terminally-blocked
5969 c        amino-acid residues.
5970       implicit real*8 (a-h,o-z)
5971       include 'DIMENSIONS'
5972       include 'COMMON.VAR'
5973       include 'COMMON.GEO'
5974       include 'COMMON.LOCAL'
5975       include 'COMMON.TORSION'
5976       include 'COMMON.SCCOR'
5977       include 'COMMON.INTERACT'
5978       include 'COMMON.DERIV'
5979       include 'COMMON.CHAIN'
5980       include 'COMMON.NAMES'
5981       include 'COMMON.IOUNITS'
5982       include 'COMMON.FFIELD'
5983       include 'COMMON.CONTROL'
5984       logical lprn
5985 C Set lprn=.true. for debugging
5986       lprn=.false.
5987 c      lprn=.true.
5988 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5989       esccor=0.0D0
5990       do i=itau_start,itau_end
5991 C        do i=42,42
5992         esccor_ii=0.0D0
5993         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5994         isccori=isccortyp(itype(i-2))
5995         isccori1=isccortyp(itype(i-1))
5996         phii=phi(i)
5997
5998 cccc  Added 9 May 2012
5999 cc Tauangle is torsional engle depending on the value of first digit
6000 c(see comment below)
6001 cc Omicron is flat angle depending on the value of first digit
6002 c(see comment below)
6003 C        print *,i,tauangle(1,i)
6004
6005         do intertyp=1,3 !intertyp
6006 cc Added 09 May 2012 (Adasko)
6007 cc  Intertyp means interaction type of backbone mainchain correlation:
6008 c   1 = SC...Ca...Ca...Ca
6009 c   2 = Ca...Ca...Ca...SC
6010 c   3 = SC...Ca...Ca...SCi
6011         gloci=0.0D0
6012         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6013      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6014      &      (itype(i-1).eq.21)))
6015      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6016      &     .or.(itype(i-2).eq.21)))
6017      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6018      &      (itype(i-1).eq.21)))) cycle
6019         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6020         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6021      & cycle
6022         do j=1,nterm_sccor(isccori,isccori1)
6023           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6024           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6025           cosphi=dcos(j*tauangle(intertyp,i))
6026           sinphi=dsin(j*tauangle(intertyp,i))
6027           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6028           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6029         enddo
6030 C        print *,i,tauangle(1,i),gloci
6031         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6032 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6033 c     &gloc_sc(intertyp,i-3,icg)
6034         if (lprn)
6035      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6036      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6037      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6038      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6039         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6040        enddo !intertyp
6041       enddo
6042 c        do i=1,nres
6043 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
6044 c     &   gloc_sc(3,i,icg)
6045 c        enddo
6046       return
6047       end
6048 c----------------------------------------------------------------------------
6049       subroutine multibody(ecorr)
6050 C This subroutine calculates multi-body contributions to energy following
6051 C the idea of Skolnick et al. If side chains I and J make a contact and
6052 C at the same time side chains I+1 and J+1 make a contact, an extra
6053 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6054       implicit real*8 (a-h,o-z)
6055       include 'DIMENSIONS'
6056       include 'COMMON.IOUNITS'
6057       include 'COMMON.DERIV'
6058       include 'COMMON.INTERACT'
6059       include 'COMMON.CONTACTS'
6060       double precision gx(3),gx1(3)
6061       logical lprn
6062
6063 C Set lprn=.true. for debugging
6064       lprn=.false.
6065
6066       if (lprn) then
6067         write (iout,'(a)') 'Contact function values:'
6068         do i=nnt,nct-2
6069           write (iout,'(i2,20(1x,i2,f10.5))')
6070      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6071         enddo
6072       endif
6073       ecorr=0.0D0
6074       do i=nnt,nct
6075         do j=1,3
6076           gradcorr(j,i)=0.0D0
6077           gradxorr(j,i)=0.0D0
6078         enddo
6079       enddo
6080       do i=nnt,nct-2
6081
6082         DO ISHIFT = 3,4
6083
6084         i1=i+ishift
6085         num_conti=num_cont(i)
6086         num_conti1=num_cont(i1)
6087         do jj=1,num_conti
6088           j=jcont(jj,i)
6089           do kk=1,num_conti1
6090             j1=jcont(kk,i1)
6091             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6092 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6093 cd   &                   ' ishift=',ishift
6094 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6095 C The system gains extra energy.
6096               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6097             endif   ! j1==j+-ishift
6098           enddo     ! kk
6099         enddo       ! jj
6100
6101         ENDDO ! ISHIFT
6102
6103       enddo         ! i
6104       return
6105       end
6106 c------------------------------------------------------------------------------
6107       double precision function esccorr(i,j,k,l,jj,kk)
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.IOUNITS'
6111       include 'COMMON.DERIV'
6112       include 'COMMON.INTERACT'
6113       include 'COMMON.CONTACTS'
6114       double precision gx(3),gx1(3)
6115       logical lprn
6116       lprn=.false.
6117       eij=facont(jj,i)
6118       ekl=facont(kk,k)
6119 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6120 C Calculate the multi-body contribution to energy.
6121 C Calculate multi-body contributions to the gradient.
6122 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6123 cd   & k,l,(gacont(m,kk,k),m=1,3)
6124       do m=1,3
6125         gx(m) =ekl*gacont(m,jj,i)
6126         gx1(m)=eij*gacont(m,kk,k)
6127         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6128         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6129         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6130         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6131       enddo
6132       do m=i,j-1
6133         do ll=1,3
6134           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6135         enddo
6136       enddo
6137       do m=k,l-1
6138         do ll=1,3
6139           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6140         enddo
6141       enddo
6142       esccorr=-eij*ekl
6143       return
6144       end
6145 c------------------------------------------------------------------------------
6146       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6147 C This subroutine calculates multi-body contributions to hydrogen-bonding
6148       implicit real*8 (a-h,o-z)
6149       include 'DIMENSIONS'
6150       include 'COMMON.IOUNITS'
6151 #ifdef MPI
6152       include "mpif.h"
6153       parameter (max_cont=maxconts)
6154       parameter (max_dim=26)
6155       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6156       double precision zapas(max_dim,maxconts,max_fg_procs),
6157      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6158       common /przechowalnia/ zapas
6159       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6160      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6161 #endif
6162       include 'COMMON.SETUP'
6163       include 'COMMON.FFIELD'
6164       include 'COMMON.DERIV'
6165       include 'COMMON.INTERACT'
6166       include 'COMMON.CONTACTS'
6167       include 'COMMON.CONTROL'
6168       include 'COMMON.LOCAL'
6169       double precision gx(3),gx1(3),time00
6170       logical lprn,ldone
6171
6172 C Set lprn=.true. for debugging
6173       lprn=.false.
6174 #ifdef MPI
6175       n_corr=0
6176       n_corr1=0
6177       if (nfgtasks.le.1) goto 30
6178       if (lprn) then
6179         write (iout,'(a)') 'Contact function values before RECEIVE:'
6180         do i=nnt,nct-2
6181           write (iout,'(2i3,50(1x,i2,f5.2))')
6182      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6183      &    j=1,num_cont_hb(i))
6184         enddo
6185       endif
6186       call flush(iout)
6187       do i=1,ntask_cont_from
6188         ncont_recv(i)=0
6189       enddo
6190       do i=1,ntask_cont_to
6191         ncont_sent(i)=0
6192       enddo
6193 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6194 c     & ntask_cont_to
6195 C Make the list of contacts to send to send to other procesors
6196 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6197 c      call flush(iout)
6198       do i=iturn3_start,iturn3_end
6199 c        write (iout,*) "make contact list turn3",i," num_cont",
6200 c     &    num_cont_hb(i)
6201         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6202       enddo
6203       do i=iturn4_start,iturn4_end
6204 c        write (iout,*) "make contact list turn4",i," num_cont",
6205 c     &   num_cont_hb(i)
6206         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6207       enddo
6208       do ii=1,nat_sent
6209         i=iat_sent(ii)
6210 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6211 c     &    num_cont_hb(i)
6212         do j=1,num_cont_hb(i)
6213         do k=1,4
6214           jjc=jcont_hb(j,i)
6215           iproc=iint_sent_local(k,jjc,ii)
6216 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6217           if (iproc.gt.0) then
6218             ncont_sent(iproc)=ncont_sent(iproc)+1
6219             nn=ncont_sent(iproc)
6220             zapas(1,nn,iproc)=i
6221             zapas(2,nn,iproc)=jjc
6222             zapas(3,nn,iproc)=facont_hb(j,i)
6223             zapas(4,nn,iproc)=ees0p(j,i)
6224             zapas(5,nn,iproc)=ees0m(j,i)
6225             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6226             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6227             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6228             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6229             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6230             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6231             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6232             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6233             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6234             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6235             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6236             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6237             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6238             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6239             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6240             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6241             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6242             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6243             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6244             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6245             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6246           endif
6247         enddo
6248         enddo
6249       enddo
6250       if (lprn) then
6251       write (iout,*)
6252      &  "Numbers of contacts to be sent to other processors",
6253      &  (ncont_sent(i),i=1,ntask_cont_to)
6254       write (iout,*) "Contacts sent"
6255       do ii=1,ntask_cont_to
6256         nn=ncont_sent(ii)
6257         iproc=itask_cont_to(ii)
6258         write (iout,*) nn," contacts to processor",iproc,
6259      &   " of CONT_TO_COMM group"
6260         do i=1,nn
6261           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6262         enddo
6263       enddo
6264       call flush(iout)
6265       endif
6266       CorrelType=477
6267       CorrelID=fg_rank+1
6268       CorrelType1=478
6269       CorrelID1=nfgtasks+fg_rank+1
6270       ireq=0
6271 C Receive the numbers of needed contacts from other processors
6272       do ii=1,ntask_cont_from
6273         iproc=itask_cont_from(ii)
6274         ireq=ireq+1
6275         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6276      &    FG_COMM,req(ireq),IERR)
6277       enddo
6278 c      write (iout,*) "IRECV ended"
6279 c      call flush(iout)
6280 C Send the number of contacts needed by other processors
6281       do ii=1,ntask_cont_to
6282         iproc=itask_cont_to(ii)
6283         ireq=ireq+1
6284         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6285      &    FG_COMM,req(ireq),IERR)
6286       enddo
6287 c      write (iout,*) "ISEND ended"
6288 c      write (iout,*) "number of requests (nn)",ireq
6289       call flush(iout)
6290       if (ireq.gt.0)
6291      &  call MPI_Waitall(ireq,req,status_array,ierr)
6292 c      write (iout,*)
6293 c     &  "Numbers of contacts to be received from other processors",
6294 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6295 c      call flush(iout)
6296 C Receive contacts
6297       ireq=0
6298       do ii=1,ntask_cont_from
6299         iproc=itask_cont_from(ii)
6300         nn=ncont_recv(ii)
6301 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6302 c     &   " of CONT_TO_COMM group"
6303         call flush(iout)
6304         if (nn.gt.0) then
6305           ireq=ireq+1
6306           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6307      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6308 c          write (iout,*) "ireq,req",ireq,req(ireq)
6309         endif
6310       enddo
6311 C Send the contacts to processors that need them
6312       do ii=1,ntask_cont_to
6313         iproc=itask_cont_to(ii)
6314         nn=ncont_sent(ii)
6315 c        write (iout,*) nn," contacts to processor",iproc,
6316 c     &   " of CONT_TO_COMM group"
6317         if (nn.gt.0) then
6318           ireq=ireq+1
6319           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6320      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6321 c          write (iout,*) "ireq,req",ireq,req(ireq)
6322 c          do i=1,nn
6323 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6324 c          enddo
6325         endif
6326       enddo
6327 c      write (iout,*) "number of requests (contacts)",ireq
6328 c      write (iout,*) "req",(req(i),i=1,4)
6329 c      call flush(iout)
6330       if (ireq.gt.0)
6331      & call MPI_Waitall(ireq,req,status_array,ierr)
6332       do iii=1,ntask_cont_from
6333         iproc=itask_cont_from(iii)
6334         nn=ncont_recv(iii)
6335         if (lprn) then
6336         write (iout,*) "Received",nn," contacts from processor",iproc,
6337      &   " of CONT_FROM_COMM group"
6338         call flush(iout)
6339         do i=1,nn
6340           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6341         enddo
6342         call flush(iout)
6343         endif
6344         do i=1,nn
6345           ii=zapas_recv(1,i,iii)
6346 c Flag the received contacts to prevent double-counting
6347           jj=-zapas_recv(2,i,iii)
6348 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6349 c          call flush(iout)
6350           nnn=num_cont_hb(ii)+1
6351           num_cont_hb(ii)=nnn
6352           jcont_hb(nnn,ii)=jj
6353           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6354           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6355           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6356           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6357           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6358           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6359           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6360           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6361           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6362           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6363           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6364           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6365           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6366           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6367           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6368           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6369           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6370           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6371           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6372           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6373           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6374           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6375           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6376           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6377         enddo
6378       enddo
6379       call flush(iout)
6380       if (lprn) then
6381         write (iout,'(a)') 'Contact function values after receive:'
6382         do i=nnt,nct-2
6383           write (iout,'(2i3,50(1x,i3,f5.2))')
6384      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6385      &    j=1,num_cont_hb(i))
6386         enddo
6387         call flush(iout)
6388       endif
6389    30 continue
6390 #endif
6391       if (lprn) then
6392         write (iout,'(a)') 'Contact function values:'
6393         do i=nnt,nct-2
6394           write (iout,'(2i3,50(1x,i3,f5.2))')
6395      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6396      &    j=1,num_cont_hb(i))
6397         enddo
6398       endif
6399       ecorr=0.0D0
6400 C Remove the loop below after debugging !!!
6401       do i=nnt,nct
6402         do j=1,3
6403           gradcorr(j,i)=0.0D0
6404           gradxorr(j,i)=0.0D0
6405         enddo
6406       enddo
6407 C Calculate the local-electrostatic correlation terms
6408       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6409         i1=i+1
6410         num_conti=num_cont_hb(i)
6411         num_conti1=num_cont_hb(i+1)
6412         do jj=1,num_conti
6413           j=jcont_hb(jj,i)
6414           jp=iabs(j)
6415           do kk=1,num_conti1
6416             j1=jcont_hb(kk,i1)
6417             jp1=iabs(j1)
6418 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6419 c     &         ' jj=',jj,' kk=',kk
6420             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6421      &          .or. j.lt.0 .and. j1.gt.0) .and.
6422      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6423 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6424 C The system gains extra energy.
6425               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6426               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6427      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6428               n_corr=n_corr+1
6429             else if (j1.eq.j) then
6430 C Contacts I-J and I-(J+1) occur simultaneously.
6431 C The system loses extra energy.
6432 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6433             endif
6434           enddo ! kk
6435           do kk=1,num_conti
6436             j1=jcont_hb(kk,i)
6437 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6438 c    &         ' jj=',jj,' kk=',kk
6439             if (j1.eq.j+1) then
6440 C Contacts I-J and (I+1)-J occur simultaneously.
6441 C The system loses extra energy.
6442 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6443             endif ! j1==j+1
6444           enddo ! kk
6445         enddo ! jj
6446       enddo ! i
6447       return
6448       end
6449 c------------------------------------------------------------------------------
6450       subroutine add_hb_contact(ii,jj,itask)
6451       implicit real*8 (a-h,o-z)
6452       include "DIMENSIONS"
6453       include "COMMON.IOUNITS"
6454       integer max_cont
6455       integer max_dim
6456       parameter (max_cont=maxconts)
6457       parameter (max_dim=26)
6458       include "COMMON.CONTACTS"
6459       double precision zapas(max_dim,maxconts,max_fg_procs),
6460      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6461       common /przechowalnia/ zapas
6462       integer i,j,ii,jj,iproc,itask(4),nn
6463 c      write (iout,*) "itask",itask
6464       do i=1,2
6465         iproc=itask(i)
6466         if (iproc.gt.0) then
6467           do j=1,num_cont_hb(ii)
6468             jjc=jcont_hb(j,ii)
6469 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6470             if (jjc.eq.jj) then
6471               ncont_sent(iproc)=ncont_sent(iproc)+1
6472               nn=ncont_sent(iproc)
6473               zapas(1,nn,iproc)=ii
6474               zapas(2,nn,iproc)=jjc
6475               zapas(3,nn,iproc)=facont_hb(j,ii)
6476               zapas(4,nn,iproc)=ees0p(j,ii)
6477               zapas(5,nn,iproc)=ees0m(j,ii)
6478               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6479               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6480               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6481               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6482               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6483               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6484               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6485               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6486               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6487               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6488               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6489               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6490               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6491               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6492               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6493               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6494               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6495               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6496               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6497               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6498               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6499               exit
6500             endif
6501           enddo
6502         endif
6503       enddo
6504       return
6505       end
6506 c------------------------------------------------------------------------------
6507       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6508      &  n_corr1)
6509 C This subroutine calculates multi-body contributions to hydrogen-bonding
6510       implicit real*8 (a-h,o-z)
6511       include 'DIMENSIONS'
6512       include 'COMMON.IOUNITS'
6513 #ifdef MPI
6514       include "mpif.h"
6515       parameter (max_cont=maxconts)
6516       parameter (max_dim=70)
6517       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6518       double precision zapas(max_dim,maxconts,max_fg_procs),
6519      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6520       common /przechowalnia/ zapas
6521       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6522      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6523 #endif
6524       include 'COMMON.SETUP'
6525       include 'COMMON.FFIELD'
6526       include 'COMMON.DERIV'
6527       include 'COMMON.LOCAL'
6528       include 'COMMON.INTERACT'
6529       include 'COMMON.CONTACTS'
6530       include 'COMMON.CHAIN'
6531       include 'COMMON.CONTROL'
6532       double precision gx(3),gx1(3)
6533       integer num_cont_hb_old(maxres)
6534       logical lprn,ldone
6535       double precision eello4,eello5,eelo6,eello_turn6
6536       external eello4,eello5,eello6,eello_turn6
6537 C Set lprn=.true. for debugging
6538       lprn=.false.
6539       eturn6=0.0d0
6540 #ifdef MPI
6541       do i=1,nres
6542         num_cont_hb_old(i)=num_cont_hb(i)
6543       enddo
6544       n_corr=0
6545       n_corr1=0
6546       if (nfgtasks.le.1) goto 30
6547       if (lprn) then
6548         write (iout,'(a)') 'Contact function values before RECEIVE:'
6549         do i=nnt,nct-2
6550           write (iout,'(2i3,50(1x,i2,f5.2))')
6551      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6552      &    j=1,num_cont_hb(i))
6553         enddo
6554       endif
6555       call flush(iout)
6556       do i=1,ntask_cont_from
6557         ncont_recv(i)=0
6558       enddo
6559       do i=1,ntask_cont_to
6560         ncont_sent(i)=0
6561       enddo
6562 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6563 c     & ntask_cont_to
6564 C Make the list of contacts to send to send to other procesors
6565       do i=iturn3_start,iturn3_end
6566 c        write (iout,*) "make contact list turn3",i," num_cont",
6567 c     &    num_cont_hb(i)
6568         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6569       enddo
6570       do i=iturn4_start,iturn4_end
6571 c        write (iout,*) "make contact list turn4",i," num_cont",
6572 c     &   num_cont_hb(i)
6573         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6574       enddo
6575       do ii=1,nat_sent
6576         i=iat_sent(ii)
6577 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6578 c     &    num_cont_hb(i)
6579         do j=1,num_cont_hb(i)
6580         do k=1,4
6581           jjc=jcont_hb(j,i)
6582           iproc=iint_sent_local(k,jjc,ii)
6583 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6584           if (iproc.ne.0) then
6585             ncont_sent(iproc)=ncont_sent(iproc)+1
6586             nn=ncont_sent(iproc)
6587             zapas(1,nn,iproc)=i
6588             zapas(2,nn,iproc)=jjc
6589             zapas(3,nn,iproc)=d_cont(j,i)
6590             ind=3
6591             do kk=1,3
6592               ind=ind+1
6593               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6594             enddo
6595             do kk=1,2
6596               do ll=1,2
6597                 ind=ind+1
6598                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6599               enddo
6600             enddo
6601             do jj=1,5
6602               do kk=1,3
6603                 do ll=1,2
6604                   do mm=1,2
6605                     ind=ind+1
6606                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6607                   enddo
6608                 enddo
6609               enddo
6610             enddo
6611           endif
6612         enddo
6613         enddo
6614       enddo
6615       if (lprn) then
6616       write (iout,*)
6617      &  "Numbers of contacts to be sent to other processors",
6618      &  (ncont_sent(i),i=1,ntask_cont_to)
6619       write (iout,*) "Contacts sent"
6620       do ii=1,ntask_cont_to
6621         nn=ncont_sent(ii)
6622         iproc=itask_cont_to(ii)
6623         write (iout,*) nn," contacts to processor",iproc,
6624      &   " of CONT_TO_COMM group"
6625         do i=1,nn
6626           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6627         enddo
6628       enddo
6629       call flush(iout)
6630       endif
6631       CorrelType=477
6632       CorrelID=fg_rank+1
6633       CorrelType1=478
6634       CorrelID1=nfgtasks+fg_rank+1
6635       ireq=0
6636 C Receive the numbers of needed contacts from other processors
6637       do ii=1,ntask_cont_from
6638         iproc=itask_cont_from(ii)
6639         ireq=ireq+1
6640         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6641      &    FG_COMM,req(ireq),IERR)
6642       enddo
6643 c      write (iout,*) "IRECV ended"
6644 c      call flush(iout)
6645 C Send the number of contacts needed by other processors
6646       do ii=1,ntask_cont_to
6647         iproc=itask_cont_to(ii)
6648         ireq=ireq+1
6649         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6650      &    FG_COMM,req(ireq),IERR)
6651       enddo
6652 c      write (iout,*) "ISEND ended"
6653 c      write (iout,*) "number of requests (nn)",ireq
6654       call flush(iout)
6655       if (ireq.gt.0)
6656      &  call MPI_Waitall(ireq,req,status_array,ierr)
6657 c      write (iout,*)
6658 c     &  "Numbers of contacts to be received from other processors",
6659 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6660 c      call flush(iout)
6661 C Receive contacts
6662       ireq=0
6663       do ii=1,ntask_cont_from
6664         iproc=itask_cont_from(ii)
6665         nn=ncont_recv(ii)
6666 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6667 c     &   " of CONT_TO_COMM group"
6668         call flush(iout)
6669         if (nn.gt.0) then
6670           ireq=ireq+1
6671           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6672      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6673 c          write (iout,*) "ireq,req",ireq,req(ireq)
6674         endif
6675       enddo
6676 C Send the contacts to processors that need them
6677       do ii=1,ntask_cont_to
6678         iproc=itask_cont_to(ii)
6679         nn=ncont_sent(ii)
6680 c        write (iout,*) nn," contacts to processor",iproc,
6681 c     &   " of CONT_TO_COMM group"
6682         if (nn.gt.0) then
6683           ireq=ireq+1
6684           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6685      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6686 c          write (iout,*) "ireq,req",ireq,req(ireq)
6687 c          do i=1,nn
6688 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6689 c          enddo
6690         endif
6691       enddo
6692 c      write (iout,*) "number of requests (contacts)",ireq
6693 c      write (iout,*) "req",(req(i),i=1,4)
6694 c      call flush(iout)
6695       if (ireq.gt.0)
6696      & call MPI_Waitall(ireq,req,status_array,ierr)
6697       do iii=1,ntask_cont_from
6698         iproc=itask_cont_from(iii)
6699         nn=ncont_recv(iii)
6700         if (lprn) then
6701         write (iout,*) "Received",nn," contacts from processor",iproc,
6702      &   " of CONT_FROM_COMM group"
6703         call flush(iout)
6704         do i=1,nn
6705           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6706         enddo
6707         call flush(iout)
6708         endif
6709         do i=1,nn
6710           ii=zapas_recv(1,i,iii)
6711 c Flag the received contacts to prevent double-counting
6712           jj=-zapas_recv(2,i,iii)
6713 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6714 c          call flush(iout)
6715           nnn=num_cont_hb(ii)+1
6716           num_cont_hb(ii)=nnn
6717           jcont_hb(nnn,ii)=jj
6718           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6719           ind=3
6720           do kk=1,3
6721             ind=ind+1
6722             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6723           enddo
6724           do kk=1,2
6725             do ll=1,2
6726               ind=ind+1
6727               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6728             enddo
6729           enddo
6730           do jj=1,5
6731             do kk=1,3
6732               do ll=1,2
6733                 do mm=1,2
6734                   ind=ind+1
6735                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6736                 enddo
6737               enddo
6738             enddo
6739           enddo
6740         enddo
6741       enddo
6742       call flush(iout)
6743       if (lprn) then
6744         write (iout,'(a)') 'Contact function values after receive:'
6745         do i=nnt,nct-2
6746           write (iout,'(2i3,50(1x,i3,5f6.3))')
6747      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6748      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6749         enddo
6750         call flush(iout)
6751       endif
6752    30 continue
6753 #endif
6754       if (lprn) then
6755         write (iout,'(a)') 'Contact function values:'
6756         do i=nnt,nct-2
6757           write (iout,'(2i3,50(1x,i2,5f6.3))')
6758      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6759      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6760         enddo
6761       endif
6762       ecorr=0.0D0
6763       ecorr5=0.0d0
6764       ecorr6=0.0d0
6765 C Remove the loop below after debugging !!!
6766       do i=nnt,nct
6767         do j=1,3
6768           gradcorr(j,i)=0.0D0
6769           gradxorr(j,i)=0.0D0
6770         enddo
6771       enddo
6772 C Calculate the dipole-dipole interaction energies
6773       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6774       do i=iatel_s,iatel_e+1
6775         num_conti=num_cont_hb(i)
6776         do jj=1,num_conti
6777           j=jcont_hb(jj,i)
6778 #ifdef MOMENT
6779           call dipole(i,j,jj)
6780 #endif
6781         enddo
6782       enddo
6783       endif
6784 C Calculate the local-electrostatic correlation terms
6785 c                write (iout,*) "gradcorr5 in eello5 before loop"
6786 c                do iii=1,nres
6787 c                  write (iout,'(i5,3f10.5)')
6788 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6789 c                enddo
6790       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6791 c        write (iout,*) "corr loop i",i
6792         i1=i+1
6793         num_conti=num_cont_hb(i)
6794         num_conti1=num_cont_hb(i+1)
6795         do jj=1,num_conti
6796           j=jcont_hb(jj,i)
6797           jp=iabs(j)
6798           do kk=1,num_conti1
6799             j1=jcont_hb(kk,i1)
6800             jp1=iabs(j1)
6801 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6802 c     &         ' jj=',jj,' kk=',kk
6803 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6804             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6805      &          .or. j.lt.0 .and. j1.gt.0) .and.
6806      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6807 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6808 C The system gains extra energy.
6809               n_corr=n_corr+1
6810               sqd1=dsqrt(d_cont(jj,i))
6811               sqd2=dsqrt(d_cont(kk,i1))
6812               sred_geom = sqd1*sqd2
6813               IF (sred_geom.lt.cutoff_corr) THEN
6814                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6815      &            ekont,fprimcont)
6816 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6817 cd     &         ' jj=',jj,' kk=',kk
6818                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6819                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6820                 do l=1,3
6821                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6822                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6823                 enddo
6824                 n_corr1=n_corr1+1
6825 cd               write (iout,*) 'sred_geom=',sred_geom,
6826 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6827 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6828 cd               write (iout,*) "g_contij",g_contij
6829 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6830 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6831                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6832                 if (wcorr4.gt.0.0d0)
6833      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6834                   if (energy_dec.and.wcorr4.gt.0.0d0)
6835      1                 write (iout,'(a6,4i5,0pf7.3)')
6836      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6837 c                write (iout,*) "gradcorr5 before eello5"
6838 c                do iii=1,nres
6839 c                  write (iout,'(i5,3f10.5)')
6840 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6841 c                enddo
6842                 if (wcorr5.gt.0.0d0)
6843      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6844 c                write (iout,*) "gradcorr5 after eello5"
6845 c                do iii=1,nres
6846 c                  write (iout,'(i5,3f10.5)')
6847 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6848 c                enddo
6849                   if (energy_dec.and.wcorr5.gt.0.0d0)
6850      1                 write (iout,'(a6,4i5,0pf7.3)')
6851      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6852 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6853 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6854                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6855      &               .or. wturn6.eq.0.0d0))then
6856 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6857                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6858                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6859      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6860 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6861 cd     &            'ecorr6=',ecorr6
6862 cd                write (iout,'(4e15.5)') sred_geom,
6863 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6864 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6865 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6866                 else if (wturn6.gt.0.0d0
6867      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6868 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6869                   eturn6=eturn6+eello_turn6(i,jj,kk)
6870                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6871      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6872 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6873                 endif
6874               ENDIF
6875 1111          continue
6876             endif
6877           enddo ! kk
6878         enddo ! jj
6879       enddo ! i
6880       do i=1,nres
6881         num_cont_hb(i)=num_cont_hb_old(i)
6882       enddo
6883 c                write (iout,*) "gradcorr5 in eello5"
6884 c                do iii=1,nres
6885 c                  write (iout,'(i5,3f10.5)')
6886 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6887 c                enddo
6888       return
6889       end
6890 c------------------------------------------------------------------------------
6891       subroutine add_hb_contact_eello(ii,jj,itask)
6892       implicit real*8 (a-h,o-z)
6893       include "DIMENSIONS"
6894       include "COMMON.IOUNITS"
6895       integer max_cont
6896       integer max_dim
6897       parameter (max_cont=maxconts)
6898       parameter (max_dim=70)
6899       include "COMMON.CONTACTS"
6900       double precision zapas(max_dim,maxconts,max_fg_procs),
6901      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6902       common /przechowalnia/ zapas
6903       integer i,j,ii,jj,iproc,itask(4),nn
6904 c      write (iout,*) "itask",itask
6905       do i=1,2
6906         iproc=itask(i)
6907         if (iproc.gt.0) then
6908           do j=1,num_cont_hb(ii)
6909             jjc=jcont_hb(j,ii)
6910 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6911             if (jjc.eq.jj) then
6912               ncont_sent(iproc)=ncont_sent(iproc)+1
6913               nn=ncont_sent(iproc)
6914               zapas(1,nn,iproc)=ii
6915               zapas(2,nn,iproc)=jjc
6916               zapas(3,nn,iproc)=d_cont(j,ii)
6917               ind=3
6918               do kk=1,3
6919                 ind=ind+1
6920                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6921               enddo
6922               do kk=1,2
6923                 do ll=1,2
6924                   ind=ind+1
6925                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6926                 enddo
6927               enddo
6928               do jj=1,5
6929                 do kk=1,3
6930                   do ll=1,2
6931                     do mm=1,2
6932                       ind=ind+1
6933                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6934                     enddo
6935                   enddo
6936                 enddo
6937               enddo
6938               exit
6939             endif
6940           enddo
6941         endif
6942       enddo
6943       return
6944       end
6945 c------------------------------------------------------------------------------
6946       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6947       implicit real*8 (a-h,o-z)
6948       include 'DIMENSIONS'
6949       include 'COMMON.IOUNITS'
6950       include 'COMMON.DERIV'
6951       include 'COMMON.INTERACT'
6952       include 'COMMON.CONTACTS'
6953       double precision gx(3),gx1(3)
6954       logical lprn
6955       lprn=.false.
6956       eij=facont_hb(jj,i)
6957       ekl=facont_hb(kk,k)
6958       ees0pij=ees0p(jj,i)
6959       ees0pkl=ees0p(kk,k)
6960       ees0mij=ees0m(jj,i)
6961       ees0mkl=ees0m(kk,k)
6962       ekont=eij*ekl
6963       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6964 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6965 C Following 4 lines for diagnostics.
6966 cd    ees0pkl=0.0D0
6967 cd    ees0pij=1.0D0
6968 cd    ees0mkl=0.0D0
6969 cd    ees0mij=1.0D0
6970 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6971 c     & 'Contacts ',i,j,
6972 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6973 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6974 c     & 'gradcorr_long'
6975 C Calculate the multi-body contribution to energy.
6976 c      ecorr=ecorr+ekont*ees
6977 C Calculate multi-body contributions to the gradient.
6978       coeffpees0pij=coeffp*ees0pij
6979       coeffmees0mij=coeffm*ees0mij
6980       coeffpees0pkl=coeffp*ees0pkl
6981       coeffmees0mkl=coeffm*ees0mkl
6982       do ll=1,3
6983 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6984         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6985      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6986      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6987         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6988      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6989      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6990 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6991         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6992      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6993      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6994         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6995      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6996      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6997         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6998      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6999      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7000         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7001         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7002         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7003      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7004      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7005         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7006         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7007 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7008       enddo
7009 c      write (iout,*)
7010 cgrad      do m=i+1,j-1
7011 cgrad        do ll=1,3
7012 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7013 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7014 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7015 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7016 cgrad        enddo
7017 cgrad      enddo
7018 cgrad      do m=k+1,l-1
7019 cgrad        do ll=1,3
7020 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7021 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7022 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7023 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7024 cgrad        enddo
7025 cgrad      enddo
7026 c      write (iout,*) "ehbcorr",ekont*ees
7027       ehbcorr=ekont*ees
7028       return
7029       end
7030 #ifdef MOMENT
7031 C---------------------------------------------------------------------------
7032       subroutine dipole(i,j,jj)
7033       implicit real*8 (a-h,o-z)
7034       include 'DIMENSIONS'
7035       include 'COMMON.IOUNITS'
7036       include 'COMMON.CHAIN'
7037       include 'COMMON.FFIELD'
7038       include 'COMMON.DERIV'
7039       include 'COMMON.INTERACT'
7040       include 'COMMON.CONTACTS'
7041       include 'COMMON.TORSION'
7042       include 'COMMON.VAR'
7043       include 'COMMON.GEO'
7044       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7045      &  auxmat(2,2)
7046       iti1 = itortyp(itype(i+1))
7047       if (j.lt.nres-1) then
7048         itj1 = itortyp(itype(j+1))
7049       else
7050         itj1=ntortyp+1
7051       endif
7052       do iii=1,2
7053         dipi(iii,1)=Ub2(iii,i)
7054         dipderi(iii)=Ub2der(iii,i)
7055         dipi(iii,2)=b1(iii,iti1)
7056         dipj(iii,1)=Ub2(iii,j)
7057         dipderj(iii)=Ub2der(iii,j)
7058         dipj(iii,2)=b1(iii,itj1)
7059       enddo
7060       kkk=0
7061       do iii=1,2
7062         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7063         do jjj=1,2
7064           kkk=kkk+1
7065           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7066         enddo
7067       enddo
7068       do kkk=1,5
7069         do lll=1,3
7070           mmm=0
7071           do iii=1,2
7072             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7073      &        auxvec(1))
7074             do jjj=1,2
7075               mmm=mmm+1
7076               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7077             enddo
7078           enddo
7079         enddo
7080       enddo
7081       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7082       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7083       do iii=1,2
7084         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7085       enddo
7086       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7087       do iii=1,2
7088         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7089       enddo
7090       return
7091       end
7092 #endif
7093 C---------------------------------------------------------------------------
7094       subroutine calc_eello(i,j,k,l,jj,kk)
7095 C
7096 C This subroutine computes matrices and vectors needed to calculate
7097 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7098 C
7099       implicit real*8 (a-h,o-z)
7100       include 'DIMENSIONS'
7101       include 'COMMON.IOUNITS'
7102       include 'COMMON.CHAIN'
7103       include 'COMMON.DERIV'
7104       include 'COMMON.INTERACT'
7105       include 'COMMON.CONTACTS'
7106       include 'COMMON.TORSION'
7107       include 'COMMON.VAR'
7108       include 'COMMON.GEO'
7109       include 'COMMON.FFIELD'
7110       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7111      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7112       logical lprn
7113       common /kutas/ lprn
7114 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7115 cd     & ' jj=',jj,' kk=',kk
7116 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7117 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7118 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7119       do iii=1,2
7120         do jjj=1,2
7121           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7122           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7123         enddo
7124       enddo
7125       call transpose2(aa1(1,1),aa1t(1,1))
7126       call transpose2(aa2(1,1),aa2t(1,1))
7127       do kkk=1,5
7128         do lll=1,3
7129           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7130      &      aa1tder(1,1,lll,kkk))
7131           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7132      &      aa2tder(1,1,lll,kkk))
7133         enddo
7134       enddo
7135       if (l.eq.j+1) then
7136 C parallel orientation of the two CA-CA-CA frames.
7137         if (i.gt.1) then
7138           iti=itortyp(itype(i))
7139         else
7140           iti=ntortyp+1
7141         endif
7142         itk1=itortyp(itype(k+1))
7143         itj=itortyp(itype(j))
7144         if (l.lt.nres-1) then
7145           itl1=itortyp(itype(l+1))
7146         else
7147           itl1=ntortyp+1
7148         endif
7149 C A1 kernel(j+1) A2T
7150 cd        do iii=1,2
7151 cd          write (iout,'(3f10.5,5x,3f10.5)')
7152 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7153 cd        enddo
7154         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7155      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7156      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7157 C Following matrices are needed only for 6-th order cumulants
7158         IF (wcorr6.gt.0.0d0) THEN
7159         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7160      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7161      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7162         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7163      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7164      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7165      &   ADtEAderx(1,1,1,1,1,1))
7166         lprn=.false.
7167         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7168      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7169      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7170      &   ADtEA1derx(1,1,1,1,1,1))
7171         ENDIF
7172 C End 6-th order cumulants
7173 cd        lprn=.false.
7174 cd        if (lprn) then
7175 cd        write (2,*) 'In calc_eello6'
7176 cd        do iii=1,2
7177 cd          write (2,*) 'iii=',iii
7178 cd          do kkk=1,5
7179 cd            write (2,*) 'kkk=',kkk
7180 cd            do jjj=1,2
7181 cd              write (2,'(3(2f10.5),5x)')
7182 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7183 cd            enddo
7184 cd          enddo
7185 cd        enddo
7186 cd        endif
7187         call transpose2(EUgder(1,1,k),auxmat(1,1))
7188         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7189         call transpose2(EUg(1,1,k),auxmat(1,1))
7190         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7191         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7192         do iii=1,2
7193           do kkk=1,5
7194             do lll=1,3
7195               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7196      &          EAEAderx(1,1,lll,kkk,iii,1))
7197             enddo
7198           enddo
7199         enddo
7200 C A1T kernel(i+1) A2
7201         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7202      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7203      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7204 C Following matrices are needed only for 6-th order cumulants
7205         IF (wcorr6.gt.0.0d0) THEN
7206         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7207      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7208      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7209         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7210      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7211      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7212      &   ADtEAderx(1,1,1,1,1,2))
7213         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7214      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7215      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7216      &   ADtEA1derx(1,1,1,1,1,2))
7217         ENDIF
7218 C End 6-th order cumulants
7219         call transpose2(EUgder(1,1,l),auxmat(1,1))
7220         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7221         call transpose2(EUg(1,1,l),auxmat(1,1))
7222         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7223         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7224         do iii=1,2
7225           do kkk=1,5
7226             do lll=1,3
7227               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7228      &          EAEAderx(1,1,lll,kkk,iii,2))
7229             enddo
7230           enddo
7231         enddo
7232 C AEAb1 and AEAb2
7233 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7234 C They are needed only when the fifth- or the sixth-order cumulants are
7235 C indluded.
7236         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7237         call transpose2(AEA(1,1,1),auxmat(1,1))
7238         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7239         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7240         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7241         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7242         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7243         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7244         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7245         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7246         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7247         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7248         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7249         call transpose2(AEA(1,1,2),auxmat(1,1))
7250         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7251         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7252         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7253         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7254         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7255         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7256         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7257         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7258         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7259         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7260         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7261 C Calculate the Cartesian derivatives of the vectors.
7262         do iii=1,2
7263           do kkk=1,5
7264             do lll=1,3
7265               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7266               call matvec2(auxmat(1,1),b1(1,iti),
7267      &          AEAb1derx(1,lll,kkk,iii,1,1))
7268               call matvec2(auxmat(1,1),Ub2(1,i),
7269      &          AEAb2derx(1,lll,kkk,iii,1,1))
7270               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7271      &          AEAb1derx(1,lll,kkk,iii,2,1))
7272               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7273      &          AEAb2derx(1,lll,kkk,iii,2,1))
7274               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7275               call matvec2(auxmat(1,1),b1(1,itj),
7276      &          AEAb1derx(1,lll,kkk,iii,1,2))
7277               call matvec2(auxmat(1,1),Ub2(1,j),
7278      &          AEAb2derx(1,lll,kkk,iii,1,2))
7279               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7280      &          AEAb1derx(1,lll,kkk,iii,2,2))
7281               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7282      &          AEAb2derx(1,lll,kkk,iii,2,2))
7283             enddo
7284           enddo
7285         enddo
7286         ENDIF
7287 C End vectors
7288       else
7289 C Antiparallel orientation of the two CA-CA-CA frames.
7290         if (i.gt.1) then
7291           iti=itortyp(itype(i))
7292         else
7293           iti=ntortyp+1
7294         endif
7295         itk1=itortyp(itype(k+1))
7296         itl=itortyp(itype(l))
7297         itj=itortyp(itype(j))
7298         if (j.lt.nres-1) then
7299           itj1=itortyp(itype(j+1))
7300         else
7301           itj1=ntortyp+1
7302         endif
7303 C A2 kernel(j-1)T A1T
7304         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7305      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7306      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7307 C Following matrices are needed only for 6-th order cumulants
7308         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7309      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7310         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7311      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7312      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7313         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7314      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7315      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7316      &   ADtEAderx(1,1,1,1,1,1))
7317         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7318      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7319      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7320      &   ADtEA1derx(1,1,1,1,1,1))
7321         ENDIF
7322 C End 6-th order cumulants
7323         call transpose2(EUgder(1,1,k),auxmat(1,1))
7324         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7325         call transpose2(EUg(1,1,k),auxmat(1,1))
7326         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7327         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7328         do iii=1,2
7329           do kkk=1,5
7330             do lll=1,3
7331               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7332      &          EAEAderx(1,1,lll,kkk,iii,1))
7333             enddo
7334           enddo
7335         enddo
7336 C A2T kernel(i+1)T A1
7337         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7338      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7339      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7340 C Following matrices are needed only for 6-th order cumulants
7341         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7342      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7343         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7344      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7345      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7346         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7347      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7348      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7349      &   ADtEAderx(1,1,1,1,1,2))
7350         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7351      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7352      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7353      &   ADtEA1derx(1,1,1,1,1,2))
7354         ENDIF
7355 C End 6-th order cumulants
7356         call transpose2(EUgder(1,1,j),auxmat(1,1))
7357         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7358         call transpose2(EUg(1,1,j),auxmat(1,1))
7359         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7360         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7361         do iii=1,2
7362           do kkk=1,5
7363             do lll=1,3
7364               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7365      &          EAEAderx(1,1,lll,kkk,iii,2))
7366             enddo
7367           enddo
7368         enddo
7369 C AEAb1 and AEAb2
7370 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7371 C They are needed only when the fifth- or the sixth-order cumulants are
7372 C indluded.
7373         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7374      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7375         call transpose2(AEA(1,1,1),auxmat(1,1))
7376         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7377         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7378         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7379         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7380         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7381         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7382         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7383         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7384         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7385         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7386         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7387         call transpose2(AEA(1,1,2),auxmat(1,1))
7388         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7389         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7390         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7391         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7392         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7393         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7394         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7395         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7396         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7397         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7398         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7399 C Calculate the Cartesian derivatives of the vectors.
7400         do iii=1,2
7401           do kkk=1,5
7402             do lll=1,3
7403               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7404               call matvec2(auxmat(1,1),b1(1,iti),
7405      &          AEAb1derx(1,lll,kkk,iii,1,1))
7406               call matvec2(auxmat(1,1),Ub2(1,i),
7407      &          AEAb2derx(1,lll,kkk,iii,1,1))
7408               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7409      &          AEAb1derx(1,lll,kkk,iii,2,1))
7410               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7411      &          AEAb2derx(1,lll,kkk,iii,2,1))
7412               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7413               call matvec2(auxmat(1,1),b1(1,itl),
7414      &          AEAb1derx(1,lll,kkk,iii,1,2))
7415               call matvec2(auxmat(1,1),Ub2(1,l),
7416      &          AEAb2derx(1,lll,kkk,iii,1,2))
7417               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7418      &          AEAb1derx(1,lll,kkk,iii,2,2))
7419               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7420      &          AEAb2derx(1,lll,kkk,iii,2,2))
7421             enddo
7422           enddo
7423         enddo
7424         ENDIF
7425 C End vectors
7426       endif
7427       return
7428       end
7429 C---------------------------------------------------------------------------
7430       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7431      &  KK,KKderg,AKA,AKAderg,AKAderx)
7432       implicit none
7433       integer nderg
7434       logical transp
7435       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7436      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7437      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7438       integer iii,kkk,lll
7439       integer jjj,mmm
7440       logical lprn
7441       common /kutas/ lprn
7442       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7443       do iii=1,nderg
7444         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7445      &    AKAderg(1,1,iii))
7446       enddo
7447 cd      if (lprn) write (2,*) 'In kernel'
7448       do kkk=1,5
7449 cd        if (lprn) write (2,*) 'kkk=',kkk
7450         do lll=1,3
7451           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7452      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7453 cd          if (lprn) then
7454 cd            write (2,*) 'lll=',lll
7455 cd            write (2,*) 'iii=1'
7456 cd            do jjj=1,2
7457 cd              write (2,'(3(2f10.5),5x)')
7458 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7459 cd            enddo
7460 cd          endif
7461           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7462      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7463 cd          if (lprn) then
7464 cd            write (2,*) 'lll=',lll
7465 cd            write (2,*) 'iii=2'
7466 cd            do jjj=1,2
7467 cd              write (2,'(3(2f10.5),5x)')
7468 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7469 cd            enddo
7470 cd          endif
7471         enddo
7472       enddo
7473       return
7474       end
7475 C---------------------------------------------------------------------------
7476       double precision function eello4(i,j,k,l,jj,kk)
7477       implicit real*8 (a-h,o-z)
7478       include 'DIMENSIONS'
7479       include 'COMMON.IOUNITS'
7480       include 'COMMON.CHAIN'
7481       include 'COMMON.DERIV'
7482       include 'COMMON.INTERACT'
7483       include 'COMMON.CONTACTS'
7484       include 'COMMON.TORSION'
7485       include 'COMMON.VAR'
7486       include 'COMMON.GEO'
7487       double precision pizda(2,2),ggg1(3),ggg2(3)
7488 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7489 cd        eello4=0.0d0
7490 cd        return
7491 cd      endif
7492 cd      print *,'eello4:',i,j,k,l,jj,kk
7493 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7494 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7495 cold      eij=facont_hb(jj,i)
7496 cold      ekl=facont_hb(kk,k)
7497 cold      ekont=eij*ekl
7498       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7499 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7500       gcorr_loc(k-1)=gcorr_loc(k-1)
7501      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7502       if (l.eq.j+1) then
7503         gcorr_loc(l-1)=gcorr_loc(l-1)
7504      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7505       else
7506         gcorr_loc(j-1)=gcorr_loc(j-1)
7507      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7508       endif
7509       do iii=1,2
7510         do kkk=1,5
7511           do lll=1,3
7512             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7513      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7514 cd            derx(lll,kkk,iii)=0.0d0
7515           enddo
7516         enddo
7517       enddo
7518 cd      gcorr_loc(l-1)=0.0d0
7519 cd      gcorr_loc(j-1)=0.0d0
7520 cd      gcorr_loc(k-1)=0.0d0
7521 cd      eel4=1.0d0
7522 cd      write (iout,*)'Contacts have occurred for peptide groups',
7523 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7524 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7525       if (j.lt.nres-1) then
7526         j1=j+1
7527         j2=j-1
7528       else
7529         j1=j-1
7530         j2=j-2
7531       endif
7532       if (l.lt.nres-1) then
7533         l1=l+1
7534         l2=l-1
7535       else
7536         l1=l-1
7537         l2=l-2
7538       endif
7539       do ll=1,3
7540 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7541 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7542         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7543         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7544 cgrad        ghalf=0.5d0*ggg1(ll)
7545         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7546         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7547         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7548         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7549         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7550         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7551 cgrad        ghalf=0.5d0*ggg2(ll)
7552         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7553         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7554         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7555         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7556         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7557         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7558       enddo
7559 cgrad      do m=i+1,j-1
7560 cgrad        do ll=1,3
7561 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7562 cgrad        enddo
7563 cgrad      enddo
7564 cgrad      do m=k+1,l-1
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cgrad      do m=i+2,j2
7570 cgrad        do ll=1,3
7571 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7572 cgrad        enddo
7573 cgrad      enddo
7574 cgrad      do m=k+2,l2
7575 cgrad        do ll=1,3
7576 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7577 cgrad        enddo
7578 cgrad      enddo
7579 cd      do iii=1,nres-3
7580 cd        write (2,*) iii,gcorr_loc(iii)
7581 cd      enddo
7582       eello4=ekont*eel4
7583 cd      write (2,*) 'ekont',ekont
7584 cd      write (iout,*) 'eello4',ekont*eel4
7585       return
7586       end
7587 C---------------------------------------------------------------------------
7588       double precision function eello5(i,j,k,l,jj,kk)
7589       implicit real*8 (a-h,o-z)
7590       include 'DIMENSIONS'
7591       include 'COMMON.IOUNITS'
7592       include 'COMMON.CHAIN'
7593       include 'COMMON.DERIV'
7594       include 'COMMON.INTERACT'
7595       include 'COMMON.CONTACTS'
7596       include 'COMMON.TORSION'
7597       include 'COMMON.VAR'
7598       include 'COMMON.GEO'
7599       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7600       double precision ggg1(3),ggg2(3)
7601 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7602 C                                                                              C
7603 C                            Parallel chains                                   C
7604 C                                                                              C
7605 C          o             o                   o             o                   C
7606 C         /l\           / \             \   / \           / \   /              C
7607 C        /   \         /   \             \ /   \         /   \ /               C
7608 C       j| o |l1       | o |              o| o |         | o |o                C
7609 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7610 C      \i/   \         /   \ /             /   \         /   \                 C
7611 C       o    k1             o                                                  C
7612 C         (I)          (II)                (III)          (IV)                 C
7613 C                                                                              C
7614 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7615 C                                                                              C
7616 C                            Antiparallel chains                               C
7617 C                                                                              C
7618 C          o             o                   o             o                   C
7619 C         /j\           / \             \   / \           / \   /              C
7620 C        /   \         /   \             \ /   \         /   \ /               C
7621 C      j1| o |l        | o |              o| o |         | o |o                C
7622 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7623 C      \i/   \         /   \ /             /   \         /   \                 C
7624 C       o     k1            o                                                  C
7625 C         (I)          (II)                (III)          (IV)                 C
7626 C                                                                              C
7627 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7628 C                                                                              C
7629 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7630 C                                                                              C
7631 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7632 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7633 cd        eello5=0.0d0
7634 cd        return
7635 cd      endif
7636 cd      write (iout,*)
7637 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7638 cd     &   ' and',k,l
7639       itk=itortyp(itype(k))
7640       itl=itortyp(itype(l))
7641       itj=itortyp(itype(j))
7642       eello5_1=0.0d0
7643       eello5_2=0.0d0
7644       eello5_3=0.0d0
7645       eello5_4=0.0d0
7646 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7647 cd     &   eel5_3_num,eel5_4_num)
7648       do iii=1,2
7649         do kkk=1,5
7650           do lll=1,3
7651             derx(lll,kkk,iii)=0.0d0
7652           enddo
7653         enddo
7654       enddo
7655 cd      eij=facont_hb(jj,i)
7656 cd      ekl=facont_hb(kk,k)
7657 cd      ekont=eij*ekl
7658 cd      write (iout,*)'Contacts have occurred for peptide groups',
7659 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7660 cd      goto 1111
7661 C Contribution from the graph I.
7662 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7663 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7664       call transpose2(EUg(1,1,k),auxmat(1,1))
7665       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)-pizda(2,2)
7667       vv(2)=pizda(1,2)+pizda(2,1)
7668       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7669      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7670 C Explicit gradient in virtual-dihedral angles.
7671       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7672      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7673      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7674       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7675       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7676       vv(1)=pizda(1,1)-pizda(2,2)
7677       vv(2)=pizda(1,2)+pizda(2,1)
7678       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7679      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7680      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7681       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7682       vv(1)=pizda(1,1)-pizda(2,2)
7683       vv(2)=pizda(1,2)+pizda(2,1)
7684       if (l.eq.j+1) then
7685         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7686      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7687      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7688       else
7689         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7690      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7692       endif
7693 C Cartesian gradient
7694       do iii=1,2
7695         do kkk=1,5
7696           do lll=1,3
7697             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7698      &        pizda(1,1))
7699             vv(1)=pizda(1,1)-pizda(2,2)
7700             vv(2)=pizda(1,2)+pizda(2,1)
7701             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7702      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7703      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7704           enddo
7705         enddo
7706       enddo
7707 c      goto 1112
7708 c1111  continue
7709 C Contribution from graph II
7710       call transpose2(EE(1,1,itk),auxmat(1,1))
7711       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7712       vv(1)=pizda(1,1)+pizda(2,2)
7713       vv(2)=pizda(2,1)-pizda(1,2)
7714       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7715      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7716 C Explicit gradient in virtual-dihedral angles.
7717       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7718      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7719       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7720       vv(1)=pizda(1,1)+pizda(2,2)
7721       vv(2)=pizda(2,1)-pizda(1,2)
7722       if (l.eq.j+1) then
7723         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7724      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7725      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7726       else
7727         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7728      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7729      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7730       endif
7731 C Cartesian gradient
7732       do iii=1,2
7733         do kkk=1,5
7734           do lll=1,3
7735             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7736      &        pizda(1,1))
7737             vv(1)=pizda(1,1)+pizda(2,2)
7738             vv(2)=pizda(2,1)-pizda(1,2)
7739             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7740      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7741      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7742           enddo
7743         enddo
7744       enddo
7745 cd      goto 1112
7746 cd1111  continue
7747       if (l.eq.j+1) then
7748 cd        goto 1110
7749 C Parallel orientation
7750 C Contribution from graph III
7751         call transpose2(EUg(1,1,l),auxmat(1,1))
7752         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7753         vv(1)=pizda(1,1)-pizda(2,2)
7754         vv(2)=pizda(1,2)+pizda(2,1)
7755         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7756      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7757 C Explicit gradient in virtual-dihedral angles.
7758         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7759      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7760      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7761         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7762         vv(1)=pizda(1,1)-pizda(2,2)
7763         vv(2)=pizda(1,2)+pizda(2,1)
7764         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7765      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7766      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7767         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7768         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7769         vv(1)=pizda(1,1)-pizda(2,2)
7770         vv(2)=pizda(1,2)+pizda(2,1)
7771         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7772      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7773      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7774 C Cartesian gradient
7775         do iii=1,2
7776           do kkk=1,5
7777             do lll=1,3
7778               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7779      &          pizda(1,1))
7780               vv(1)=pizda(1,1)-pizda(2,2)
7781               vv(2)=pizda(1,2)+pizda(2,1)
7782               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7783      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7784      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7785             enddo
7786           enddo
7787         enddo
7788 cd        goto 1112
7789 C Contribution from graph IV
7790 cd1110    continue
7791         call transpose2(EE(1,1,itl),auxmat(1,1))
7792         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7793         vv(1)=pizda(1,1)+pizda(2,2)
7794         vv(2)=pizda(2,1)-pizda(1,2)
7795         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7796      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7797 C Explicit gradient in virtual-dihedral angles.
7798         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7799      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7800         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7801         vv(1)=pizda(1,1)+pizda(2,2)
7802         vv(2)=pizda(2,1)-pizda(1,2)
7803         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7804      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7805      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7806 C Cartesian gradient
7807         do iii=1,2
7808           do kkk=1,5
7809             do lll=1,3
7810               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7811      &          pizda(1,1))
7812               vv(1)=pizda(1,1)+pizda(2,2)
7813               vv(2)=pizda(2,1)-pizda(1,2)
7814               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7815      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7816      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7817             enddo
7818           enddo
7819         enddo
7820       else
7821 C Antiparallel orientation
7822 C Contribution from graph III
7823 c        goto 1110
7824         call transpose2(EUg(1,1,j),auxmat(1,1))
7825         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7826         vv(1)=pizda(1,1)-pizda(2,2)
7827         vv(2)=pizda(1,2)+pizda(2,1)
7828         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7829      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7830 C Explicit gradient in virtual-dihedral angles.
7831         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7832      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7833      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7834         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7835         vv(1)=pizda(1,1)-pizda(2,2)
7836         vv(2)=pizda(1,2)+pizda(2,1)
7837         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7838      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7839      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7840         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7841         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7842         vv(1)=pizda(1,1)-pizda(2,2)
7843         vv(2)=pizda(1,2)+pizda(2,1)
7844         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7845      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7846      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7847 C Cartesian gradient
7848         do iii=1,2
7849           do kkk=1,5
7850             do lll=1,3
7851               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7852      &          pizda(1,1))
7853               vv(1)=pizda(1,1)-pizda(2,2)
7854               vv(2)=pizda(1,2)+pizda(2,1)
7855               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7856      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7857      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7858             enddo
7859           enddo
7860         enddo
7861 cd        goto 1112
7862 C Contribution from graph IV
7863 1110    continue
7864         call transpose2(EE(1,1,itj),auxmat(1,1))
7865         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7866         vv(1)=pizda(1,1)+pizda(2,2)
7867         vv(2)=pizda(2,1)-pizda(1,2)
7868         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7869      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7870 C Explicit gradient in virtual-dihedral angles.
7871         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7872      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7873         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7874         vv(1)=pizda(1,1)+pizda(2,2)
7875         vv(2)=pizda(2,1)-pizda(1,2)
7876         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7877      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7878      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7879 C Cartesian gradient
7880         do iii=1,2
7881           do kkk=1,5
7882             do lll=1,3
7883               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7884      &          pizda(1,1))
7885               vv(1)=pizda(1,1)+pizda(2,2)
7886               vv(2)=pizda(2,1)-pizda(1,2)
7887               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7888      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7889      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7890             enddo
7891           enddo
7892         enddo
7893       endif
7894 1112  continue
7895       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7896 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7897 cd        write (2,*) 'ijkl',i,j,k,l
7898 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7899 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7900 cd      endif
7901 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7902 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7903 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7904 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7905       if (j.lt.nres-1) then
7906         j1=j+1
7907         j2=j-1
7908       else
7909         j1=j-1
7910         j2=j-2
7911       endif
7912       if (l.lt.nres-1) then
7913         l1=l+1
7914         l2=l-1
7915       else
7916         l1=l-1
7917         l2=l-2
7918       endif
7919 cd      eij=1.0d0
7920 cd      ekl=1.0d0
7921 cd      ekont=1.0d0
7922 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7923 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7924 C        summed up outside the subrouine as for the other subroutines
7925 C        handling long-range interactions. The old code is commented out
7926 C        with "cgrad" to keep track of changes.
7927       do ll=1,3
7928 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7929 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7930         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7931         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7932 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7933 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7934 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7935 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7936 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7937 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7938 c     &   gradcorr5ij,
7939 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7940 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7941 cgrad        ghalf=0.5d0*ggg1(ll)
7942 cd        ghalf=0.0d0
7943         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7944         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7945         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7946         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7947         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7948         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7949 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7950 cgrad        ghalf=0.5d0*ggg2(ll)
7951 cd        ghalf=0.0d0
7952         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7953         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7954         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7955         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7956         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7957         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7958       enddo
7959 cd      goto 1112
7960 cgrad      do m=i+1,j-1
7961 cgrad        do ll=1,3
7962 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7963 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7964 cgrad        enddo
7965 cgrad      enddo
7966 cgrad      do m=k+1,l-1
7967 cgrad        do ll=1,3
7968 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7969 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7970 cgrad        enddo
7971 cgrad      enddo
7972 c1112  continue
7973 cgrad      do m=i+2,j2
7974 cgrad        do ll=1,3
7975 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7976 cgrad        enddo
7977 cgrad      enddo
7978 cgrad      do m=k+2,l2
7979 cgrad        do ll=1,3
7980 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7981 cgrad        enddo
7982 cgrad      enddo
7983 cd      do iii=1,nres-3
7984 cd        write (2,*) iii,g_corr5_loc(iii)
7985 cd      enddo
7986       eello5=ekont*eel5
7987 cd      write (2,*) 'ekont',ekont
7988 cd      write (iout,*) 'eello5',ekont*eel5
7989       return
7990       end
7991 c--------------------------------------------------------------------------
7992       double precision function eello6(i,j,k,l,jj,kk)
7993       implicit real*8 (a-h,o-z)
7994       include 'DIMENSIONS'
7995       include 'COMMON.IOUNITS'
7996       include 'COMMON.CHAIN'
7997       include 'COMMON.DERIV'
7998       include 'COMMON.INTERACT'
7999       include 'COMMON.CONTACTS'
8000       include 'COMMON.TORSION'
8001       include 'COMMON.VAR'
8002       include 'COMMON.GEO'
8003       include 'COMMON.FFIELD'
8004       double precision ggg1(3),ggg2(3)
8005 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8006 cd        eello6=0.0d0
8007 cd        return
8008 cd      endif
8009 cd      write (iout,*)
8010 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8011 cd     &   ' and',k,l
8012       eello6_1=0.0d0
8013       eello6_2=0.0d0
8014       eello6_3=0.0d0
8015       eello6_4=0.0d0
8016       eello6_5=0.0d0
8017       eello6_6=0.0d0
8018 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8019 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8020       do iii=1,2
8021         do kkk=1,5
8022           do lll=1,3
8023             derx(lll,kkk,iii)=0.0d0
8024           enddo
8025         enddo
8026       enddo
8027 cd      eij=facont_hb(jj,i)
8028 cd      ekl=facont_hb(kk,k)
8029 cd      ekont=eij*ekl
8030 cd      eij=1.0d0
8031 cd      ekl=1.0d0
8032 cd      ekont=1.0d0
8033       if (l.eq.j+1) then
8034         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8035         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8036         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8037         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8038         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8039         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8040       else
8041         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8042         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8043         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8044         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8045         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8046           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8047         else
8048           eello6_5=0.0d0
8049         endif
8050         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8051       endif
8052 C If turn contributions are considered, they will be handled separately.
8053       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8054 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8055 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8056 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8057 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8058 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8059 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8060 cd      goto 1112
8061       if (j.lt.nres-1) then
8062         j1=j+1
8063         j2=j-1
8064       else
8065         j1=j-1
8066         j2=j-2
8067       endif
8068       if (l.lt.nres-1) then
8069         l1=l+1
8070         l2=l-1
8071       else
8072         l1=l-1
8073         l2=l-2
8074       endif
8075       do ll=1,3
8076 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8077 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8078 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8079 cgrad        ghalf=0.5d0*ggg1(ll)
8080 cd        ghalf=0.0d0
8081         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8082         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8083         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8084         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8085         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8086         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8087         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8088         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8089 cgrad        ghalf=0.5d0*ggg2(ll)
8090 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8091 cd        ghalf=0.0d0
8092         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8093         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8094         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8095         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8096         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8097         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8098       enddo
8099 cd      goto 1112
8100 cgrad      do m=i+1,j-1
8101 cgrad        do ll=1,3
8102 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8103 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8104 cgrad        enddo
8105 cgrad      enddo
8106 cgrad      do m=k+1,l-1
8107 cgrad        do ll=1,3
8108 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8109 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8110 cgrad        enddo
8111 cgrad      enddo
8112 cgrad1112  continue
8113 cgrad      do m=i+2,j2
8114 cgrad        do ll=1,3
8115 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8116 cgrad        enddo
8117 cgrad      enddo
8118 cgrad      do m=k+2,l2
8119 cgrad        do ll=1,3
8120 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8121 cgrad        enddo
8122 cgrad      enddo
8123 cd      do iii=1,nres-3
8124 cd        write (2,*) iii,g_corr6_loc(iii)
8125 cd      enddo
8126       eello6=ekont*eel6
8127 cd      write (2,*) 'ekont',ekont
8128 cd      write (iout,*) 'eello6',ekont*eel6
8129       return
8130       end
8131 c--------------------------------------------------------------------------
8132       double precision function eello6_graph1(i,j,k,l,imat,swap)
8133       implicit real*8 (a-h,o-z)
8134       include 'DIMENSIONS'
8135       include 'COMMON.IOUNITS'
8136       include 'COMMON.CHAIN'
8137       include 'COMMON.DERIV'
8138       include 'COMMON.INTERACT'
8139       include 'COMMON.CONTACTS'
8140       include 'COMMON.TORSION'
8141       include 'COMMON.VAR'
8142       include 'COMMON.GEO'
8143       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8144       logical swap
8145       logical lprn
8146       common /kutas/ lprn
8147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8148 C
8149 C      Parallel       Antiparallel
8150 C
8151 C          o             o
8152 C         /l\           /j\
8153 C        /   \         /   \
8154 C       /| o |         | o |\
8155 C     \ j|/k\|  /   \  |/k\|l /
8156 C      \ /   \ /     \ /   \ /
8157 C       o     o       o     o
8158 C       i             i
8159 C
8160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8161       itk=itortyp(itype(k))
8162       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8163       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8164       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8165       call transpose2(EUgC(1,1,k),auxmat(1,1))
8166       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8167       vv1(1)=pizda1(1,1)-pizda1(2,2)
8168       vv1(2)=pizda1(1,2)+pizda1(2,1)
8169       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8170       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8171       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8172       s5=scalar2(vv(1),Dtobr2(1,i))
8173 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8174       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8175       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8176      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8177      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8178      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8179      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8180      & +scalar2(vv(1),Dtobr2der(1,i)))
8181       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8182       vv1(1)=pizda1(1,1)-pizda1(2,2)
8183       vv1(2)=pizda1(1,2)+pizda1(2,1)
8184       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8185       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8186       if (l.eq.j+1) then
8187         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8188      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8189      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8190      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8191      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8192       else
8193         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8194      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8195      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8196      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8197      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8198       endif
8199       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8200       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8201       vv1(1)=pizda1(1,1)-pizda1(2,2)
8202       vv1(2)=pizda1(1,2)+pizda1(2,1)
8203       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8204      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8205      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8206      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8207       do iii=1,2
8208         if (swap) then
8209           ind=3-iii
8210         else
8211           ind=iii
8212         endif
8213         do kkk=1,5
8214           do lll=1,3
8215             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8216             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8217             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8218             call transpose2(EUgC(1,1,k),auxmat(1,1))
8219             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8220      &        pizda1(1,1))
8221             vv1(1)=pizda1(1,1)-pizda1(2,2)
8222             vv1(2)=pizda1(1,2)+pizda1(2,1)
8223             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8224             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8225      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8226             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8227      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8228             s5=scalar2(vv(1),Dtobr2(1,i))
8229             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8230           enddo
8231         enddo
8232       enddo
8233       return
8234       end
8235 c----------------------------------------------------------------------------
8236       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8237       implicit real*8 (a-h,o-z)
8238       include 'DIMENSIONS'
8239       include 'COMMON.IOUNITS'
8240       include 'COMMON.CHAIN'
8241       include 'COMMON.DERIV'
8242       include 'COMMON.INTERACT'
8243       include 'COMMON.CONTACTS'
8244       include 'COMMON.TORSION'
8245       include 'COMMON.VAR'
8246       include 'COMMON.GEO'
8247       logical swap
8248       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8249      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8250       logical lprn
8251       common /kutas/ lprn
8252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8253 C                                                                              C
8254 C      Parallel       Antiparallel                                             C
8255 C                                                                              C
8256 C          o             o                                                     C
8257 C     \   /l\           /j\   /                                                C
8258 C      \ /   \         /   \ /                                                 C
8259 C       o| o |         | o |o                                                  C
8260 C     \ j|/k\|      \  |/k\|l                                                  C
8261 C      \ /   \       \ /   \                                                   C
8262 C       o             o                                                        C
8263 C       i             i                                                        C
8264 C                                                                              C
8265 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8266 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8267 C AL 7/4/01 s1 would occur in the sixth-order moment,
8268 C           but not in a cluster cumulant
8269 #ifdef MOMENT
8270       s1=dip(1,jj,i)*dip(1,kk,k)
8271 #endif
8272       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8273       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8274       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8275       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8276       call transpose2(EUg(1,1,k),auxmat(1,1))
8277       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8278       vv(1)=pizda(1,1)-pizda(2,2)
8279       vv(2)=pizda(1,2)+pizda(2,1)
8280       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8281 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8282 #ifdef MOMENT
8283       eello6_graph2=-(s1+s2+s3+s4)
8284 #else
8285       eello6_graph2=-(s2+s3+s4)
8286 #endif
8287 c      eello6_graph2=-s3
8288 C Derivatives in gamma(i-1)
8289       if (i.gt.1) then
8290 #ifdef MOMENT
8291         s1=dipderg(1,jj,i)*dip(1,kk,k)
8292 #endif
8293         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8294         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8295         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8296         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8297 #ifdef MOMENT
8298         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8299 #else
8300         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8301 #endif
8302 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8303       endif
8304 C Derivatives in gamma(k-1)
8305 #ifdef MOMENT
8306       s1=dip(1,jj,i)*dipderg(1,kk,k)
8307 #endif
8308       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8309       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8310       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8311       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8312       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8313       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8314       vv(1)=pizda(1,1)-pizda(2,2)
8315       vv(2)=pizda(1,2)+pizda(2,1)
8316       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8317 #ifdef MOMENT
8318       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8319 #else
8320       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8321 #endif
8322 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8323 C Derivatives in gamma(j-1) or gamma(l-1)
8324       if (j.gt.1) then
8325 #ifdef MOMENT
8326         s1=dipderg(3,jj,i)*dip(1,kk,k)
8327 #endif
8328         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8329         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8330         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8331         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8332         vv(1)=pizda(1,1)-pizda(2,2)
8333         vv(2)=pizda(1,2)+pizda(2,1)
8334         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8335 #ifdef MOMENT
8336         if (swap) then
8337           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8338         else
8339           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8340         endif
8341 #endif
8342         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8343 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8344       endif
8345 C Derivatives in gamma(l-1) or gamma(j-1)
8346       if (l.gt.1) then
8347 #ifdef MOMENT
8348         s1=dip(1,jj,i)*dipderg(3,kk,k)
8349 #endif
8350         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8351         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8352         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8353         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8354         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8355         vv(1)=pizda(1,1)-pizda(2,2)
8356         vv(2)=pizda(1,2)+pizda(2,1)
8357         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8358 #ifdef MOMENT
8359         if (swap) then
8360           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8361         else
8362           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8363         endif
8364 #endif
8365         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8366 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8367       endif
8368 C Cartesian derivatives.
8369       if (lprn) then
8370         write (2,*) 'In eello6_graph2'
8371         do iii=1,2
8372           write (2,*) 'iii=',iii
8373           do kkk=1,5
8374             write (2,*) 'kkk=',kkk
8375             do jjj=1,2
8376               write (2,'(3(2f10.5),5x)')
8377      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8378             enddo
8379           enddo
8380         enddo
8381       endif
8382       do iii=1,2
8383         do kkk=1,5
8384           do lll=1,3
8385 #ifdef MOMENT
8386             if (iii.eq.1) then
8387               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8388             else
8389               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8390             endif
8391 #endif
8392             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8393      &        auxvec(1))
8394             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8395             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8396      &        auxvec(1))
8397             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8398             call transpose2(EUg(1,1,k),auxmat(1,1))
8399             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8400      &        pizda(1,1))
8401             vv(1)=pizda(1,1)-pizda(2,2)
8402             vv(2)=pizda(1,2)+pizda(2,1)
8403             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8404 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8405 #ifdef MOMENT
8406             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8407 #else
8408             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8409 #endif
8410             if (swap) then
8411               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8412             else
8413               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8414             endif
8415           enddo
8416         enddo
8417       enddo
8418       return
8419       end
8420 c----------------------------------------------------------------------------
8421       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8422       implicit real*8 (a-h,o-z)
8423       include 'DIMENSIONS'
8424       include 'COMMON.IOUNITS'
8425       include 'COMMON.CHAIN'
8426       include 'COMMON.DERIV'
8427       include 'COMMON.INTERACT'
8428       include 'COMMON.CONTACTS'
8429       include 'COMMON.TORSION'
8430       include 'COMMON.VAR'
8431       include 'COMMON.GEO'
8432       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8433       logical swap
8434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8435 C                                                                              C
8436 C      Parallel       Antiparallel                                             C
8437 C                                                                              C
8438 C          o             o                                                     C
8439 C         /l\   /   \   /j\                                                    C
8440 C        /   \ /     \ /   \                                                   C
8441 C       /| o |o       o| o |\                                                  C
8442 C       j|/k\|  /      |/k\|l /                                                C
8443 C        /   \ /       /   \ /                                                 C
8444 C       /     o       /     o                                                  C
8445 C       i             i                                                        C
8446 C                                                                              C
8447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8448 C
8449 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8450 C           energy moment and not to the cluster cumulant.
8451       iti=itortyp(itype(i))
8452       if (j.lt.nres-1) then
8453         itj1=itortyp(itype(j+1))
8454       else
8455         itj1=ntortyp+1
8456       endif
8457       itk=itortyp(itype(k))
8458       itk1=itortyp(itype(k+1))
8459       if (l.lt.nres-1) then
8460         itl1=itortyp(itype(l+1))
8461       else
8462         itl1=ntortyp+1
8463       endif
8464 #ifdef MOMENT
8465       s1=dip(4,jj,i)*dip(4,kk,k)
8466 #endif
8467       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8468       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8469       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8470       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8471       call transpose2(EE(1,1,itk),auxmat(1,1))
8472       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8473       vv(1)=pizda(1,1)+pizda(2,2)
8474       vv(2)=pizda(2,1)-pizda(1,2)
8475       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8476 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8477 cd     & "sum",-(s2+s3+s4)
8478 #ifdef MOMENT
8479       eello6_graph3=-(s1+s2+s3+s4)
8480 #else
8481       eello6_graph3=-(s2+s3+s4)
8482 #endif
8483 c      eello6_graph3=-s4
8484 C Derivatives in gamma(k-1)
8485       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8486       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8487       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8488       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8489 C Derivatives in gamma(l-1)
8490       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8491       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8492       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8493       vv(1)=pizda(1,1)+pizda(2,2)
8494       vv(2)=pizda(2,1)-pizda(1,2)
8495       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8496       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8497 C Cartesian derivatives.
8498       do iii=1,2
8499         do kkk=1,5
8500           do lll=1,3
8501 #ifdef MOMENT
8502             if (iii.eq.1) then
8503               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8504             else
8505               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8506             endif
8507 #endif
8508             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8509      &        auxvec(1))
8510             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8511             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8512      &        auxvec(1))
8513             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8514             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8515      &        pizda(1,1))
8516             vv(1)=pizda(1,1)+pizda(2,2)
8517             vv(2)=pizda(2,1)-pizda(1,2)
8518             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8519 #ifdef MOMENT
8520             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8521 #else
8522             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8523 #endif
8524             if (swap) then
8525               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8526             else
8527               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8528             endif
8529 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8530           enddo
8531         enddo
8532       enddo
8533       return
8534       end
8535 c----------------------------------------------------------------------------
8536       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8537       implicit real*8 (a-h,o-z)
8538       include 'DIMENSIONS'
8539       include 'COMMON.IOUNITS'
8540       include 'COMMON.CHAIN'
8541       include 'COMMON.DERIV'
8542       include 'COMMON.INTERACT'
8543       include 'COMMON.CONTACTS'
8544       include 'COMMON.TORSION'
8545       include 'COMMON.VAR'
8546       include 'COMMON.GEO'
8547       include 'COMMON.FFIELD'
8548       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8549      & auxvec1(2),auxmat1(2,2)
8550       logical swap
8551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8552 C                                                                              C
8553 C      Parallel       Antiparallel                                             C
8554 C                                                                              C
8555 C          o             o                                                     C
8556 C         /l\   /   \   /j\                                                    C
8557 C        /   \ /     \ /   \                                                   C
8558 C       /| o |o       o| o |\                                                  C
8559 C     \ j|/k\|      \  |/k\|l                                                  C
8560 C      \ /   \       \ /   \                                                   C
8561 C       o     \       o     \                                                  C
8562 C       i             i                                                        C
8563 C                                                                              C
8564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8565 C
8566 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8567 C           energy moment and not to the cluster cumulant.
8568 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8569       iti=itortyp(itype(i))
8570       itj=itortyp(itype(j))
8571       if (j.lt.nres-1) then
8572         itj1=itortyp(itype(j+1))
8573       else
8574         itj1=ntortyp+1
8575       endif
8576       itk=itortyp(itype(k))
8577       if (k.lt.nres-1) then
8578         itk1=itortyp(itype(k+1))
8579       else
8580         itk1=ntortyp+1
8581       endif
8582       itl=itortyp(itype(l))
8583       if (l.lt.nres-1) then
8584         itl1=itortyp(itype(l+1))
8585       else
8586         itl1=ntortyp+1
8587       endif
8588 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8589 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8590 cd     & ' itl',itl,' itl1',itl1
8591 #ifdef MOMENT
8592       if (imat.eq.1) then
8593         s1=dip(3,jj,i)*dip(3,kk,k)
8594       else
8595         s1=dip(2,jj,j)*dip(2,kk,l)
8596       endif
8597 #endif
8598       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8599       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8600       if (j.eq.l+1) then
8601         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8602         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8603       else
8604         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8605         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8606       endif
8607       call transpose2(EUg(1,1,k),auxmat(1,1))
8608       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8609       vv(1)=pizda(1,1)-pizda(2,2)
8610       vv(2)=pizda(2,1)+pizda(1,2)
8611       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8612 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8613 #ifdef MOMENT
8614       eello6_graph4=-(s1+s2+s3+s4)
8615 #else
8616       eello6_graph4=-(s2+s3+s4)
8617 #endif
8618 C Derivatives in gamma(i-1)
8619       if (i.gt.1) then
8620 #ifdef MOMENT
8621         if (imat.eq.1) then
8622           s1=dipderg(2,jj,i)*dip(3,kk,k)
8623         else
8624           s1=dipderg(4,jj,j)*dip(2,kk,l)
8625         endif
8626 #endif
8627         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8628         if (j.eq.l+1) then
8629           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8630           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8631         else
8632           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8633           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8634         endif
8635         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8636         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8637 cd          write (2,*) 'turn6 derivatives'
8638 #ifdef MOMENT
8639           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8640 #else
8641           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8642 #endif
8643         else
8644 #ifdef MOMENT
8645           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8646 #else
8647           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8648 #endif
8649         endif
8650       endif
8651 C Derivatives in gamma(k-1)
8652 #ifdef MOMENT
8653       if (imat.eq.1) then
8654         s1=dip(3,jj,i)*dipderg(2,kk,k)
8655       else
8656         s1=dip(2,jj,j)*dipderg(4,kk,l)
8657       endif
8658 #endif
8659       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8660       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8661       if (j.eq.l+1) then
8662         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8663         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8664       else
8665         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8666         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8667       endif
8668       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8669       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8670       vv(1)=pizda(1,1)-pizda(2,2)
8671       vv(2)=pizda(2,1)+pizda(1,2)
8672       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8673       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8674 #ifdef MOMENT
8675         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8676 #else
8677         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8678 #endif
8679       else
8680 #ifdef MOMENT
8681         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8682 #else
8683         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8684 #endif
8685       endif
8686 C Derivatives in gamma(j-1) or gamma(l-1)
8687       if (l.eq.j+1 .and. l.gt.1) then
8688         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8689         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8690         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8691         vv(1)=pizda(1,1)-pizda(2,2)
8692         vv(2)=pizda(2,1)+pizda(1,2)
8693         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8694         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8695       else if (j.gt.1) then
8696         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8697         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8698         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8699         vv(1)=pizda(1,1)-pizda(2,2)
8700         vv(2)=pizda(2,1)+pizda(1,2)
8701         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8702         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8703           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8704         else
8705           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8706         endif
8707       endif
8708 C Cartesian derivatives.
8709       do iii=1,2
8710         do kkk=1,5
8711           do lll=1,3
8712 #ifdef MOMENT
8713             if (iii.eq.1) then
8714               if (imat.eq.1) then
8715                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8716               else
8717                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8718               endif
8719             else
8720               if (imat.eq.1) then
8721                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8722               else
8723                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8724               endif
8725             endif
8726 #endif
8727             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8728      &        auxvec(1))
8729             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8730             if (j.eq.l+1) then
8731               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8732      &          b1(1,itj1),auxvec(1))
8733               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8734             else
8735               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8736      &          b1(1,itl1),auxvec(1))
8737               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8738             endif
8739             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8740      &        pizda(1,1))
8741             vv(1)=pizda(1,1)-pizda(2,2)
8742             vv(2)=pizda(2,1)+pizda(1,2)
8743             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8744             if (swap) then
8745               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8746 #ifdef MOMENT
8747                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8748      &             -(s1+s2+s4)
8749 #else
8750                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8751      &             -(s2+s4)
8752 #endif
8753                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8754               else
8755 #ifdef MOMENT
8756                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8757 #else
8758                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8759 #endif
8760                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8761               endif
8762             else
8763 #ifdef MOMENT
8764               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8765 #else
8766               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8767 #endif
8768               if (l.eq.j+1) then
8769                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8770               else
8771                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8772               endif
8773             endif
8774           enddo
8775         enddo
8776       enddo
8777       return
8778       end
8779 c----------------------------------------------------------------------------
8780       double precision function eello_turn6(i,jj,kk)
8781       implicit real*8 (a-h,o-z)
8782       include 'DIMENSIONS'
8783       include 'COMMON.IOUNITS'
8784       include 'COMMON.CHAIN'
8785       include 'COMMON.DERIV'
8786       include 'COMMON.INTERACT'
8787       include 'COMMON.CONTACTS'
8788       include 'COMMON.TORSION'
8789       include 'COMMON.VAR'
8790       include 'COMMON.GEO'
8791       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8792      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8793      &  ggg1(3),ggg2(3)
8794       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8795      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8796 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8797 C           the respective energy moment and not to the cluster cumulant.
8798       s1=0.0d0
8799       s8=0.0d0
8800       s13=0.0d0
8801 c
8802       eello_turn6=0.0d0
8803       j=i+4
8804       k=i+1
8805       l=i+3
8806       iti=itortyp(itype(i))
8807       itk=itortyp(itype(k))
8808       itk1=itortyp(itype(k+1))
8809       itl=itortyp(itype(l))
8810       itj=itortyp(itype(j))
8811 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8812 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8813 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8814 cd        eello6=0.0d0
8815 cd        return
8816 cd      endif
8817 cd      write (iout,*)
8818 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8819 cd     &   ' and',k,l
8820 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8821       do iii=1,2
8822         do kkk=1,5
8823           do lll=1,3
8824             derx_turn(lll,kkk,iii)=0.0d0
8825           enddo
8826         enddo
8827       enddo
8828 cd      eij=1.0d0
8829 cd      ekl=1.0d0
8830 cd      ekont=1.0d0
8831       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8832 cd      eello6_5=0.0d0
8833 cd      write (2,*) 'eello6_5',eello6_5
8834 #ifdef MOMENT
8835       call transpose2(AEA(1,1,1),auxmat(1,1))
8836       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8837       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8838       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8839 #endif
8840       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8841       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8842       s2 = scalar2(b1(1,itk),vtemp1(1))
8843 #ifdef MOMENT
8844       call transpose2(AEA(1,1,2),atemp(1,1))
8845       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8846       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8847       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8848 #endif
8849       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8850       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8851       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8852 #ifdef MOMENT
8853       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8854       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8855       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8856       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8857       ss13 = scalar2(b1(1,itk),vtemp4(1))
8858       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8859 #endif
8860 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8861 c      s1=0.0d0
8862 c      s2=0.0d0
8863 c      s8=0.0d0
8864 c      s12=0.0d0
8865 c      s13=0.0d0
8866       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8867 C Derivatives in gamma(i+2)
8868       s1d =0.0d0
8869       s8d =0.0d0
8870 #ifdef MOMENT
8871       call transpose2(AEA(1,1,1),auxmatd(1,1))
8872       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8873       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8874       call transpose2(AEAderg(1,1,2),atempd(1,1))
8875       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8876       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8877 #endif
8878       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8879       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8880       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8881 c      s1d=0.0d0
8882 c      s2d=0.0d0
8883 c      s8d=0.0d0
8884 c      s12d=0.0d0
8885 c      s13d=0.0d0
8886       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8887 C Derivatives in gamma(i+3)
8888 #ifdef MOMENT
8889       call transpose2(AEA(1,1,1),auxmatd(1,1))
8890       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8891       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8892       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8893 #endif
8894       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8895       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8896       s2d = scalar2(b1(1,itk),vtemp1d(1))
8897 #ifdef MOMENT
8898       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8899       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8900 #endif
8901       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8902 #ifdef MOMENT
8903       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8904       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8905       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8906 #endif
8907 c      s1d=0.0d0
8908 c      s2d=0.0d0
8909 c      s8d=0.0d0
8910 c      s12d=0.0d0
8911 c      s13d=0.0d0
8912 #ifdef MOMENT
8913       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8914      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8915 #else
8916       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8917      &               -0.5d0*ekont*(s2d+s12d)
8918 #endif
8919 C Derivatives in gamma(i+4)
8920       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8921       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8922       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8923 #ifdef MOMENT
8924       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8925       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8926       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8927 #endif
8928 c      s1d=0.0d0
8929 c      s2d=0.0d0
8930 c      s8d=0.0d0
8931 C      s12d=0.0d0
8932 c      s13d=0.0d0
8933 #ifdef MOMENT
8934       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8935 #else
8936       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8937 #endif
8938 C Derivatives in gamma(i+5)
8939 #ifdef MOMENT
8940       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8941       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8942       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8943 #endif
8944       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8945       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8946       s2d = scalar2(b1(1,itk),vtemp1d(1))
8947 #ifdef MOMENT
8948       call transpose2(AEA(1,1,2),atempd(1,1))
8949       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8950       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8951 #endif
8952       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8953       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8954 #ifdef MOMENT
8955       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8956       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8957       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8958 #endif
8959 c      s1d=0.0d0
8960 c      s2d=0.0d0
8961 c      s8d=0.0d0
8962 c      s12d=0.0d0
8963 c      s13d=0.0d0
8964 #ifdef MOMENT
8965       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8966      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8967 #else
8968       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8969      &               -0.5d0*ekont*(s2d+s12d)
8970 #endif
8971 C Cartesian derivatives
8972       do iii=1,2
8973         do kkk=1,5
8974           do lll=1,3
8975 #ifdef MOMENT
8976             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8977             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8978             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8979 #endif
8980             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8981             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8982      &          vtemp1d(1))
8983             s2d = scalar2(b1(1,itk),vtemp1d(1))
8984 #ifdef MOMENT
8985             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8986             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8987             s8d = -(atempd(1,1)+atempd(2,2))*
8988      &           scalar2(cc(1,1,itl),vtemp2(1))
8989 #endif
8990             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8991      &           auxmatd(1,1))
8992             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8993             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8994 c      s1d=0.0d0
8995 c      s2d=0.0d0
8996 c      s8d=0.0d0
8997 c      s12d=0.0d0
8998 c      s13d=0.0d0
8999 #ifdef MOMENT
9000             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9001      &        - 0.5d0*(s1d+s2d)
9002 #else
9003             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9004      &        - 0.5d0*s2d
9005 #endif
9006 #ifdef MOMENT
9007             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9008      &        - 0.5d0*(s8d+s12d)
9009 #else
9010             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9011      &        - 0.5d0*s12d
9012 #endif
9013           enddo
9014         enddo
9015       enddo
9016 #ifdef MOMENT
9017       do kkk=1,5
9018         do lll=1,3
9019           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9020      &      achuj_tempd(1,1))
9021           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9022           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9023           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9024           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9025           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9026      &      vtemp4d(1))
9027           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9028           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9029           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9030         enddo
9031       enddo
9032 #endif
9033 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9034 cd     &  16*eel_turn6_num
9035 cd      goto 1112
9036       if (j.lt.nres-1) then
9037         j1=j+1
9038         j2=j-1
9039       else
9040         j1=j-1
9041         j2=j-2
9042       endif
9043       if (l.lt.nres-1) then
9044         l1=l+1
9045         l2=l-1
9046       else
9047         l1=l-1
9048         l2=l-2
9049       endif
9050       do ll=1,3
9051 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9052 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9053 cgrad        ghalf=0.5d0*ggg1(ll)
9054 cd        ghalf=0.0d0
9055         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9056         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9057         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9058      &    +ekont*derx_turn(ll,2,1)
9059         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9060         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9061      &    +ekont*derx_turn(ll,4,1)
9062         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9063         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9064         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9065 cgrad        ghalf=0.5d0*ggg2(ll)
9066 cd        ghalf=0.0d0
9067         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9068      &    +ekont*derx_turn(ll,2,2)
9069         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9070         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9071      &    +ekont*derx_turn(ll,4,2)
9072         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9073         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9074         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9075       enddo
9076 cd      goto 1112
9077 cgrad      do m=i+1,j-1
9078 cgrad        do ll=1,3
9079 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9080 cgrad        enddo
9081 cgrad      enddo
9082 cgrad      do m=k+1,l-1
9083 cgrad        do ll=1,3
9084 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9085 cgrad        enddo
9086 cgrad      enddo
9087 cgrad1112  continue
9088 cgrad      do m=i+2,j2
9089 cgrad        do ll=1,3
9090 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9091 cgrad        enddo
9092 cgrad      enddo
9093 cgrad      do m=k+2,l2
9094 cgrad        do ll=1,3
9095 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9096 cgrad        enddo
9097 cgrad      enddo
9098 cd      do iii=1,nres-3
9099 cd        write (2,*) iii,g_corr6_loc(iii)
9100 cd      enddo
9101       eello_turn6=ekont*eel_turn6
9102 cd      write (2,*) 'ekont',ekont
9103 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9104       return
9105       end
9106
9107 C-----------------------------------------------------------------------------
9108       double precision function scalar(u,v)
9109 !DIR$ INLINEALWAYS scalar
9110 #ifndef OSF
9111 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9112 #endif
9113       implicit none
9114       double precision u(3),v(3)
9115 cd      double precision sc
9116 cd      integer i
9117 cd      sc=0.0d0
9118 cd      do i=1,3
9119 cd        sc=sc+u(i)*v(i)
9120 cd      enddo
9121 cd      scalar=sc
9122
9123       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9124       return
9125       end
9126 crc-------------------------------------------------
9127       SUBROUTINE MATVEC2(A1,V1,V2)
9128 !DIR$ INLINEALWAYS MATVEC2
9129 #ifndef OSF
9130 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9131 #endif
9132       implicit real*8 (a-h,o-z)
9133       include 'DIMENSIONS'
9134       DIMENSION A1(2,2),V1(2),V2(2)
9135 c      DO 1 I=1,2
9136 c        VI=0.0
9137 c        DO 3 K=1,2
9138 c    3     VI=VI+A1(I,K)*V1(K)
9139 c        Vaux(I)=VI
9140 c    1 CONTINUE
9141
9142       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9143       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9144
9145       v2(1)=vaux1
9146       v2(2)=vaux2
9147       END
9148 C---------------------------------------
9149       SUBROUTINE MATMAT2(A1,A2,A3)
9150 #ifndef OSF
9151 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9152 #endif
9153       implicit real*8 (a-h,o-z)
9154       include 'DIMENSIONS'
9155       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9156 c      DIMENSION AI3(2,2)
9157 c        DO  J=1,2
9158 c          A3IJ=0.0
9159 c          DO K=1,2
9160 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9161 c          enddo
9162 c          A3(I,J)=A3IJ
9163 c       enddo
9164 c      enddo
9165
9166       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9167       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9168       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9169       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9170
9171       A3(1,1)=AI3_11
9172       A3(2,1)=AI3_21
9173       A3(1,2)=AI3_12
9174       A3(2,2)=AI3_22
9175       END
9176
9177 c-------------------------------------------------------------------------
9178       double precision function scalar2(u,v)
9179 !DIR$ INLINEALWAYS scalar2
9180       implicit none
9181       double precision u(2),v(2)
9182       double precision sc
9183       integer i
9184       scalar2=u(1)*v(1)+u(2)*v(2)
9185       return
9186       end
9187
9188 C-----------------------------------------------------------------------------
9189
9190       subroutine transpose2(a,at)
9191 !DIR$ INLINEALWAYS transpose2
9192 #ifndef OSF
9193 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9194 #endif
9195       implicit none
9196       double precision a(2,2),at(2,2)
9197       at(1,1)=a(1,1)
9198       at(1,2)=a(2,1)
9199       at(2,1)=a(1,2)
9200       at(2,2)=a(2,2)
9201       return
9202       end
9203 c--------------------------------------------------------------------------
9204       subroutine transpose(n,a,at)
9205       implicit none
9206       integer n,i,j
9207       double precision a(n,n),at(n,n)
9208       do i=1,n
9209         do j=1,n
9210           at(j,i)=a(i,j)
9211         enddo
9212       enddo
9213       return
9214       end
9215 C---------------------------------------------------------------------------
9216       subroutine prodmat3(a1,a2,kk,transp,prod)
9217 !DIR$ INLINEALWAYS prodmat3
9218 #ifndef OSF
9219 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9220 #endif
9221       implicit none
9222       integer i,j
9223       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9224       logical transp
9225 crc      double precision auxmat(2,2),prod_(2,2)
9226
9227       if (transp) then
9228 crc        call transpose2(kk(1,1),auxmat(1,1))
9229 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9230 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9231
9232            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9233      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9234            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9235      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9236            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9237      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9238            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9239      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9240
9241       else
9242 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9243 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9244
9245            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9246      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9247            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9248      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9249            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9250      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9251            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9252      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9253
9254       endif
9255 c      call transpose2(a2(1,1),a2t(1,1))
9256
9257 crc      print *,transp
9258 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9259 crc      print *,((prod(i,j),i=1,2),j=1,2)
9260
9261       return
9262       end
9263