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=iabs(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) write (iout,'(a6,2i5,0pf7.3)')
1683      &                        'evdw',i,j,evdwij
1684
1685 C Calculate gradient components.
1686             e1=e1*eps1*eps2rt**2*eps3rt**2
1687             fac=-expon*(e1+evdwij)*rij_shift
1688             sigder=fac*sigder
1689             fac=rij*fac
1690 c            fac=0.0d0
1691 C Calculate the radial part of the gradient
1692             gg(1)=xj*fac
1693             gg(2)=yj*fac
1694             gg(3)=zj*fac
1695 C Calculate angular part of the gradient.
1696 #ifdef TSCSC
1697             if (bb(itypi,itypj).gt.0) then
1698                call sc_grad
1699             else
1700                call sc_grad_T
1701             endif
1702 #else
1703             call sc_grad
1704 #endif
1705             ENDIF    ! dyn_ss
1706           enddo      ! j
1707         enddo        ! iint
1708       enddo          ! i
1709 c      write (iout,*) "Number of loop steps in EGB:",ind
1710 cccc      energy_dec=.false.
1711       return
1712       end
1713 C-----------------------------------------------------------------------------
1714       subroutine egbv(evdw,evdw_p,evdw_m)
1715 C
1716 C This subroutine calculates the interaction energy of nonbonded side chains
1717 C assuming the Gay-Berne-Vorobjev potential of interaction.
1718 C
1719       implicit real*8 (a-h,o-z)
1720       include 'DIMENSIONS'
1721       include 'COMMON.GEO'
1722       include 'COMMON.VAR'
1723       include 'COMMON.LOCAL'
1724       include 'COMMON.CHAIN'
1725       include 'COMMON.DERIV'
1726       include 'COMMON.NAMES'
1727       include 'COMMON.INTERACT'
1728       include 'COMMON.IOUNITS'
1729       include 'COMMON.CALC'
1730       common /srutu/ icall
1731       logical lprn
1732       evdw=0.0D0
1733 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1734       evdw=0.0D0
1735       lprn=.false.
1736 c     if (icall.eq.0) lprn=.true.
1737       ind=0
1738       do i=iatsc_s,iatsc_e
1739         itypi=itype(i)
1740         itypi1=itype(i+1)
1741         xi=c(1,nres+i)
1742         yi=c(2,nres+i)
1743         zi=c(3,nres+i)
1744         dxi=dc_norm(1,nres+i)
1745         dyi=dc_norm(2,nres+i)
1746         dzi=dc_norm(3,nres+i)
1747 c        dsci_inv=dsc_inv(itypi)
1748         dsci_inv=vbld_inv(i+nres)
1749 C
1750 C Calculate SC interaction energy.
1751 C
1752         do iint=1,nint_gr(i)
1753           do j=istart(i,iint),iend(i,iint)
1754             ind=ind+1
1755             itypj=itype(j)
1756 c            dscj_inv=dsc_inv(itypj)
1757             dscj_inv=vbld_inv(j+nres)
1758             sig0ij=sigma(itypi,itypj)
1759             r0ij=r0(itypi,itypj)
1760             chi1=chi(itypi,itypj)
1761             chi2=chi(itypj,itypi)
1762             chi12=chi1*chi2
1763             chip1=chip(itypi)
1764             chip2=chip(itypj)
1765             chip12=chip1*chip2
1766             alf1=alp(itypi)
1767             alf2=alp(itypj)
1768             alf12=0.5D0*(alf1+alf2)
1769 C For diagnostics only!!!
1770 c           chi1=0.0D0
1771 c           chi2=0.0D0
1772 c           chi12=0.0D0
1773 c           chip1=0.0D0
1774 c           chip2=0.0D0
1775 c           chip12=0.0D0
1776 c           alf1=0.0D0
1777 c           alf2=0.0D0
1778 c           alf12=0.0D0
1779             xj=c(1,nres+j)-xi
1780             yj=c(2,nres+j)-yi
1781             zj=c(3,nres+j)-zi
1782             dxj=dc_norm(1,nres+j)
1783             dyj=dc_norm(2,nres+j)
1784             dzj=dc_norm(3,nres+j)
1785             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1786             rij=dsqrt(rrij)
1787 C Calculate angle-dependent terms of energy and contributions to their
1788 C derivatives.
1789             call sc_angular
1790             sigsq=1.0D0/sigsq
1791             sig=sig0ij*dsqrt(sigsq)
1792             rij_shift=1.0D0/rij-sig+r0ij
1793 C I hate to put IF's in the loops, but here don't have another choice!!!!
1794             if (rij_shift.le.0.0D0) then
1795               evdw=1.0D20
1796               return
1797             endif
1798             sigder=-sig*sigsq
1799 c---------------------------------------------------------------
1800             rij_shift=1.0D0/rij_shift
1801             fac=rij_shift**expon
1802             e1=fac*fac*aa(itypi,itypj)
1803             e2=fac*bb(itypi,itypj)
1804             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1805             eps2der=evdwij*eps3rt
1806             eps3der=evdwij*eps2rt
1807             fac_augm=rrij**expon
1808             e_augm=augm(itypi,itypj)*fac_augm
1809             evdwij=evdwij*eps2rt*eps3rt
1810 #ifdef TSCSC
1811             if (bb(itypi,itypj).gt.0) then
1812                evdw_p=evdw_p+evdwij+e_augm
1813             else
1814                evdw_m=evdw_m+evdwij+e_augm
1815             endif
1816 #else
1817             evdw=evdw+evdwij+e_augm
1818 #endif
1819             if (lprn) then
1820             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1821             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1822             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1823      &        restyp(itypi),i,restyp(itypj),j,
1824      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1825      &        chi1,chi2,chip1,chip2,
1826      &        eps1,eps2rt**2,eps3rt**2,
1827      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1828      &        evdwij+e_augm
1829             endif
1830 C Calculate gradient components.
1831             e1=e1*eps1*eps2rt**2*eps3rt**2
1832             fac=-expon*(e1+evdwij)*rij_shift
1833             sigder=fac*sigder
1834             fac=rij*fac-2*expon*rrij*e_augm
1835 C Calculate the radial part of the gradient
1836             gg(1)=xj*fac
1837             gg(2)=yj*fac
1838             gg(3)=zj*fac
1839 C Calculate angular part of the gradient.
1840 #ifdef TSCSC
1841             if (bb(itypi,itypj).gt.0) then
1842                call sc_grad
1843             else
1844                call sc_grad_T
1845             endif
1846 #else
1847             call sc_grad
1848 #endif
1849           enddo      ! j
1850         enddo        ! iint
1851       enddo          ! i
1852       end
1853 C-----------------------------------------------------------------------------
1854       subroutine sc_angular
1855 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1856 C om12. Called by ebp, egb, and egbv.
1857       implicit none
1858       include 'COMMON.CALC'
1859       include 'COMMON.IOUNITS'
1860       erij(1)=xj*rij
1861       erij(2)=yj*rij
1862       erij(3)=zj*rij
1863       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1864       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1865       om12=dxi*dxj+dyi*dyj+dzi*dzj
1866       chiom12=chi12*om12
1867 C Calculate eps1(om12) and its derivative in om12
1868       faceps1=1.0D0-om12*chiom12
1869       faceps1_inv=1.0D0/faceps1
1870       eps1=dsqrt(faceps1_inv)
1871 C Following variable is eps1*deps1/dom12
1872       eps1_om12=faceps1_inv*chiom12
1873 c diagnostics only
1874 c      faceps1_inv=om12
1875 c      eps1=om12
1876 c      eps1_om12=1.0d0
1877 c      write (iout,*) "om12",om12," eps1",eps1
1878 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1879 C and om12.
1880       om1om2=om1*om2
1881       chiom1=chi1*om1
1882       chiom2=chi2*om2
1883       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1884       sigsq=1.0D0-facsig*faceps1_inv
1885       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1886       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1887       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1888 c diagnostics only
1889 c      sigsq=1.0d0
1890 c      sigsq_om1=0.0d0
1891 c      sigsq_om2=0.0d0
1892 c      sigsq_om12=0.0d0
1893 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1894 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1895 c     &    " eps1",eps1
1896 C Calculate eps2 and its derivatives in om1, om2, and om12.
1897       chipom1=chip1*om1
1898       chipom2=chip2*om2
1899       chipom12=chip12*om12
1900       facp=1.0D0-om12*chipom12
1901       facp_inv=1.0D0/facp
1902       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1903 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1904 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1905 C Following variable is the square root of eps2
1906       eps2rt=1.0D0-facp1*facp_inv
1907 C Following three variables are the derivatives of the square root of eps
1908 C in om1, om2, and om12.
1909       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1910       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1911       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1912 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1913       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1914 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1915 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1916 c     &  " eps2rt_om12",eps2rt_om12
1917 C Calculate whole angle-dependent part of epsilon and contributions
1918 C to its derivatives
1919       return
1920       end
1921
1922 C----------------------------------------------------------------------------
1923       subroutine sc_grad_T
1924       implicit real*8 (a-h,o-z)
1925       include 'DIMENSIONS'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.CALC'
1929       include 'COMMON.IOUNITS'
1930       double precision dcosom1(3),dcosom2(3)
1931       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1932       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1933       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1934      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1935 c diagnostics only
1936 c      eom1=0.0d0
1937 c      eom2=0.0d0
1938 c      eom12=evdwij*eps1_om12
1939 c end diagnostics
1940 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1941 c     &  " sigder",sigder
1942 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1943 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1944       do k=1,3
1945         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1946         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1947       enddo
1948       do k=1,3
1949         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1950       enddo
1951 c      write (iout,*) "gg",(gg(k),k=1,3)
1952       do k=1,3
1953         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1954      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1955      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1956         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1957      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1958      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1959 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1960 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1961 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1962 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1963       enddo
1964 C
1965 C Calculate the components of the gradient in DC and X
1966 C
1967 cgrad      do k=i,j-1
1968 cgrad        do l=1,3
1969 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1970 cgrad        enddo
1971 cgrad      enddo
1972       do l=1,3
1973         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1974         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1975       enddo
1976       return
1977       end
1978
1979 C----------------------------------------------------------------------------
1980       subroutine sc_grad
1981       implicit real*8 (a-h,o-z)
1982       include 'DIMENSIONS'
1983       include 'COMMON.CHAIN'
1984       include 'COMMON.DERIV'
1985       include 'COMMON.CALC'
1986       include 'COMMON.IOUNITS'
1987       double precision dcosom1(3),dcosom2(3)
1988       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1989       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1990       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1991      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1992 c diagnostics only
1993 c      eom1=0.0d0
1994 c      eom2=0.0d0
1995 c      eom12=evdwij*eps1_om12
1996 c end diagnostics
1997 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1998 c     &  " sigder",sigder
1999 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2000 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2001       do k=1,3
2002         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2003         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2004       enddo
2005       do k=1,3
2006         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2007       enddo
2008 c      write (iout,*) "gg",(gg(k),k=1,3)
2009       do k=1,3
2010         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2011      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2012      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2013         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2014      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2015      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2016 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2017 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2018 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2019 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2020       enddo
2021 C
2022 C Calculate the components of the gradient in DC and X
2023 C
2024 cgrad      do k=i,j-1
2025 cgrad        do l=1,3
2026 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2027 cgrad        enddo
2028 cgrad      enddo
2029       do l=1,3
2030         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2031         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2032       enddo
2033       return
2034       end
2035 C-----------------------------------------------------------------------
2036       subroutine e_softsphere(evdw)
2037 C
2038 C This subroutine calculates the interaction energy of nonbonded side chains
2039 C assuming the LJ potential of interaction.
2040 C
2041       implicit real*8 (a-h,o-z)
2042       include 'DIMENSIONS'
2043       parameter (accur=1.0d-10)
2044       include 'COMMON.GEO'
2045       include 'COMMON.VAR'
2046       include 'COMMON.LOCAL'
2047       include 'COMMON.CHAIN'
2048       include 'COMMON.DERIV'
2049       include 'COMMON.INTERACT'
2050       include 'COMMON.TORSION'
2051       include 'COMMON.SBRIDGE'
2052       include 'COMMON.NAMES'
2053       include 'COMMON.IOUNITS'
2054       include 'COMMON.CONTACTS'
2055       dimension gg(3)
2056 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2057       evdw=0.0D0
2058       do i=iatsc_s,iatsc_e
2059         itypi=itype(i)
2060         itypi1=itype(i+1)
2061         xi=c(1,nres+i)
2062         yi=c(2,nres+i)
2063         zi=c(3,nres+i)
2064 C
2065 C Calculate SC interaction energy.
2066 C
2067         do iint=1,nint_gr(i)
2068 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2069 cd   &                  'iend=',iend(i,iint)
2070           do j=istart(i,iint),iend(i,iint)
2071             itypj=itype(j)
2072             xj=c(1,nres+j)-xi
2073             yj=c(2,nres+j)-yi
2074             zj=c(3,nres+j)-zi
2075             rij=xj*xj+yj*yj+zj*zj
2076 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2077             r0ij=r0(itypi,itypj)
2078             r0ijsq=r0ij*r0ij
2079 c            print *,i,j,r0ij,dsqrt(rij)
2080             if (rij.lt.r0ijsq) then
2081               evdwij=0.25d0*(rij-r0ijsq)**2
2082               fac=rij-r0ijsq
2083             else
2084               evdwij=0.0d0
2085               fac=0.0d0
2086             endif
2087             evdw=evdw+evdwij
2088 C
2089 C Calculate the components of the gradient in DC and X
2090 C
2091             gg(1)=xj*fac
2092             gg(2)=yj*fac
2093             gg(3)=zj*fac
2094             do k=1,3
2095               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2096               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2097               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2098               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2099             enddo
2100 cgrad            do k=i,j-1
2101 cgrad              do l=1,3
2102 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2103 cgrad              enddo
2104 cgrad            enddo
2105           enddo ! j
2106         enddo ! iint
2107       enddo ! i
2108       return
2109       end
2110 C--------------------------------------------------------------------------
2111       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2112      &              eello_turn4)
2113 C
2114 C Soft-sphere potential of p-p interaction
2115 C
2116       implicit real*8 (a-h,o-z)
2117       include 'DIMENSIONS'
2118       include 'COMMON.CONTROL'
2119       include 'COMMON.IOUNITS'
2120       include 'COMMON.GEO'
2121       include 'COMMON.VAR'
2122       include 'COMMON.LOCAL'
2123       include 'COMMON.CHAIN'
2124       include 'COMMON.DERIV'
2125       include 'COMMON.INTERACT'
2126       include 'COMMON.CONTACTS'
2127       include 'COMMON.TORSION'
2128       include 'COMMON.VECTORS'
2129       include 'COMMON.FFIELD'
2130       dimension ggg(3)
2131 cd      write(iout,*) 'In EELEC_soft_sphere'
2132       ees=0.0D0
2133       evdw1=0.0D0
2134       eel_loc=0.0d0
2135       eello_turn3=0.0d0
2136       eello_turn4=0.0d0
2137       ind=0
2138       do i=iatel_s,iatel_e
2139         dxi=dc(1,i)
2140         dyi=dc(2,i)
2141         dzi=dc(3,i)
2142         xmedi=c(1,i)+0.5d0*dxi
2143         ymedi=c(2,i)+0.5d0*dyi
2144         zmedi=c(3,i)+0.5d0*dzi
2145         num_conti=0
2146 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2147         do j=ielstart(i),ielend(i)
2148           ind=ind+1
2149           iteli=itel(i)
2150           itelj=itel(j)
2151           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2152           r0ij=rpp(iteli,itelj)
2153           r0ijsq=r0ij*r0ij
2154           dxj=dc(1,j)
2155           dyj=dc(2,j)
2156           dzj=dc(3,j)
2157           xj=c(1,j)+0.5D0*dxj-xmedi
2158           yj=c(2,j)+0.5D0*dyj-ymedi
2159           zj=c(3,j)+0.5D0*dzj-zmedi
2160           rij=xj*xj+yj*yj+zj*zj
2161           if (rij.lt.r0ijsq) then
2162             evdw1ij=0.25d0*(rij-r0ijsq)**2
2163             fac=rij-r0ijsq
2164           else
2165             evdw1ij=0.0d0
2166             fac=0.0d0
2167           endif
2168           evdw1=evdw1+evdw1ij
2169 C
2170 C Calculate contributions to the Cartesian gradient.
2171 C
2172           ggg(1)=fac*xj
2173           ggg(2)=fac*yj
2174           ggg(3)=fac*zj
2175           do k=1,3
2176             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2177             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2178           enddo
2179 *
2180 * Loop over residues i+1 thru j-1.
2181 *
2182 cgrad          do k=i+1,j-1
2183 cgrad            do l=1,3
2184 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2185 cgrad            enddo
2186 cgrad          enddo
2187         enddo ! j
2188       enddo   ! i
2189 cgrad      do i=nnt,nct-1
2190 cgrad        do k=1,3
2191 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2192 cgrad        enddo
2193 cgrad        do j=i+1,nct-1
2194 cgrad          do k=1,3
2195 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2196 cgrad          enddo
2197 cgrad        enddo
2198 cgrad      enddo
2199       return
2200       end
2201 c------------------------------------------------------------------------------
2202       subroutine vec_and_deriv
2203       implicit real*8 (a-h,o-z)
2204       include 'DIMENSIONS'
2205 #ifdef MPI
2206       include 'mpif.h'
2207 #endif
2208       include 'COMMON.IOUNITS'
2209       include 'COMMON.GEO'
2210       include 'COMMON.VAR'
2211       include 'COMMON.LOCAL'
2212       include 'COMMON.CHAIN'
2213       include 'COMMON.VECTORS'
2214       include 'COMMON.SETUP'
2215       include 'COMMON.TIME1'
2216       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2217 C Compute the local reference systems. For reference system (i), the
2218 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2219 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2220 #ifdef PARVEC
2221       do i=ivec_start,ivec_end
2222 #else
2223       do i=1,nres-1
2224 #endif
2225           if (i.eq.nres-1) then
2226 C Case of the last full residue
2227 C Compute the Z-axis
2228             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2229             costh=dcos(pi-theta(nres))
2230             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2231             do k=1,3
2232               uz(k,i)=fac*uz(k,i)
2233             enddo
2234 C Compute the derivatives of uz
2235             uzder(1,1,1)= 0.0d0
2236             uzder(2,1,1)=-dc_norm(3,i-1)
2237             uzder(3,1,1)= dc_norm(2,i-1)
2238             uzder(1,2,1)= dc_norm(3,i-1)
2239             uzder(2,2,1)= 0.0d0
2240             uzder(3,2,1)=-dc_norm(1,i-1)
2241             uzder(1,3,1)=-dc_norm(2,i-1)
2242             uzder(2,3,1)= dc_norm(1,i-1)
2243             uzder(3,3,1)= 0.0d0
2244             uzder(1,1,2)= 0.0d0
2245             uzder(2,1,2)= dc_norm(3,i)
2246             uzder(3,1,2)=-dc_norm(2,i)
2247             uzder(1,2,2)=-dc_norm(3,i)
2248             uzder(2,2,2)= 0.0d0
2249             uzder(3,2,2)= dc_norm(1,i)
2250             uzder(1,3,2)= dc_norm(2,i)
2251             uzder(2,3,2)=-dc_norm(1,i)
2252             uzder(3,3,2)= 0.0d0
2253 C Compute the Y-axis
2254             facy=fac
2255             do k=1,3
2256               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2257             enddo
2258 C Compute the derivatives of uy
2259             do j=1,3
2260               do k=1,3
2261                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2262      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2263                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2264               enddo
2265               uyder(j,j,1)=uyder(j,j,1)-costh
2266               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2267             enddo
2268             do j=1,2
2269               do k=1,3
2270                 do l=1,3
2271                   uygrad(l,k,j,i)=uyder(l,k,j)
2272                   uzgrad(l,k,j,i)=uzder(l,k,j)
2273                 enddo
2274               enddo
2275             enddo
2276             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2277             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2278             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2279             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2280           else
2281 C Other residues
2282 C Compute the Z-axis
2283             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2284             costh=dcos(pi-theta(i+2))
2285             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2286             do k=1,3
2287               uz(k,i)=fac*uz(k,i)
2288             enddo
2289 C Compute the derivatives of uz
2290             uzder(1,1,1)= 0.0d0
2291             uzder(2,1,1)=-dc_norm(3,i+1)
2292             uzder(3,1,1)= dc_norm(2,i+1)
2293             uzder(1,2,1)= dc_norm(3,i+1)
2294             uzder(2,2,1)= 0.0d0
2295             uzder(3,2,1)=-dc_norm(1,i+1)
2296             uzder(1,3,1)=-dc_norm(2,i+1)
2297             uzder(2,3,1)= dc_norm(1,i+1)
2298             uzder(3,3,1)= 0.0d0
2299             uzder(1,1,2)= 0.0d0
2300             uzder(2,1,2)= dc_norm(3,i)
2301             uzder(3,1,2)=-dc_norm(2,i)
2302             uzder(1,2,2)=-dc_norm(3,i)
2303             uzder(2,2,2)= 0.0d0
2304             uzder(3,2,2)= dc_norm(1,i)
2305             uzder(1,3,2)= dc_norm(2,i)
2306             uzder(2,3,2)=-dc_norm(1,i)
2307             uzder(3,3,2)= 0.0d0
2308 C Compute the Y-axis
2309             facy=fac
2310             do k=1,3
2311               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2312             enddo
2313 C Compute the derivatives of uy
2314             do j=1,3
2315               do k=1,3
2316                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2317      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2318                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2319               enddo
2320               uyder(j,j,1)=uyder(j,j,1)-costh
2321               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2322             enddo
2323             do j=1,2
2324               do k=1,3
2325                 do l=1,3
2326                   uygrad(l,k,j,i)=uyder(l,k,j)
2327                   uzgrad(l,k,j,i)=uzder(l,k,j)
2328                 enddo
2329               enddo
2330             enddo
2331             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2332             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2333             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2334             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2335           endif
2336       enddo
2337       do i=1,nres-1
2338         vbld_inv_temp(1)=vbld_inv(i+1)
2339         if (i.lt.nres-1) then
2340           vbld_inv_temp(2)=vbld_inv(i+2)
2341           else
2342           vbld_inv_temp(2)=vbld_inv(i)
2343           endif
2344         do j=1,2
2345           do k=1,3
2346             do l=1,3
2347               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2348               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2349             enddo
2350           enddo
2351         enddo
2352       enddo
2353 #if defined(PARVEC) && defined(MPI)
2354       if (nfgtasks1.gt.1) then
2355         time00=MPI_Wtime()
2356 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2357 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2358 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2359         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2360      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2361      &   FG_COMM1,IERR)
2362         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2363      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2364      &   FG_COMM1,IERR)
2365         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2366      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2367      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2368         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2369      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2370      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2371         time_gather=time_gather+MPI_Wtime()-time00
2372       endif
2373 c      if (fg_rank.eq.0) then
2374 c        write (iout,*) "Arrays UY and UZ"
2375 c        do i=1,nres-1
2376 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2377 c     &     (uz(k,i),k=1,3)
2378 c        enddo
2379 c      endif
2380 #endif
2381       return
2382       end
2383 C-----------------------------------------------------------------------------
2384       subroutine check_vecgrad
2385       implicit real*8 (a-h,o-z)
2386       include 'DIMENSIONS'
2387       include 'COMMON.IOUNITS'
2388       include 'COMMON.GEO'
2389       include 'COMMON.VAR'
2390       include 'COMMON.LOCAL'
2391       include 'COMMON.CHAIN'
2392       include 'COMMON.VECTORS'
2393       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2394       dimension uyt(3,maxres),uzt(3,maxres)
2395       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2396       double precision delta /1.0d-7/
2397       call vec_and_deriv
2398 cd      do i=1,nres
2399 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2400 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2401 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2402 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2403 cd     &     (dc_norm(if90,i),if90=1,3)
2404 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2405 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2406 cd          write(iout,'(a)')
2407 cd      enddo
2408       do i=1,nres
2409         do j=1,2
2410           do k=1,3
2411             do l=1,3
2412               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2413               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2414             enddo
2415           enddo
2416         enddo
2417       enddo
2418       call vec_and_deriv
2419       do i=1,nres
2420         do j=1,3
2421           uyt(j,i)=uy(j,i)
2422           uzt(j,i)=uz(j,i)
2423         enddo
2424       enddo
2425       do i=1,nres
2426 cd        write (iout,*) 'i=',i
2427         do k=1,3
2428           erij(k)=dc_norm(k,i)
2429         enddo
2430         do j=1,3
2431           do k=1,3
2432             dc_norm(k,i)=erij(k)
2433           enddo
2434           dc_norm(j,i)=dc_norm(j,i)+delta
2435 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2436 c          do k=1,3
2437 c            dc_norm(k,i)=dc_norm(k,i)/fac
2438 c          enddo
2439 c          write (iout,*) (dc_norm(k,i),k=1,3)
2440 c          write (iout,*) (erij(k),k=1,3)
2441           call vec_and_deriv
2442           do k=1,3
2443             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2444             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2445             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2446             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2447           enddo
2448 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2449 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2450 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2451         enddo
2452         do k=1,3
2453           dc_norm(k,i)=erij(k)
2454         enddo
2455 cd        do k=1,3
2456 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2457 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2458 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2459 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2460 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2461 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2462 cd          write (iout,'(a)')
2463 cd        enddo
2464       enddo
2465       return
2466       end
2467 C--------------------------------------------------------------------------
2468       subroutine set_matrices
2469       implicit real*8 (a-h,o-z)
2470       include 'DIMENSIONS'
2471 #ifdef MPI
2472       include "mpif.h"
2473       include "COMMON.SETUP"
2474       integer IERR
2475       integer status(MPI_STATUS_SIZE)
2476 #endif
2477       include 'COMMON.IOUNITS'
2478       include 'COMMON.GEO'
2479       include 'COMMON.VAR'
2480       include 'COMMON.LOCAL'
2481       include 'COMMON.CHAIN'
2482       include 'COMMON.DERIV'
2483       include 'COMMON.INTERACT'
2484       include 'COMMON.CONTACTS'
2485       include 'COMMON.TORSION'
2486       include 'COMMON.VECTORS'
2487       include 'COMMON.FFIELD'
2488       double precision auxvec(2),auxmat(2,2)
2489 C
2490 C Compute the virtual-bond-torsional-angle dependent quantities needed
2491 C to calculate the el-loc multibody terms of various order.
2492 C
2493 #ifdef PARMAT
2494       do i=ivec_start+2,ivec_end+2
2495 #else
2496       do i=3,nres+1
2497 #endif
2498         if (i .lt. nres+1) then
2499           sin1=dsin(phi(i))
2500           cos1=dcos(phi(i))
2501           sintab(i-2)=sin1
2502           costab(i-2)=cos1
2503           obrot(1,i-2)=cos1
2504           obrot(2,i-2)=sin1
2505           sin2=dsin(2*phi(i))
2506           cos2=dcos(2*phi(i))
2507           sintab2(i-2)=sin2
2508           costab2(i-2)=cos2
2509           obrot2(1,i-2)=cos2
2510           obrot2(2,i-2)=sin2
2511           Ug(1,1,i-2)=-cos1
2512           Ug(1,2,i-2)=-sin1
2513           Ug(2,1,i-2)=-sin1
2514           Ug(2,2,i-2)= cos1
2515           Ug2(1,1,i-2)=-cos2
2516           Ug2(1,2,i-2)=-sin2
2517           Ug2(2,1,i-2)=-sin2
2518           Ug2(2,2,i-2)= cos2
2519         else
2520           costab(i-2)=1.0d0
2521           sintab(i-2)=0.0d0
2522           obrot(1,i-2)=1.0d0
2523           obrot(2,i-2)=0.0d0
2524           obrot2(1,i-2)=0.0d0
2525           obrot2(2,i-2)=0.0d0
2526           Ug(1,1,i-2)=1.0d0
2527           Ug(1,2,i-2)=0.0d0
2528           Ug(2,1,i-2)=0.0d0
2529           Ug(2,2,i-2)=1.0d0
2530           Ug2(1,1,i-2)=0.0d0
2531           Ug2(1,2,i-2)=0.0d0
2532           Ug2(2,1,i-2)=0.0d0
2533           Ug2(2,2,i-2)=0.0d0
2534         endif
2535         if (i .gt. 3 .and. i .lt. nres+1) then
2536           obrot_der(1,i-2)=-sin1
2537           obrot_der(2,i-2)= cos1
2538           Ugder(1,1,i-2)= sin1
2539           Ugder(1,2,i-2)=-cos1
2540           Ugder(2,1,i-2)=-cos1
2541           Ugder(2,2,i-2)=-sin1
2542           dwacos2=cos2+cos2
2543           dwasin2=sin2+sin2
2544           obrot2_der(1,i-2)=-dwasin2
2545           obrot2_der(2,i-2)= dwacos2
2546           Ug2der(1,1,i-2)= dwasin2
2547           Ug2der(1,2,i-2)=-dwacos2
2548           Ug2der(2,1,i-2)=-dwacos2
2549           Ug2der(2,2,i-2)=-dwasin2
2550         else
2551           obrot_der(1,i-2)=0.0d0
2552           obrot_der(2,i-2)=0.0d0
2553           Ugder(1,1,i-2)=0.0d0
2554           Ugder(1,2,i-2)=0.0d0
2555           Ugder(2,1,i-2)=0.0d0
2556           Ugder(2,2,i-2)=0.0d0
2557           obrot2_der(1,i-2)=0.0d0
2558           obrot2_der(2,i-2)=0.0d0
2559           Ug2der(1,1,i-2)=0.0d0
2560           Ug2der(1,2,i-2)=0.0d0
2561           Ug2der(2,1,i-2)=0.0d0
2562           Ug2der(2,2,i-2)=0.0d0
2563         endif
2564 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2565         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2566           iti = itortyp(itype(i-2))
2567         else
2568           iti=ntortyp+1
2569         endif
2570 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2571         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2572           iti1 = itortyp(itype(i-1))
2573         else
2574           iti1=ntortyp+1
2575         endif
2576 cd        write (iout,*) '*******i',i,' iti1',iti
2577 cd        write (iout,*) 'b1',b1(:,iti)
2578 cd        write (iout,*) 'b2',b2(:,iti)
2579 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2580 c        if (i .gt. iatel_s+2) then
2581         if (i .gt. nnt+2) then
2582           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2583           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2584           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2585      &    then
2586           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2587           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2588           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2589           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2590           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2591           endif
2592         else
2593           do k=1,2
2594             Ub2(k,i-2)=0.0d0
2595             Ctobr(k,i-2)=0.0d0
2596             Dtobr2(k,i-2)=0.0d0
2597             do l=1,2
2598               EUg(l,k,i-2)=0.0d0
2599               CUg(l,k,i-2)=0.0d0
2600               DUg(l,k,i-2)=0.0d0
2601               DtUg2(l,k,i-2)=0.0d0
2602             enddo
2603           enddo
2604         endif
2605         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2606         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2607         do k=1,2
2608           muder(k,i-2)=Ub2der(k,i-2)
2609         enddo
2610 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2611         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2612           iti1 = itortyp(itype(i-1))
2613         else
2614           iti1=ntortyp+1
2615         endif
2616         do k=1,2
2617           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2618         enddo
2619 cd        write (iout,*) 'mu ',mu(:,i-2)
2620 cd        write (iout,*) 'mu1',mu1(:,i-2)
2621 cd        write (iout,*) 'mu2',mu2(:,i-2)
2622         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2623      &  then
2624         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2625         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2626         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2627         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2628         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2629 C Vectors and matrices dependent on a single virtual-bond dihedral.
2630         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2631         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2632         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2633         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2634         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2635         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2636         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2637         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2638         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2639         endif
2640       enddo
2641 C Matrices dependent on two consecutive virtual-bond dihedrals.
2642 C The order of matrices is from left to right.
2643       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2644      &then
2645 c      do i=max0(ivec_start,2),ivec_end
2646       do i=2,nres-1
2647         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2648         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2649         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2650         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2651         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2652         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2653         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2654         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2655       enddo
2656       endif
2657 #if defined(MPI) && defined(PARMAT)
2658 #ifdef DEBUG
2659 c      if (fg_rank.eq.0) then
2660         write (iout,*) "Arrays UG and UGDER before GATHER"
2661         do i=1,nres-1
2662           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2663      &     ((ug(l,k,i),l=1,2),k=1,2),
2664      &     ((ugder(l,k,i),l=1,2),k=1,2)
2665         enddo
2666         write (iout,*) "Arrays UG2 and UG2DER"
2667         do i=1,nres-1
2668           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2669      &     ((ug2(l,k,i),l=1,2),k=1,2),
2670      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2671         enddo
2672         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2673         do i=1,nres-1
2674           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2675      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2676      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2677         enddo
2678         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2679         do i=1,nres-1
2680           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2681      &     costab(i),sintab(i),costab2(i),sintab2(i)
2682         enddo
2683         write (iout,*) "Array MUDER"
2684         do i=1,nres-1
2685           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2686         enddo
2687 c      endif
2688 #endif
2689       if (nfgtasks.gt.1) then
2690         time00=MPI_Wtime()
2691 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2692 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2693 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2694 #ifdef MATGATHER
2695         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2696      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2697      &   FG_COMM1,IERR)
2698         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2699      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2700      &   FG_COMM1,IERR)
2701         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2702      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2712      &   FG_COMM1,IERR)
2713         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2714      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2715      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2716         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2717      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2718      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2719         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2720      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2721      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2722         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2723      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2724      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2725         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2726      &  then
2727         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2743      &   ivec_count(fg_rank1),
2744      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2751      &   FG_COMM1,IERR)
2752         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2768      &   ivec_count(fg_rank1),
2769      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2773      &   FG_COMM1,IERR)
2774        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2779      &   FG_COMM1,IERR)
2780        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2781      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2782      &   FG_COMM1,IERR)
2783         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2784      &   ivec_count(fg_rank1),
2785      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2788      &   ivec_count(fg_rank1),
2789      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2790      &   FG_COMM1,IERR)
2791         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2792      &   ivec_count(fg_rank1),
2793      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2794      &   MPI_MAT2,FG_COMM1,IERR)
2795         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2796      &   ivec_count(fg_rank1),
2797      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2798      &   MPI_MAT2,FG_COMM1,IERR)
2799         endif
2800 #else
2801 c Passes matrix info through the ring
2802       isend=fg_rank1
2803       irecv=fg_rank1-1
2804       if (irecv.lt.0) irecv=nfgtasks1-1
2805       iprev=irecv
2806       inext=fg_rank1+1
2807       if (inext.ge.nfgtasks1) inext=0
2808       do i=1,nfgtasks1-1
2809 c        write (iout,*) "isend",isend," irecv",irecv
2810 c        call flush(iout)
2811         lensend=lentyp(isend)
2812         lenrecv=lentyp(irecv)
2813 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2814 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2815 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2816 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2817 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2818 c        write (iout,*) "Gather ROTAT1"
2819 c        call flush(iout)
2820 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2821 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2822 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2823 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2824 c        write (iout,*) "Gather ROTAT2"
2825 c        call flush(iout)
2826         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2827      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2828      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2829      &   iprev,4400+irecv,FG_COMM,status,IERR)
2830 c        write (iout,*) "Gather ROTAT_OLD"
2831 c        call flush(iout)
2832         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2833      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2834      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2835      &   iprev,5500+irecv,FG_COMM,status,IERR)
2836 c        write (iout,*) "Gather PRECOMP11"
2837 c        call flush(iout)
2838         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2839      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2840      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2841      &   iprev,6600+irecv,FG_COMM,status,IERR)
2842 c        write (iout,*) "Gather PRECOMP12"
2843 c        call flush(iout)
2844         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2845      &  then
2846         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2847      &   MPI_ROTAT2(lensend),inext,7700+isend,
2848      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2849      &   iprev,7700+irecv,FG_COMM,status,IERR)
2850 c        write (iout,*) "Gather PRECOMP21"
2851 c        call flush(iout)
2852         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2853      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2854      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2855      &   iprev,8800+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather PRECOMP22"
2857 c        call flush(iout)
2858         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2859      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2860      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2861      &   MPI_PRECOMP23(lenrecv),
2862      &   iprev,9900+irecv,FG_COMM,status,IERR)
2863 c        write (iout,*) "Gather PRECOMP23"
2864 c        call flush(iout)
2865         endif
2866         isend=irecv
2867         irecv=irecv-1
2868         if (irecv.lt.0) irecv=nfgtasks1-1
2869       enddo
2870 #endif
2871         time_gather=time_gather+MPI_Wtime()-time00
2872       endif
2873 #ifdef DEBUG
2874 c      if (fg_rank.eq.0) then
2875         write (iout,*) "Arrays UG and UGDER"
2876         do i=1,nres-1
2877           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2878      &     ((ug(l,k,i),l=1,2),k=1,2),
2879      &     ((ugder(l,k,i),l=1,2),k=1,2)
2880         enddo
2881         write (iout,*) "Arrays UG2 and UG2DER"
2882         do i=1,nres-1
2883           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2884      &     ((ug2(l,k,i),l=1,2),k=1,2),
2885      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2886         enddo
2887         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2888         do i=1,nres-1
2889           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2890      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2891      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2892         enddo
2893         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2894         do i=1,nres-1
2895           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2896      &     costab(i),sintab(i),costab2(i),sintab2(i)
2897         enddo
2898         write (iout,*) "Array MUDER"
2899         do i=1,nres-1
2900           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2901         enddo
2902 c      endif
2903 #endif
2904 #endif
2905 cd      do i=1,nres
2906 cd        iti = itortyp(itype(i))
2907 cd        write (iout,*) i
2908 cd        do j=1,2
2909 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2910 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2911 cd        enddo
2912 cd      enddo
2913       return
2914       end
2915 C--------------------------------------------------------------------------
2916       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2917 C
2918 C This subroutine calculates the average interaction energy and its gradient
2919 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2920 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2921 C The potential depends both on the distance of peptide-group centers and on
2922 C the orientation of the CA-CA virtual bonds.
2923 C
2924       implicit real*8 (a-h,o-z)
2925 #ifdef MPI
2926       include 'mpif.h'
2927 #endif
2928       include 'DIMENSIONS'
2929       include 'COMMON.CONTROL'
2930       include 'COMMON.SETUP'
2931       include 'COMMON.IOUNITS'
2932       include 'COMMON.GEO'
2933       include 'COMMON.VAR'
2934       include 'COMMON.LOCAL'
2935       include 'COMMON.CHAIN'
2936       include 'COMMON.DERIV'
2937       include 'COMMON.INTERACT'
2938       include 'COMMON.CONTACTS'
2939       include 'COMMON.TORSION'
2940       include 'COMMON.VECTORS'
2941       include 'COMMON.FFIELD'
2942       include 'COMMON.TIME1'
2943       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2944      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2945       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2946      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2947       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2948      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2949      &    num_conti,j1,j2
2950 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2951 #ifdef MOMENT
2952       double precision scal_el /1.0d0/
2953 #else
2954       double precision scal_el /0.5d0/
2955 #endif
2956 C 12/13/98
2957 C 13-go grudnia roku pamietnego...
2958       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2959      &                   0.0d0,1.0d0,0.0d0,
2960      &                   0.0d0,0.0d0,1.0d0/
2961 cd      write(iout,*) 'In EELEC'
2962 cd      do i=1,nloctyp
2963 cd        write(iout,*) 'Type',i
2964 cd        write(iout,*) 'B1',B1(:,i)
2965 cd        write(iout,*) 'B2',B2(:,i)
2966 cd        write(iout,*) 'CC',CC(:,:,i)
2967 cd        write(iout,*) 'DD',DD(:,:,i)
2968 cd        write(iout,*) 'EE',EE(:,:,i)
2969 cd      enddo
2970 cd      call check_vecgrad
2971 cd      stop
2972       if (icheckgrad.eq.1) then
2973         do i=1,nres-1
2974           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2975           do k=1,3
2976             dc_norm(k,i)=dc(k,i)*fac
2977           enddo
2978 c          write (iout,*) 'i',i,' fac',fac
2979         enddo
2980       endif
2981       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2982      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2983      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2984 c        call vec_and_deriv
2985 #ifdef TIMING
2986         time01=MPI_Wtime()
2987 #endif
2988         call set_matrices
2989 #ifdef TIMING
2990         time_mat=time_mat+MPI_Wtime()-time01
2991 #endif
2992       endif
2993 cd      do i=1,nres-1
2994 cd        write (iout,*) 'i=',i
2995 cd        do k=1,3
2996 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2997 cd        enddo
2998 cd        do k=1,3
2999 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3000 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3001 cd        enddo
3002 cd      enddo
3003       t_eelecij=0.0d0
3004       ees=0.0D0
3005       evdw1=0.0D0
3006       eel_loc=0.0d0
3007       eello_turn3=0.0d0
3008       eello_turn4=0.0d0
3009       ind=0
3010       do i=1,nres
3011         num_cont_hb(i)=0
3012       enddo
3013 cd      print '(a)','Enter EELEC'
3014 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3015       do i=1,nres
3016         gel_loc_loc(i)=0.0d0
3017         gcorr_loc(i)=0.0d0
3018       enddo
3019 c
3020 c
3021 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3022 C
3023 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3024 C
3025       do i=iturn3_start,iturn3_end
3026         dxi=dc(1,i)
3027         dyi=dc(2,i)
3028         dzi=dc(3,i)
3029         dx_normi=dc_norm(1,i)
3030         dy_normi=dc_norm(2,i)
3031         dz_normi=dc_norm(3,i)
3032         xmedi=c(1,i)+0.5d0*dxi
3033         ymedi=c(2,i)+0.5d0*dyi
3034         zmedi=c(3,i)+0.5d0*dzi
3035         num_conti=0
3036         call eelecij(i,i+2,ees,evdw1,eel_loc)
3037         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3038         num_cont_hb(i)=num_conti
3039       enddo
3040       do i=iturn4_start,iturn4_end
3041         dxi=dc(1,i)
3042         dyi=dc(2,i)
3043         dzi=dc(3,i)
3044         dx_normi=dc_norm(1,i)
3045         dy_normi=dc_norm(2,i)
3046         dz_normi=dc_norm(3,i)
3047         xmedi=c(1,i)+0.5d0*dxi
3048         ymedi=c(2,i)+0.5d0*dyi
3049         zmedi=c(3,i)+0.5d0*dzi
3050         num_conti=num_cont_hb(i)
3051         call eelecij(i,i+3,ees,evdw1,eel_loc)
3052         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3053         num_cont_hb(i)=num_conti
3054       enddo   ! i
3055 c
3056 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3057 c
3058       do i=iatel_s,iatel_e
3059         dxi=dc(1,i)
3060         dyi=dc(2,i)
3061         dzi=dc(3,i)
3062         dx_normi=dc_norm(1,i)
3063         dy_normi=dc_norm(2,i)
3064         dz_normi=dc_norm(3,i)
3065         xmedi=c(1,i)+0.5d0*dxi
3066         ymedi=c(2,i)+0.5d0*dyi
3067         zmedi=c(3,i)+0.5d0*dzi
3068 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3069         num_conti=num_cont_hb(i)
3070         do j=ielstart(i),ielend(i)
3071           call eelecij(i,j,ees,evdw1,eel_loc)
3072         enddo ! j
3073         num_cont_hb(i)=num_conti
3074       enddo   ! i
3075 c      write (iout,*) "Number of loop steps in EELEC:",ind
3076 cd      do i=1,nres
3077 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3078 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3079 cd      enddo
3080 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3081 ccc      eel_loc=eel_loc+eello_turn3
3082 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3083       return
3084       end
3085 C-------------------------------------------------------------------------------
3086       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3087       implicit real*8 (a-h,o-z)
3088       include 'DIMENSIONS'
3089 #ifdef MPI
3090       include "mpif.h"
3091 #endif
3092       include 'COMMON.CONTROL'
3093       include 'COMMON.IOUNITS'
3094       include 'COMMON.GEO'
3095       include 'COMMON.VAR'
3096       include 'COMMON.LOCAL'
3097       include 'COMMON.CHAIN'
3098       include 'COMMON.DERIV'
3099       include 'COMMON.INTERACT'
3100       include 'COMMON.CONTACTS'
3101       include 'COMMON.TORSION'
3102       include 'COMMON.VECTORS'
3103       include 'COMMON.FFIELD'
3104       include 'COMMON.TIME1'
3105       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3106      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3107       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3108      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3109       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3110      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3111      &    num_conti,j1,j2
3112 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3113 #ifdef MOMENT
3114       double precision scal_el /1.0d0/
3115 #else
3116       double precision scal_el /0.5d0/
3117 #endif
3118 C 12/13/98
3119 C 13-go grudnia roku pamietnego...
3120       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3121      &                   0.0d0,1.0d0,0.0d0,
3122      &                   0.0d0,0.0d0,1.0d0/
3123 c          time00=MPI_Wtime()
3124 cd      write (iout,*) "eelecij",i,j
3125 c          ind=ind+1
3126           iteli=itel(i)
3127           itelj=itel(j)
3128           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3129           aaa=app(iteli,itelj)
3130           bbb=bpp(iteli,itelj)
3131           ael6i=ael6(iteli,itelj)
3132           ael3i=ael3(iteli,itelj)
3133           dxj=dc(1,j)
3134           dyj=dc(2,j)
3135           dzj=dc(3,j)
3136           dx_normj=dc_norm(1,j)
3137           dy_normj=dc_norm(2,j)
3138           dz_normj=dc_norm(3,j)
3139           xj=c(1,j)+0.5D0*dxj-xmedi
3140           yj=c(2,j)+0.5D0*dyj-ymedi
3141           zj=c(3,j)+0.5D0*dzj-zmedi
3142           rij=xj*xj+yj*yj+zj*zj
3143           rrmij=1.0D0/rij
3144           rij=dsqrt(rij)
3145           rmij=1.0D0/rij
3146           r3ij=rrmij*rmij
3147           r6ij=r3ij*r3ij
3148           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3149           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3150           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3151           fac=cosa-3.0D0*cosb*cosg
3152           ev1=aaa*r6ij*r6ij
3153 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3154           if (j.eq.i+2) ev1=scal_el*ev1
3155           ev2=bbb*r6ij
3156           fac3=ael6i*r6ij
3157           fac4=ael3i*r3ij
3158           evdwij=ev1+ev2
3159           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3160           el2=fac4*fac
3161           eesij=el1+el2
3162 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3163           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3164           ees=ees+eesij
3165           evdw1=evdw1+evdwij
3166 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3167 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3168 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3169 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3170
3171           if (energy_dec) then
3172               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3173               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3174           endif
3175
3176 C
3177 C Calculate contributions to the Cartesian gradient.
3178 C
3179 #ifdef SPLITELE
3180           facvdw=-6*rrmij*(ev1+evdwij)
3181           facel=-3*rrmij*(el1+eesij)
3182           fac1=fac
3183           erij(1)=xj*rmij
3184           erij(2)=yj*rmij
3185           erij(3)=zj*rmij
3186 *
3187 * Radial derivatives. First process both termini of the fragment (i,j)
3188 *
3189           ggg(1)=facel*xj
3190           ggg(2)=facel*yj
3191           ggg(3)=facel*zj
3192 c          do k=1,3
3193 c            ghalf=0.5D0*ggg(k)
3194 c            gelc(k,i)=gelc(k,i)+ghalf
3195 c            gelc(k,j)=gelc(k,j)+ghalf
3196 c          enddo
3197 c 9/28/08 AL Gradient compotents will be summed only at the end
3198           do k=1,3
3199             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3200             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3201           enddo
3202 *
3203 * Loop over residues i+1 thru j-1.
3204 *
3205 cgrad          do k=i+1,j-1
3206 cgrad            do l=1,3
3207 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3208 cgrad            enddo
3209 cgrad          enddo
3210           ggg(1)=facvdw*xj
3211           ggg(2)=facvdw*yj
3212           ggg(3)=facvdw*zj
3213 c          do k=1,3
3214 c            ghalf=0.5D0*ggg(k)
3215 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3216 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3217 c          enddo
3218 c 9/28/08 AL Gradient compotents will be summed only at the end
3219           do k=1,3
3220             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3221             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3222           enddo
3223 *
3224 * Loop over residues i+1 thru j-1.
3225 *
3226 cgrad          do k=i+1,j-1
3227 cgrad            do l=1,3
3228 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3229 cgrad            enddo
3230 cgrad          enddo
3231 #else
3232           facvdw=ev1+evdwij
3233           facel=el1+eesij
3234           fac1=fac
3235           fac=-3*rrmij*(facvdw+facvdw+facel)
3236           erij(1)=xj*rmij
3237           erij(2)=yj*rmij
3238           erij(3)=zj*rmij
3239 *
3240 * Radial derivatives. First process both termini of the fragment (i,j)
3241 *
3242           ggg(1)=fac*xj
3243           ggg(2)=fac*yj
3244           ggg(3)=fac*zj
3245 c          do k=1,3
3246 c            ghalf=0.5D0*ggg(k)
3247 c            gelc(k,i)=gelc(k,i)+ghalf
3248 c            gelc(k,j)=gelc(k,j)+ghalf
3249 c          enddo
3250 c 9/28/08 AL Gradient compotents will be summed only at the end
3251           do k=1,3
3252             gelc_long(k,j)=gelc(k,j)+ggg(k)
3253             gelc_long(k,i)=gelc(k,i)-ggg(k)
3254           enddo
3255 *
3256 * Loop over residues i+1 thru j-1.
3257 *
3258 cgrad          do k=i+1,j-1
3259 cgrad            do l=1,3
3260 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3261 cgrad            enddo
3262 cgrad          enddo
3263 c 9/28/08 AL Gradient compotents will be summed only at the end
3264           ggg(1)=facvdw*xj
3265           ggg(2)=facvdw*yj
3266           ggg(3)=facvdw*zj
3267           do k=1,3
3268             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3269             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3270           enddo
3271 #endif
3272 *
3273 * Angular part
3274 *
3275           ecosa=2.0D0*fac3*fac1+fac4
3276           fac4=-3.0D0*fac4
3277           fac3=-6.0D0*fac3
3278           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3279           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3280           do k=1,3
3281             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3282             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3283           enddo
3284 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3285 cd   &          (dcosg(k),k=1,3)
3286           do k=1,3
3287             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3288           enddo
3289 c          do k=1,3
3290 c            ghalf=0.5D0*ggg(k)
3291 c            gelc(k,i)=gelc(k,i)+ghalf
3292 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3293 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3294 c            gelc(k,j)=gelc(k,j)+ghalf
3295 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3296 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3297 c          enddo
3298 cgrad          do k=i+1,j-1
3299 cgrad            do l=1,3
3300 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3301 cgrad            enddo
3302 cgrad          enddo
3303           do k=1,3
3304             gelc(k,i)=gelc(k,i)
3305      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3306      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3307             gelc(k,j)=gelc(k,j)
3308      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3309      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3310             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3311             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3312           enddo
3313           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3314      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3315      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3316 C
3317 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3318 C   energy of a peptide unit is assumed in the form of a second-order
3319 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3320 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3321 C   are computed for EVERY pair of non-contiguous peptide groups.
3322 C
3323           if (j.lt.nres-1) then
3324             j1=j+1
3325             j2=j-1
3326           else
3327             j1=j-1
3328             j2=j-2
3329           endif
3330           kkk=0
3331           do k=1,2
3332             do l=1,2
3333               kkk=kkk+1
3334               muij(kkk)=mu(k,i)*mu(l,j)
3335             enddo
3336           enddo
3337 cd         write (iout,*) 'EELEC: i',i,' j',j
3338 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3339 cd          write(iout,*) 'muij',muij
3340           ury=scalar(uy(1,i),erij)
3341           urz=scalar(uz(1,i),erij)
3342           vry=scalar(uy(1,j),erij)
3343           vrz=scalar(uz(1,j),erij)
3344           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3345           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3346           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3347           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3348           fac=dsqrt(-ael6i)*r3ij
3349           a22=a22*fac
3350           a23=a23*fac
3351           a32=a32*fac
3352           a33=a33*fac
3353 cd          write (iout,'(4i5,4f10.5)')
3354 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3355 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3356 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3357 cd     &      uy(:,j),uz(:,j)
3358 cd          write (iout,'(4f10.5)')
3359 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3360 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3361 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3362 cd           write (iout,'(9f10.5/)')
3363 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3364 C Derivatives of the elements of A in virtual-bond vectors
3365           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3366           do k=1,3
3367             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3368             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3369             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3370             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3371             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3372             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3373             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3374             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3375             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3376             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3377             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3378             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3379           enddo
3380 C Compute radial contributions to the gradient
3381           facr=-3.0d0*rrmij
3382           a22der=a22*facr
3383           a23der=a23*facr
3384           a32der=a32*facr
3385           a33der=a33*facr
3386           agg(1,1)=a22der*xj
3387           agg(2,1)=a22der*yj
3388           agg(3,1)=a22der*zj
3389           agg(1,2)=a23der*xj
3390           agg(2,2)=a23der*yj
3391           agg(3,2)=a23der*zj
3392           agg(1,3)=a32der*xj
3393           agg(2,3)=a32der*yj
3394           agg(3,3)=a32der*zj
3395           agg(1,4)=a33der*xj
3396           agg(2,4)=a33der*yj
3397           agg(3,4)=a33der*zj
3398 C Add the contributions coming from er
3399           fac3=-3.0d0*fac
3400           do k=1,3
3401             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3402             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3403             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3404             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3405           enddo
3406           do k=1,3
3407 C Derivatives in DC(i)
3408 cgrad            ghalf1=0.5d0*agg(k,1)
3409 cgrad            ghalf2=0.5d0*agg(k,2)
3410 cgrad            ghalf3=0.5d0*agg(k,3)
3411 cgrad            ghalf4=0.5d0*agg(k,4)
3412             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3413      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3414             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3415      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3416             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3417      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3418             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3419      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3420 C Derivatives in DC(i+1)
3421             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3422      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3423             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3424      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3425             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3426      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3427             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3428      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3429 C Derivatives in DC(j)
3430             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3431      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3432             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3433      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3434             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3435      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3436             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3437      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3438 C Derivatives in DC(j+1) or DC(nres-1)
3439             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3440      &      -3.0d0*vryg(k,3)*ury)
3441             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3442      &      -3.0d0*vrzg(k,3)*ury)
3443             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3444      &      -3.0d0*vryg(k,3)*urz)
3445             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3446      &      -3.0d0*vrzg(k,3)*urz)
3447 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3448 cgrad              do l=1,4
3449 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3450 cgrad              enddo
3451 cgrad            endif
3452           enddo
3453           acipa(1,1)=a22
3454           acipa(1,2)=a23
3455           acipa(2,1)=a32
3456           acipa(2,2)=a33
3457           a22=-a22
3458           a23=-a23
3459           do l=1,2
3460             do k=1,3
3461               agg(k,l)=-agg(k,l)
3462               aggi(k,l)=-aggi(k,l)
3463               aggi1(k,l)=-aggi1(k,l)
3464               aggj(k,l)=-aggj(k,l)
3465               aggj1(k,l)=-aggj1(k,l)
3466             enddo
3467           enddo
3468           if (j.lt.nres-1) then
3469             a22=-a22
3470             a32=-a32
3471             do l=1,3,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           else
3481             a22=-a22
3482             a23=-a23
3483             a32=-a32
3484             a33=-a33
3485             do l=1,4
3486               do k=1,3
3487                 agg(k,l)=-agg(k,l)
3488                 aggi(k,l)=-aggi(k,l)
3489                 aggi1(k,l)=-aggi1(k,l)
3490                 aggj(k,l)=-aggj(k,l)
3491                 aggj1(k,l)=-aggj1(k,l)
3492               enddo
3493             enddo
3494           endif
3495           ENDIF ! WCORR
3496           IF (wel_loc.gt.0.0d0) THEN
3497 C Contribution to the local-electrostatic energy coming from the i-j pair
3498           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3499      &     +a33*muij(4)
3500 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3501
3502           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3503      &            'eelloc',i,j,eel_loc_ij
3504
3505           eel_loc=eel_loc+eel_loc_ij
3506 C Partial derivatives in virtual-bond dihedral angles gamma
3507           if (i.gt.1)
3508      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3509      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3510      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3511           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3512      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3513      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3514 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3515           do l=1,3
3516             ggg(l)=agg(l,1)*muij(1)+
3517      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3518             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3519             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3520 cgrad            ghalf=0.5d0*ggg(l)
3521 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3522 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3523           enddo
3524 cgrad          do k=i+1,j2
3525 cgrad            do l=1,3
3526 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3527 cgrad            enddo
3528 cgrad          enddo
3529 C Remaining derivatives of eello
3530           do l=1,3
3531             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3532      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3533             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3534      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3535             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3536      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3537             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3538      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3539           enddo
3540           ENDIF
3541 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3542 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3543           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3544      &       .and. num_conti.le.maxconts) then
3545 c            write (iout,*) i,j," entered corr"
3546 C
3547 C Calculate the contact function. The ith column of the array JCONT will
3548 C contain the numbers of atoms that make contacts with the atom I (of numbers
3549 C greater than I). The arrays FACONT and GACONT will contain the values of
3550 C the contact function and its derivative.
3551 c           r0ij=1.02D0*rpp(iteli,itelj)
3552 c           r0ij=1.11D0*rpp(iteli,itelj)
3553             r0ij=2.20D0*rpp(iteli,itelj)
3554 c           r0ij=1.55D0*rpp(iteli,itelj)
3555             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3556             if (fcont.gt.0.0D0) then
3557               num_conti=num_conti+1
3558               if (num_conti.gt.maxconts) then
3559                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3560      &                         ' will skip next contacts for this conf.'
3561               else
3562                 jcont_hb(num_conti,i)=j
3563 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3564 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3565                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3566      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3567 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3568 C  terms.
3569                 d_cont(num_conti,i)=rij
3570 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3571 C     --- Electrostatic-interaction matrix ---
3572                 a_chuj(1,1,num_conti,i)=a22
3573                 a_chuj(1,2,num_conti,i)=a23
3574                 a_chuj(2,1,num_conti,i)=a32
3575                 a_chuj(2,2,num_conti,i)=a33
3576 C     --- Gradient of rij
3577                 do kkk=1,3
3578                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3579                 enddo
3580                 kkll=0
3581                 do k=1,2
3582                   do l=1,2
3583                     kkll=kkll+1
3584                     do m=1,3
3585                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3586                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3587                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3588                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3589                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3590                     enddo
3591                   enddo
3592                 enddo
3593                 ENDIF
3594                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3595 C Calculate contact energies
3596                 cosa4=4.0D0*cosa
3597                 wij=cosa-3.0D0*cosb*cosg
3598                 cosbg1=cosb+cosg
3599                 cosbg2=cosb-cosg
3600 c               fac3=dsqrt(-ael6i)/r0ij**3
3601                 fac3=dsqrt(-ael6i)*r3ij
3602 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3603                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3604                 if (ees0tmp.gt.0) then
3605                   ees0pij=dsqrt(ees0tmp)
3606                 else
3607                   ees0pij=0
3608                 endif
3609 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3610                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3611                 if (ees0tmp.gt.0) then
3612                   ees0mij=dsqrt(ees0tmp)
3613                 else
3614                   ees0mij=0
3615                 endif
3616 c               ees0mij=0.0D0
3617                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3618                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3619 C Diagnostics. Comment out or remove after debugging!
3620 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3621 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3622 c               ees0m(num_conti,i)=0.0D0
3623 C End diagnostics.
3624 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3625 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3626 C Angular derivatives of the contact function
3627                 ees0pij1=fac3/ees0pij
3628                 ees0mij1=fac3/ees0mij
3629                 fac3p=-3.0D0*fac3*rrmij
3630                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3631                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3632 c               ees0mij1=0.0D0
3633                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3634                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3635                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3636                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3637                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3638                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3639                 ecosap=ecosa1+ecosa2
3640                 ecosbp=ecosb1+ecosb2
3641                 ecosgp=ecosg1+ecosg2
3642                 ecosam=ecosa1-ecosa2
3643                 ecosbm=ecosb1-ecosb2
3644                 ecosgm=ecosg1-ecosg2
3645 C Diagnostics
3646 c               ecosap=ecosa1
3647 c               ecosbp=ecosb1
3648 c               ecosgp=ecosg1
3649 c               ecosam=0.0D0
3650 c               ecosbm=0.0D0
3651 c               ecosgm=0.0D0
3652 C End diagnostics
3653                 facont_hb(num_conti,i)=fcont
3654                 fprimcont=fprimcont/rij
3655 cd              facont_hb(num_conti,i)=1.0D0
3656 C Following line is for diagnostics.
3657 cd              fprimcont=0.0D0
3658                 do k=1,3
3659                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3660                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3661                 enddo
3662                 do k=1,3
3663                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3664                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3665                 enddo
3666                 gggp(1)=gggp(1)+ees0pijp*xj
3667                 gggp(2)=gggp(2)+ees0pijp*yj
3668                 gggp(3)=gggp(3)+ees0pijp*zj
3669                 gggm(1)=gggm(1)+ees0mijp*xj
3670                 gggm(2)=gggm(2)+ees0mijp*yj
3671                 gggm(3)=gggm(3)+ees0mijp*zj
3672 C Derivatives due to the contact function
3673                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3674                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3675                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3676                 do k=1,3
3677 c
3678 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3679 c          following the change of gradient-summation algorithm.
3680 c
3681 cgrad                  ghalfp=0.5D0*gggp(k)
3682 cgrad                  ghalfm=0.5D0*gggm(k)
3683                   gacontp_hb1(k,num_conti,i)=!ghalfp
3684      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3685      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3686                   gacontp_hb2(k,num_conti,i)=!ghalfp
3687      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3688      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3689                   gacontp_hb3(k,num_conti,i)=gggp(k)
3690                   gacontm_hb1(k,num_conti,i)=!ghalfm
3691      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3692      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3693                   gacontm_hb2(k,num_conti,i)=!ghalfm
3694      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3695      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3696                   gacontm_hb3(k,num_conti,i)=gggm(k)
3697                 enddo
3698 C Diagnostics. Comment out or remove after debugging!
3699 cdiag           do k=1,3
3700 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3701 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3702 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3703 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3704 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3705 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3706 cdiag           enddo
3707               ENDIF ! wcorr
3708               endif  ! num_conti.le.maxconts
3709             endif  ! fcont.gt.0
3710           endif    ! j.gt.i+1
3711           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3712             do k=1,4
3713               do l=1,3
3714                 ghalf=0.5d0*agg(l,k)
3715                 aggi(l,k)=aggi(l,k)+ghalf
3716                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3717                 aggj(l,k)=aggj(l,k)+ghalf
3718               enddo
3719             enddo
3720             if (j.eq.nres-1 .and. i.lt.j-2) then
3721               do k=1,4
3722                 do l=1,3
3723                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3724                 enddo
3725               enddo
3726             endif
3727           endif
3728 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3729       return
3730       end
3731 C-----------------------------------------------------------------------------
3732       subroutine eturn3(i,eello_turn3)
3733 C Third- and fourth-order contributions from turns
3734       implicit real*8 (a-h,o-z)
3735       include 'DIMENSIONS'
3736       include 'COMMON.IOUNITS'
3737       include 'COMMON.GEO'
3738       include 'COMMON.VAR'
3739       include 'COMMON.LOCAL'
3740       include 'COMMON.CHAIN'
3741       include 'COMMON.DERIV'
3742       include 'COMMON.INTERACT'
3743       include 'COMMON.CONTACTS'
3744       include 'COMMON.TORSION'
3745       include 'COMMON.VECTORS'
3746       include 'COMMON.FFIELD'
3747       include 'COMMON.CONTROL'
3748       dimension ggg(3)
3749       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3750      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3751      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3752       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3753      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3754       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3755      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3756      &    num_conti,j1,j2
3757       j=i+2
3758 c      write (iout,*) "eturn3",i,j,j1,j2
3759       a_temp(1,1)=a22
3760       a_temp(1,2)=a23
3761       a_temp(2,1)=a32
3762       a_temp(2,2)=a33
3763 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3764 C
3765 C               Third-order contributions
3766 C
3767 C                 (i+2)o----(i+3)
3768 C                      | |
3769 C                      | |
3770 C                 (i+1)o----i
3771 C
3772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3773 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3774         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3775         call transpose2(auxmat(1,1),auxmat1(1,1))
3776         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3777         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3778         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3779      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3780 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3781 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3782 cd     &    ' eello_turn3_num',4*eello_turn3_num
3783 C Derivatives in gamma(i)
3784         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3785         call transpose2(auxmat2(1,1),auxmat3(1,1))
3786         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3787         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3788 C Derivatives in gamma(i+1)
3789         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3790         call transpose2(auxmat2(1,1),auxmat3(1,1))
3791         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3792         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3793      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3794 C Cartesian derivatives
3795         do l=1,3
3796 c            ghalf1=0.5d0*agg(l,1)
3797 c            ghalf2=0.5d0*agg(l,2)
3798 c            ghalf3=0.5d0*agg(l,3)
3799 c            ghalf4=0.5d0*agg(l,4)
3800           a_temp(1,1)=aggi(l,1)!+ghalf1
3801           a_temp(1,2)=aggi(l,2)!+ghalf2
3802           a_temp(2,1)=aggi(l,3)!+ghalf3
3803           a_temp(2,2)=aggi(l,4)!+ghalf4
3804           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3805           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3806      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3807           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3808           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3809           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3810           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3811           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3812           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3813      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3814           a_temp(1,1)=aggj(l,1)!+ghalf1
3815           a_temp(1,2)=aggj(l,2)!+ghalf2
3816           a_temp(2,1)=aggj(l,3)!+ghalf3
3817           a_temp(2,2)=aggj(l,4)!+ghalf4
3818           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3819           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3820      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3821           a_temp(1,1)=aggj1(l,1)
3822           a_temp(1,2)=aggj1(l,2)
3823           a_temp(2,1)=aggj1(l,3)
3824           a_temp(2,2)=aggj1(l,4)
3825           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3826           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3827      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3828         enddo
3829       return
3830       end
3831 C-------------------------------------------------------------------------------
3832       subroutine eturn4(i,eello_turn4)
3833 C Third- and fourth-order contributions from turns
3834       implicit real*8 (a-h,o-z)
3835       include 'DIMENSIONS'
3836       include 'COMMON.IOUNITS'
3837       include 'COMMON.GEO'
3838       include 'COMMON.VAR'
3839       include 'COMMON.LOCAL'
3840       include 'COMMON.CHAIN'
3841       include 'COMMON.DERIV'
3842       include 'COMMON.INTERACT'
3843       include 'COMMON.CONTACTS'
3844       include 'COMMON.TORSION'
3845       include 'COMMON.VECTORS'
3846       include 'COMMON.FFIELD'
3847       include 'COMMON.CONTROL'
3848       dimension ggg(3)
3849       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3850      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3851      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3852       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3853      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3854       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3855      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3856      &    num_conti,j1,j2
3857       j=i+3
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 C
3860 C               Fourth-order contributions
3861 C
3862 C                 (i+3)o----(i+4)
3863 C                     /  |
3864 C               (i+2)o   |
3865 C                     \  |
3866 C                 (i+1)o----i
3867 C
3868 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3869 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3870 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3871         a_temp(1,1)=a22
3872         a_temp(1,2)=a23
3873         a_temp(2,1)=a32
3874         a_temp(2,2)=a33
3875         iti1=itortyp(itype(i+1))
3876         iti2=itortyp(itype(i+2))
3877         iti3=itortyp(itype(i+3))
3878 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3879         call transpose2(EUg(1,1,i+1),e1t(1,1))
3880         call transpose2(Eug(1,1,i+2),e2t(1,1))
3881         call transpose2(Eug(1,1,i+3),e3t(1,1))
3882         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3883         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3884         s1=scalar2(b1(1,iti2),auxvec(1))
3885         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3886         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3887         s2=scalar2(b1(1,iti1),auxvec(1))
3888         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3889         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3890         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3891         eello_turn4=eello_turn4-(s1+s2+s3)
3892         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3893      &      'eturn4',i,j,-(s1+s2+s3)
3894 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3895 cd     &    ' eello_turn4_num',8*eello_turn4_num
3896 C Derivatives in gamma(i)
3897         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3898         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3899         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3900         s1=scalar2(b1(1,iti2),auxvec(1))
3901         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3902         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3904 C Derivatives in gamma(i+1)
3905         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3906         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3907         s2=scalar2(b1(1,iti1),auxvec(1))
3908         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3909         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3911         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3912 C Derivatives in gamma(i+2)
3913         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3914         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3915         s1=scalar2(b1(1,iti2),auxvec(1))
3916         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3917         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3918         s2=scalar2(b1(1,iti1),auxvec(1))
3919         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3920         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3921         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3923 C Cartesian derivatives
3924 C Derivatives of this turn contributions in DC(i+2)
3925         if (j.lt.nres-1) then
3926           do l=1,3
3927             a_temp(1,1)=agg(l,1)
3928             a_temp(1,2)=agg(l,2)
3929             a_temp(2,1)=agg(l,3)
3930             a_temp(2,2)=agg(l,4)
3931             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3932             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3933             s1=scalar2(b1(1,iti2),auxvec(1))
3934             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3935             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3936             s2=scalar2(b1(1,iti1),auxvec(1))
3937             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3938             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3939             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3940             ggg(l)=-(s1+s2+s3)
3941             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3942           enddo
3943         endif
3944 C Remaining derivatives of this turn contribution
3945         do l=1,3
3946           a_temp(1,1)=aggi(l,1)
3947           a_temp(1,2)=aggi(l,2)
3948           a_temp(2,1)=aggi(l,3)
3949           a_temp(2,2)=aggi(l,4)
3950           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3951           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3952           s1=scalar2(b1(1,iti2),auxvec(1))
3953           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3954           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3955           s2=scalar2(b1(1,iti1),auxvec(1))
3956           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3957           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3958           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3960           a_temp(1,1)=aggi1(l,1)
3961           a_temp(1,2)=aggi1(l,2)
3962           a_temp(2,1)=aggi1(l,3)
3963           a_temp(2,2)=aggi1(l,4)
3964           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966           s1=scalar2(b1(1,iti2),auxvec(1))
3967           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969           s2=scalar2(b1(1,iti1),auxvec(1))
3970           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3974           a_temp(1,1)=aggj(l,1)
3975           a_temp(1,2)=aggj(l,2)
3976           a_temp(2,1)=aggj(l,3)
3977           a_temp(2,2)=aggj(l,4)
3978           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3979           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3980           s1=scalar2(b1(1,iti2),auxvec(1))
3981           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3982           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3983           s2=scalar2(b1(1,iti1),auxvec(1))
3984           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3985           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3986           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3988           a_temp(1,1)=aggj1(l,1)
3989           a_temp(1,2)=aggj1(l,2)
3990           a_temp(2,1)=aggj1(l,3)
3991           a_temp(2,2)=aggj1(l,4)
3992           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3993           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3994           s1=scalar2(b1(1,iti2),auxvec(1))
3995           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3996           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3997           s2=scalar2(b1(1,iti1),auxvec(1))
3998           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3999           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4000           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4001 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4002           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4003         enddo
4004       return
4005       end
4006 C-----------------------------------------------------------------------------
4007       subroutine vecpr(u,v,w)
4008       implicit real*8(a-h,o-z)
4009       dimension u(3),v(3),w(3)
4010       w(1)=u(2)*v(3)-u(3)*v(2)
4011       w(2)=-u(1)*v(3)+u(3)*v(1)
4012       w(3)=u(1)*v(2)-u(2)*v(1)
4013       return
4014       end
4015 C-----------------------------------------------------------------------------
4016       subroutine unormderiv(u,ugrad,unorm,ungrad)
4017 C This subroutine computes the derivatives of a normalized vector u, given
4018 C the derivatives computed without normalization conditions, ugrad. Returns
4019 C ungrad.
4020       implicit none
4021       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4022       double precision vec(3)
4023       double precision scalar
4024       integer i,j
4025 c      write (2,*) 'ugrad',ugrad
4026 c      write (2,*) 'u',u
4027       do i=1,3
4028         vec(i)=scalar(ugrad(1,i),u(1))
4029       enddo
4030 c      write (2,*) 'vec',vec
4031       do i=1,3
4032         do j=1,3
4033           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4034         enddo
4035       enddo
4036 c      write (2,*) 'ungrad',ungrad
4037       return
4038       end
4039 C-----------------------------------------------------------------------------
4040       subroutine escp_soft_sphere(evdw2,evdw2_14)
4041 C
4042 C This subroutine calculates the excluded-volume interaction energy between
4043 C peptide-group centers and side chains and its gradient in virtual-bond and
4044 C side-chain vectors.
4045 C
4046       implicit real*8 (a-h,o-z)
4047       include 'DIMENSIONS'
4048       include 'COMMON.GEO'
4049       include 'COMMON.VAR'
4050       include 'COMMON.LOCAL'
4051       include 'COMMON.CHAIN'
4052       include 'COMMON.DERIV'
4053       include 'COMMON.INTERACT'
4054       include 'COMMON.FFIELD'
4055       include 'COMMON.IOUNITS'
4056       include 'COMMON.CONTROL'
4057       dimension ggg(3)
4058       evdw2=0.0D0
4059       evdw2_14=0.0d0
4060       r0_scp=4.5d0
4061 cd    print '(a)','Enter ESCP'
4062 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4063       do i=iatscp_s,iatscp_e
4064         iteli=itel(i)
4065         xi=0.5D0*(c(1,i)+c(1,i+1))
4066         yi=0.5D0*(c(2,i)+c(2,i+1))
4067         zi=0.5D0*(c(3,i)+c(3,i+1))
4068
4069         do iint=1,nscp_gr(i)
4070
4071         do j=iscpstart(i,iint),iscpend(i,iint)
4072           itypj=itype(j)
4073 C Uncomment following three lines for SC-p interactions
4074 c         xj=c(1,nres+j)-xi
4075 c         yj=c(2,nres+j)-yi
4076 c         zj=c(3,nres+j)-zi
4077 C Uncomment following three lines for Ca-p interactions
4078           xj=c(1,j)-xi
4079           yj=c(2,j)-yi
4080           zj=c(3,j)-zi
4081           rij=xj*xj+yj*yj+zj*zj
4082           r0ij=r0_scp
4083           r0ijsq=r0ij*r0ij
4084           if (rij.lt.r0ijsq) then
4085             evdwij=0.25d0*(rij-r0ijsq)**2
4086             fac=rij-r0ijsq
4087           else
4088             evdwij=0.0d0
4089             fac=0.0d0
4090           endif
4091           evdw2=evdw2+evdwij
4092 C
4093 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4094 C
4095           ggg(1)=xj*fac
4096           ggg(2)=yj*fac
4097           ggg(3)=zj*fac
4098 cgrad          if (j.lt.i) then
4099 cd          write (iout,*) 'j<i'
4100 C Uncomment following three lines for SC-p interactions
4101 c           do k=1,3
4102 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4103 c           enddo
4104 cgrad          else
4105 cd          write (iout,*) 'j>i'
4106 cgrad            do k=1,3
4107 cgrad              ggg(k)=-ggg(k)
4108 C Uncomment following line for SC-p interactions
4109 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4110 cgrad            enddo
4111 cgrad          endif
4112 cgrad          do k=1,3
4113 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4114 cgrad          enddo
4115 cgrad          kstart=min0(i+1,j)
4116 cgrad          kend=max0(i-1,j-1)
4117 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4118 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4119 cgrad          do k=kstart,kend
4120 cgrad            do l=1,3
4121 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4122 cgrad            enddo
4123 cgrad          enddo
4124           do k=1,3
4125             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4126             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4127           enddo
4128         enddo
4129
4130         enddo ! iint
4131       enddo ! i
4132       return
4133       end
4134 C-----------------------------------------------------------------------------
4135       subroutine escp(evdw2,evdw2_14)
4136 C
4137 C This subroutine calculates the excluded-volume interaction energy between
4138 C peptide-group centers and side chains and its gradient in virtual-bond and
4139 C side-chain vectors.
4140 C
4141       implicit real*8 (a-h,o-z)
4142       include 'DIMENSIONS'
4143       include 'COMMON.GEO'
4144       include 'COMMON.VAR'
4145       include 'COMMON.LOCAL'
4146       include 'COMMON.CHAIN'
4147       include 'COMMON.DERIV'
4148       include 'COMMON.INTERACT'
4149       include 'COMMON.FFIELD'
4150       include 'COMMON.IOUNITS'
4151       include 'COMMON.CONTROL'
4152       dimension ggg(3)
4153       evdw2=0.0D0
4154       evdw2_14=0.0d0
4155 cd    print '(a)','Enter ESCP'
4156 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4157       do i=iatscp_s,iatscp_e
4158         iteli=itel(i)
4159         xi=0.5D0*(c(1,i)+c(1,i+1))
4160         yi=0.5D0*(c(2,i)+c(2,i+1))
4161         zi=0.5D0*(c(3,i)+c(3,i+1))
4162
4163         do iint=1,nscp_gr(i)
4164
4165         do j=iscpstart(i,iint),iscpend(i,iint)
4166           itypj=itype(j)
4167 C Uncomment following three lines for SC-p interactions
4168 c         xj=c(1,nres+j)-xi
4169 c         yj=c(2,nres+j)-yi
4170 c         zj=c(3,nres+j)-zi
4171 C Uncomment following three lines for Ca-p interactions
4172           xj=c(1,j)-xi
4173           yj=c(2,j)-yi
4174           zj=c(3,j)-zi
4175           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4176           fac=rrij**expon2
4177           e1=fac*fac*aad(itypj,iteli)
4178           e2=fac*bad(itypj,iteli)
4179           if (iabs(j-i) .le. 2) then
4180             e1=scal14*e1
4181             e2=scal14*e2
4182             evdw2_14=evdw2_14+e1+e2
4183           endif
4184           evdwij=e1+e2
4185           evdw2=evdw2+evdwij
4186           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4187      &        'evdw2',i,j,evdwij
4188 C
4189 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4190 C
4191           fac=-(evdwij+e1)*rrij
4192           ggg(1)=xj*fac
4193           ggg(2)=yj*fac
4194           ggg(3)=zj*fac
4195 cgrad          if (j.lt.i) then
4196 cd          write (iout,*) 'j<i'
4197 C Uncomment following three lines for SC-p interactions
4198 c           do k=1,3
4199 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4200 c           enddo
4201 cgrad          else
4202 cd          write (iout,*) 'j>i'
4203 cgrad            do k=1,3
4204 cgrad              ggg(k)=-ggg(k)
4205 C Uncomment following line for SC-p interactions
4206 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4207 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4208 cgrad            enddo
4209 cgrad          endif
4210 cgrad          do k=1,3
4211 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4212 cgrad          enddo
4213 cgrad          kstart=min0(i+1,j)
4214 cgrad          kend=max0(i-1,j-1)
4215 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4216 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4217 cgrad          do k=kstart,kend
4218 cgrad            do l=1,3
4219 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4220 cgrad            enddo
4221 cgrad          enddo
4222           do k=1,3
4223             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4224             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4225           enddo
4226         enddo
4227
4228         enddo ! iint
4229       enddo ! i
4230       do i=1,nct
4231         do j=1,3
4232           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4233           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4234           gradx_scp(j,i)=expon*gradx_scp(j,i)
4235         enddo
4236       enddo
4237 C******************************************************************************
4238 C
4239 C                              N O T E !!!
4240 C
4241 C To save time the factor EXPON has been extracted from ALL components
4242 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4243 C use!
4244 C
4245 C******************************************************************************
4246       return
4247       end
4248 C--------------------------------------------------------------------------
4249       subroutine edis(ehpb)
4250 C
4251 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4252 C
4253       implicit real*8 (a-h,o-z)
4254       include 'DIMENSIONS'
4255       include 'COMMON.SBRIDGE'
4256       include 'COMMON.CHAIN'
4257       include 'COMMON.DERIV'
4258       include 'COMMON.VAR'
4259       include 'COMMON.INTERACT'
4260       include 'COMMON.IOUNITS'
4261       dimension ggg(3)
4262       ehpb=0.0D0
4263 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4264 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4265       if (link_end.eq.0) return
4266       do i=link_start,link_end
4267 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4268 C CA-CA distance used in regularization of structure.
4269         ii=ihpb(i)
4270         jj=jhpb(i)
4271 C iii and jjj point to the residues for which the distance is assigned.
4272         if (ii.gt.nres) then
4273           iii=ii-nres
4274           jjj=jj-nres
4275         else
4276           iii=ii
4277           jjj=jj
4278         endif
4279 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4280 c     &    dhpb(i),dhpb1(i),forcon(i)
4281 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4282 C    distance and angle dependent SS bond potential.
4283 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4284 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4285         if (.not.dyn_ss .and. i.le.nss) then
4286 C 15/02/13 CC dynamic SSbond - additional check
4287          if (ii.gt.nres
4288      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4289           call ssbond_ene(iii,jjj,eij)
4290           ehpb=ehpb+2*eij
4291          endif
4292 cd          write (iout,*) "eij",eij
4293         else if (ii.gt.nres .and. jj.gt.nres) then
4294 c Restraints from contact prediction
4295           dd=dist(ii,jj)
4296           if (dhpb1(i).gt.0.0d0) then
4297             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4298             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4299 c            write (iout,*) "beta nmr",
4300 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4301           else
4302             dd=dist(ii,jj)
4303             rdis=dd-dhpb(i)
4304 C Get the force constant corresponding to this distance.
4305             waga=forcon(i)
4306 C Calculate the contribution to energy.
4307             ehpb=ehpb+waga*rdis*rdis
4308 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4309 C
4310 C Evaluate gradient.
4311 C
4312             fac=waga*rdis/dd
4313           endif
4314           do j=1,3
4315             ggg(j)=fac*(c(j,jj)-c(j,ii))
4316           enddo
4317           do j=1,3
4318             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4319             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4320           enddo
4321           do k=1,3
4322             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4323             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4324           enddo
4325         else
4326 C Calculate the distance between the two points and its difference from the
4327 C target distance.
4328           dd=dist(ii,jj)
4329           if (dhpb1(i).gt.0.0d0) then
4330             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4331             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4332 c            write (iout,*) "alph nmr",
4333 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4334           else
4335             rdis=dd-dhpb(i)
4336 C Get the force constant corresponding to this distance.
4337             waga=forcon(i)
4338 C Calculate the contribution to energy.
4339             ehpb=ehpb+waga*rdis*rdis
4340 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4341 C
4342 C Evaluate gradient.
4343 C
4344             fac=waga*rdis/dd
4345           endif
4346 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4347 cd   &   ' waga=',waga,' fac=',fac
4348             do j=1,3
4349               ggg(j)=fac*(c(j,jj)-c(j,ii))
4350             enddo
4351 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4352 C If this is a SC-SC distance, we need to calculate the contributions to the
4353 C Cartesian gradient in the SC vectors (ghpbx).
4354           if (iii.lt.ii) then
4355           do j=1,3
4356             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4357             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4358           enddo
4359           endif
4360 cgrad        do j=iii,jjj-1
4361 cgrad          do k=1,3
4362 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4363 cgrad          enddo
4364 cgrad        enddo
4365           do k=1,3
4366             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4367             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4368           enddo
4369         endif
4370       enddo
4371       ehpb=0.5D0*ehpb
4372       return
4373       end
4374 C--------------------------------------------------------------------------
4375       subroutine ssbond_ene(i,j,eij)
4376 C
4377 C Calculate the distance and angle dependent SS-bond potential energy
4378 C using a free-energy function derived based on RHF/6-31G** ab initio
4379 C calculations of diethyl disulfide.
4380 C
4381 C A. Liwo and U. Kozlowska, 11/24/03
4382 C
4383       implicit real*8 (a-h,o-z)
4384       include 'DIMENSIONS'
4385       include 'COMMON.SBRIDGE'
4386       include 'COMMON.CHAIN'
4387       include 'COMMON.DERIV'
4388       include 'COMMON.LOCAL'
4389       include 'COMMON.INTERACT'
4390       include 'COMMON.VAR'
4391       include 'COMMON.IOUNITS'
4392       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4393       itypi=itype(i)
4394       xi=c(1,nres+i)
4395       yi=c(2,nres+i)
4396       zi=c(3,nres+i)
4397       dxi=dc_norm(1,nres+i)
4398       dyi=dc_norm(2,nres+i)
4399       dzi=dc_norm(3,nres+i)
4400 c      dsci_inv=dsc_inv(itypi)
4401       dsci_inv=vbld_inv(nres+i)
4402       itypj=itype(j)
4403 c      dscj_inv=dsc_inv(itypj)
4404       dscj_inv=vbld_inv(nres+j)
4405       xj=c(1,nres+j)-xi
4406       yj=c(2,nres+j)-yi
4407       zj=c(3,nres+j)-zi
4408       dxj=dc_norm(1,nres+j)
4409       dyj=dc_norm(2,nres+j)
4410       dzj=dc_norm(3,nres+j)
4411       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4412       rij=dsqrt(rrij)
4413       erij(1)=xj*rij
4414       erij(2)=yj*rij
4415       erij(3)=zj*rij
4416       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4417       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4418       om12=dxi*dxj+dyi*dyj+dzi*dzj
4419       do k=1,3
4420         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4421         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4422       enddo
4423       rij=1.0d0/rij
4424       deltad=rij-d0cm
4425       deltat1=1.0d0-om1
4426       deltat2=1.0d0+om2
4427       deltat12=om2-om1+2.0d0
4428       cosphi=om12-om1*om2
4429       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4430      &  +akct*deltad*deltat12+ebr
4431      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4432 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4433 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4434 c     &  " deltat12",deltat12," eij",eij
4435       ed=2*akcm*deltad+akct*deltat12
4436       pom1=akct*deltad
4437       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4438       eom1=-2*akth*deltat1-pom1-om2*pom2
4439       eom2= 2*akth*deltat2+pom1-om1*pom2
4440       eom12=pom2
4441       do k=1,3
4442         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4443         ghpbx(k,i)=ghpbx(k,i)-ggk
4444      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4445      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4446         ghpbx(k,j)=ghpbx(k,j)+ggk
4447      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4448      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4449         ghpbc(k,i)=ghpbc(k,i)-ggk
4450         ghpbc(k,j)=ghpbc(k,j)+ggk
4451       enddo
4452 C
4453 C Calculate the components of the gradient in DC and X
4454 C
4455 cgrad      do k=i,j-1
4456 cgrad        do l=1,3
4457 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4458 cgrad        enddo
4459 cgrad      enddo
4460       return
4461       end
4462 C--------------------------------------------------------------------------
4463       subroutine ebond(estr)
4464 c
4465 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4466 c
4467       implicit real*8 (a-h,o-z)
4468       include 'DIMENSIONS'
4469       include 'COMMON.LOCAL'
4470       include 'COMMON.GEO'
4471       include 'COMMON.INTERACT'
4472       include 'COMMON.DERIV'
4473       include 'COMMON.VAR'
4474       include 'COMMON.CHAIN'
4475       include 'COMMON.IOUNITS'
4476       include 'COMMON.NAMES'
4477       include 'COMMON.FFIELD'
4478       include 'COMMON.CONTROL'
4479       include 'COMMON.SETUP'
4480       double precision u(3),ud(3)
4481       estr=0.0d0
4482       do i=ibondp_start,ibondp_end
4483         diff = vbld(i)-vbldp0
4484 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4485         estr=estr+diff*diff
4486         do j=1,3
4487           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4488         enddo
4489 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4490       enddo
4491       estr=0.5d0*AKP*estr
4492 c
4493 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4494 c
4495       do i=ibond_start,ibond_end
4496         iti=itype(i)
4497         if (iti.ne.10) then
4498           nbi=nbondterm(iti)
4499           if (nbi.eq.1) then
4500             diff=vbld(i+nres)-vbldsc0(1,iti)
4501 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4502 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4503             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4504             do j=1,3
4505               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4506             enddo
4507           else
4508             do j=1,nbi
4509               diff=vbld(i+nres)-vbldsc0(j,iti)
4510               ud(j)=aksc(j,iti)*diff
4511               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4512             enddo
4513             uprod=u(1)
4514             do j=2,nbi
4515               uprod=uprod*u(j)
4516             enddo
4517             usum=0.0d0
4518             usumsqder=0.0d0
4519             do j=1,nbi
4520               uprod1=1.0d0
4521               uprod2=1.0d0
4522               do k=1,nbi
4523                 if (k.ne.j) then
4524                   uprod1=uprod1*u(k)
4525                   uprod2=uprod2*u(k)*u(k)
4526                 endif
4527               enddo
4528               usum=usum+uprod1
4529               usumsqder=usumsqder+ud(j)*uprod2
4530             enddo
4531             estr=estr+uprod/usum
4532             do j=1,3
4533              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4534             enddo
4535           endif
4536         endif
4537       enddo
4538       return
4539       end
4540 #ifdef CRYST_THETA
4541 C--------------------------------------------------------------------------
4542       subroutine ebend(etheta)
4543 C
4544 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4545 C angles gamma and its derivatives in consecutive thetas and gammas.
4546 C
4547       implicit real*8 (a-h,o-z)
4548       include 'DIMENSIONS'
4549       include 'COMMON.LOCAL'
4550       include 'COMMON.GEO'
4551       include 'COMMON.INTERACT'
4552       include 'COMMON.DERIV'
4553       include 'COMMON.VAR'
4554       include 'COMMON.CHAIN'
4555       include 'COMMON.IOUNITS'
4556       include 'COMMON.NAMES'
4557       include 'COMMON.FFIELD'
4558       include 'COMMON.CONTROL'
4559       common /calcthet/ term1,term2,termm,diffak,ratak,
4560      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4561      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4562       double precision y(2),z(2)
4563       delta=0.02d0*pi
4564 c      time11=dexp(-2*time)
4565 c      time12=1.0d0
4566       etheta=0.0D0
4567 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4568       do i=ithet_start,ithet_end
4569 C Zero the energy function and its derivative at 0 or pi.
4570         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4571         it=itype(i-1)
4572         ichir1=isign(1,itype(i-2))
4573         ichir2=isign(1,itype(i))
4574          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4575          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4576          if (itype(i-1).eq.10) then
4577           itype1=isign(10,itype(i-2))
4578           ichir11=isign(1,itype(i-2))
4579           ichir12=isign(1,itype(i-2))
4580           itype2=isign(10,itype(i))
4581           ichir21=isign(1,itype(i))
4582           ichir22=isign(1,itype(i))
4583          endif
4584         if (i.gt.3) then
4585 #ifdef OSF
4586           phii=phi(i)
4587           if (phii.ne.phii) phii=150.0
4588 #else
4589           phii=phi(i)
4590 #endif
4591           y(1)=dcos(phii)
4592           y(2)=dsin(phii)
4593         else
4594           y(1)=0.0D0
4595           y(2)=0.0D0
4596         endif
4597         if (i.lt.nres) then
4598 #ifdef OSF
4599           phii1=phi(i+1)
4600           if (phii1.ne.phii1) phii1=150.0
4601           phii1=pinorm(phii1)
4602           z(1)=cos(phii1)
4603 #else
4604           phii1=phi(i+1)
4605           z(1)=dcos(phii1)
4606 #endif
4607           z(2)=dsin(phii1)
4608         else
4609           z(1)=0.0D0
4610           z(2)=0.0D0
4611         endif
4612 C Calculate the "mean" value of theta from the part of the distribution
4613 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4614 C In following comments this theta will be referred to as t_c.
4615         thet_pred_mean=0.0d0
4616         do k=1,2
4617             athetk=athet(k,it,ichir1,ichir2)
4618             bthetk=bthet(k,it,ichir1,ichir2)
4619           if (it.eq.10) then
4620              athetk=athet(k,itype1,ichir11,ichir12)
4621              bthetk=bthet(k,itype2,ichir21,ichir22)
4622           endif
4623           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4624         enddo
4625         dthett=thet_pred_mean*ssd
4626         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4627 C Derivatives of the "mean" values in gamma1 and gamma2.
4628         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4629      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4630          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4631      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4632          if (it.eq.10) then
4633       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4634      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4635         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4636      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4637          endif
4638         if (theta(i).gt.pi-delta) then
4639           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4640      &         E_tc0)
4641           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4642           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4643           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4644      &        E_theta)
4645           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4646      &        E_tc)
4647         else if (theta(i).lt.delta) then
4648           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4649           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4650           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4651      &        E_theta)
4652           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4653           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4654      &        E_tc)
4655         else
4656           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4657      &        E_theta,E_tc)
4658         endif
4659         etheta=etheta+ethetai
4660         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4661      &      'ebend',i,ethetai
4662         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4663         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4664         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4665       enddo
4666 C Ufff.... We've done all this!!!
4667       return
4668       end
4669 C---------------------------------------------------------------------------
4670       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4671      &     E_tc)
4672       implicit real*8 (a-h,o-z)
4673       include 'DIMENSIONS'
4674       include 'COMMON.LOCAL'
4675       include 'COMMON.IOUNITS'
4676       common /calcthet/ term1,term2,termm,diffak,ratak,
4677      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4678      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4679 C Calculate the contributions to both Gaussian lobes.
4680 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4681 C The "polynomial part" of the "standard deviation" of this part of
4682 C the distribution.
4683         sig=polthet(3,it)
4684         do j=2,0,-1
4685           sig=sig*thet_pred_mean+polthet(j,it)
4686         enddo
4687 C Derivative of the "interior part" of the "standard deviation of the"
4688 C gamma-dependent Gaussian lobe in t_c.
4689         sigtc=3*polthet(3,it)
4690         do j=2,1,-1
4691           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4692         enddo
4693         sigtc=sig*sigtc
4694 C Set the parameters of both Gaussian lobes of the distribution.
4695 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4696         fac=sig*sig+sigc0(it)
4697         sigcsq=fac+fac
4698         sigc=1.0D0/sigcsq
4699 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4700         sigsqtc=-4.0D0*sigcsq*sigtc
4701 c       print *,i,sig,sigtc,sigsqtc
4702 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4703         sigtc=-sigtc/(fac*fac)
4704 C Following variable is sigma(t_c)**(-2)
4705         sigcsq=sigcsq*sigcsq
4706         sig0i=sig0(it)
4707         sig0inv=1.0D0/sig0i**2
4708         delthec=thetai-thet_pred_mean
4709         delthe0=thetai-theta0i
4710         term1=-0.5D0*sigcsq*delthec*delthec
4711         term2=-0.5D0*sig0inv*delthe0*delthe0
4712 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4713 C NaNs in taking the logarithm. We extract the largest exponent which is added
4714 C to the energy (this being the log of the distribution) at the end of energy
4715 C term evaluation for this virtual-bond angle.
4716         if (term1.gt.term2) then
4717           termm=term1
4718           term2=dexp(term2-termm)
4719           term1=1.0d0
4720         else
4721           termm=term2
4722           term1=dexp(term1-termm)
4723           term2=1.0d0
4724         endif
4725 C The ratio between the gamma-independent and gamma-dependent lobes of
4726 C the distribution is a Gaussian function of thet_pred_mean too.
4727         diffak=gthet(2,it)-thet_pred_mean
4728         ratak=diffak/gthet(3,it)**2
4729         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4730 C Let's differentiate it in thet_pred_mean NOW.
4731         aktc=ak*ratak
4732 C Now put together the distribution terms to make complete distribution.
4733         termexp=term1+ak*term2
4734         termpre=sigc+ak*sig0i
4735 C Contribution of the bending energy from this theta is just the -log of
4736 C the sum of the contributions from the two lobes and the pre-exponential
4737 C factor. Simple enough, isn't it?
4738         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4739 C NOW the derivatives!!!
4740 C 6/6/97 Take into account the deformation.
4741         E_theta=(delthec*sigcsq*term1
4742      &       +ak*delthe0*sig0inv*term2)/termexp
4743         E_tc=((sigtc+aktc*sig0i)/termpre
4744      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4745      &       aktc*term2)/termexp)
4746       return
4747       end
4748 c-----------------------------------------------------------------------------
4749       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4750       implicit real*8 (a-h,o-z)
4751       include 'DIMENSIONS'
4752       include 'COMMON.LOCAL'
4753       include 'COMMON.IOUNITS'
4754       common /calcthet/ term1,term2,termm,diffak,ratak,
4755      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4756      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4757       delthec=thetai-thet_pred_mean
4758       delthe0=thetai-theta0i
4759 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4760       t3 = thetai-thet_pred_mean
4761       t6 = t3**2
4762       t9 = term1
4763       t12 = t3*sigcsq
4764       t14 = t12+t6*sigsqtc
4765       t16 = 1.0d0
4766       t21 = thetai-theta0i
4767       t23 = t21**2
4768       t26 = term2
4769       t27 = t21*t26
4770       t32 = termexp
4771       t40 = t32**2
4772       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4773      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4774      & *(-t12*t9-ak*sig0inv*t27)
4775       return
4776       end
4777 #else
4778 C--------------------------------------------------------------------------
4779       subroutine ebend(etheta)
4780 C
4781 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4782 C angles gamma and its derivatives in consecutive thetas and gammas.
4783 C ab initio-derived potentials from
4784 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4785 C
4786       implicit real*8 (a-h,o-z)
4787       include 'DIMENSIONS'
4788       include 'COMMON.LOCAL'
4789       include 'COMMON.GEO'
4790       include 'COMMON.INTERACT'
4791       include 'COMMON.DERIV'
4792       include 'COMMON.VAR'
4793       include 'COMMON.CHAIN'
4794       include 'COMMON.IOUNITS'
4795       include 'COMMON.NAMES'
4796       include 'COMMON.FFIELD'
4797       include 'COMMON.CONTROL'
4798       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4799      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4800      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4801      & sinph1ph2(maxdouble,maxdouble)
4802       logical lprn /.false./, lprn1 /.false./
4803       etheta=0.0D0
4804       do i=ithet_start,ithet_end
4805         dethetai=0.0d0
4806         dephii=0.0d0
4807         dephii1=0.0d0
4808         theti2=0.5d0*theta(i)
4809         ityp2=ithetyp(itype(i-1))
4810         do k=1,nntheterm
4811           coskt(k)=dcos(k*theti2)
4812           sinkt(k)=dsin(k*theti2)
4813         enddo
4814         if (i.gt.3) then
4815 #ifdef OSF
4816           phii=phi(i)
4817           if (phii.ne.phii) phii=150.0
4818 #else
4819           phii=phi(i)
4820 #endif
4821           ityp1=ithetyp(itype(i-2))
4822           do k=1,nsingle
4823             cosph1(k)=dcos(k*phii)
4824             sinph1(k)=dsin(k*phii)
4825           enddo
4826         else
4827           phii=0.0d0
4828           ityp1=nthetyp+1
4829           do k=1,nsingle
4830             cosph1(k)=0.0d0
4831             sinph1(k)=0.0d0
4832           enddo
4833         endif
4834         if (i.lt.nres) then
4835
4836         if (iabs(itype(i+1)).eq.20) iblock=2
4837         if (iabs(itype(i+1)).ne.20) iblock=1
4838 #ifdef OSF
4839           phii1=phi(i+1)
4840           if (phii1.ne.phii1) phii1=150.0
4841           phii1=pinorm(phii1)
4842 #else
4843           phii1=phi(i+1)
4844 #endif
4845           ityp3=ithetyp(itype(i))
4846           do k=1,nsingle
4847             cosph2(k)=dcos(k*phii1)
4848             sinph2(k)=dsin(k*phii1)
4849           enddo
4850         else
4851           phii1=0.0d0
4852           ityp3=nthetyp+1
4853           do k=1,nsingle
4854             cosph2(k)=0.0d0
4855             sinph2(k)=0.0d0
4856           enddo
4857         endif
4858          ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4859         do k=1,ndouble
4860           do l=1,k-1
4861             ccl=cosph1(l)*cosph2(k-l)
4862             ssl=sinph1(l)*sinph2(k-l)
4863             scl=sinph1(l)*cosph2(k-l)
4864             csl=cosph1(l)*sinph2(k-l)
4865             cosph1ph2(l,k)=ccl-ssl
4866             cosph1ph2(k,l)=ccl+ssl
4867             sinph1ph2(l,k)=scl+csl
4868             sinph1ph2(k,l)=scl-csl
4869           enddo
4870         enddo
4871         if (lprn) then
4872         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4873      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4874         write (iout,*) "coskt and sinkt"
4875         do k=1,nntheterm
4876           write (iout,*) k,coskt(k),sinkt(k)
4877         enddo
4878         endif
4879         do k=1,ntheterm
4880           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4881           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4882      &      *coskt(k)
4883           if (lprn)
4884      &    write (iout,*) "k",k,
4885      &    "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4886      &     " ethetai",ethetai
4887         enddo
4888         if (lprn) then
4889         write (iout,*) "cosph and sinph"
4890         do k=1,nsingle
4891           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4892         enddo
4893         write (iout,*) "cosph1ph2 and sinph2ph2"
4894         do k=2,ndouble
4895           do l=1,k-1
4896             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4897      &         sinph1ph2(l,k),sinph1ph2(k,l)
4898           enddo
4899         enddo
4900         write(iout,*) "ethetai",ethetai
4901         endif
4902         do m=1,ntheterm2
4903           do k=1,nsingle
4904             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4905      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4906      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4907      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4908             ethetai=ethetai+sinkt(m)*aux
4909             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4910             dephii=dephii+k*sinkt(m)*(
4911      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4912      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4913             dephii1=dephii1+k*sinkt(m)*(
4914      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4915      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4916             if (lprn)
4917      &      write (iout,*) "m",m," k",k," bbthet",
4918      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4919      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4920      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4921      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4922           enddo
4923         enddo
4924         if (lprn)
4925      &  write(iout,*) "ethetai",ethetai
4926         do m=1,ntheterm3
4927           do k=2,ndouble
4928             do l=1,k-1
4929        aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4930      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4931      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4932      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4933
4934               ethetai=ethetai+sinkt(m)*aux
4935               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4936               dephii=dephii+l*sinkt(m)*(
4937      & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4938      &  ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4939      &  ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4940      &  ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4941
4942               dephii1=dephii1+(k-l)*sinkt(m)*(
4943      &-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4944      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4945      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4946      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4947
4948               if (lprn) then
4949               write (iout,*) "m",m," k",k," l",l," ffthet",
4950      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4951      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4952      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4953      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4954      &            " ethetai",ethetai
4955
4956               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4957      &            cosph1ph2(k,l)*sinkt(m),
4958      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4959               endif
4960             enddo
4961           enddo
4962         enddo
4963 10      continue
4964 c        lprn1=.true.
4965         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4966      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4967      &   phii1*rad2deg,ethetai
4968 c        lprn1=.false.
4969         etheta=etheta+ethetai
4970         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4971         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4972         gloc(nphi+i-2,icg)=wang*dethetai
4973       enddo
4974       return
4975       end
4976 #endif
4977 #ifdef CRYST_SC
4978 c-----------------------------------------------------------------------------
4979       subroutine esc(escloc)
4980 C Calculate the local energy of a side chain and its derivatives in the
4981 C corresponding virtual-bond valence angles THETA and the spherical angles
4982 C ALPHA and OMEGA.
4983       implicit real*8 (a-h,o-z)
4984       include 'DIMENSIONS'
4985       include 'COMMON.GEO'
4986       include 'COMMON.LOCAL'
4987       include 'COMMON.VAR'
4988       include 'COMMON.INTERACT'
4989       include 'COMMON.DERIV'
4990       include 'COMMON.CHAIN'
4991       include 'COMMON.IOUNITS'
4992       include 'COMMON.NAMES'
4993       include 'COMMON.FFIELD'
4994       include 'COMMON.CONTROL'
4995       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4996      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4997       common /sccalc/ time11,time12,time112,theti,it,nlobit
4998       delta=0.02d0*pi
4999       escloc=0.0D0
5000 c     write (iout,'(a)') 'ESC'
5001       do i=loc_start,loc_end
5002         it=itype(i)
5003         if (it.eq.10) goto 1
5004         nlobit=nlob(it)
5005 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5006 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5007         theti=theta(i+1)-pipol
5008         x(1)=dtan(theti)
5009         x(2)=alph(i)
5010         x(3)=omeg(i)
5011
5012         if (x(2).gt.pi-delta) then
5013           xtemp(1)=x(1)
5014           xtemp(2)=pi-delta
5015           xtemp(3)=x(3)
5016           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5017           xtemp(2)=pi
5018           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5019           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5020      &        escloci,dersc(2))
5021           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5022      &        ddersc0(1),dersc(1))
5023           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5024      &        ddersc0(3),dersc(3))
5025           xtemp(2)=pi-delta
5026           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5027           xtemp(2)=pi
5028           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5029           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5030      &            dersc0(2),esclocbi,dersc02)
5031           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5032      &            dersc12,dersc01)
5033           call splinthet(x(2),0.5d0*delta,ss,ssd)
5034           dersc0(1)=dersc01
5035           dersc0(2)=dersc02
5036           dersc0(3)=0.0d0
5037           do k=1,3
5038             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5039           enddo
5040           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5041 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5042 c    &             esclocbi,ss,ssd
5043           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5044 c         escloci=esclocbi
5045 c         write (iout,*) escloci
5046         else if (x(2).lt.delta) then
5047           xtemp(1)=x(1)
5048           xtemp(2)=delta
5049           xtemp(3)=x(3)
5050           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5051           xtemp(2)=0.0d0
5052           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5053           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5054      &        escloci,dersc(2))
5055           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5056      &        ddersc0(1),dersc(1))
5057           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5058      &        ddersc0(3),dersc(3))
5059           xtemp(2)=delta
5060           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5061           xtemp(2)=0.0d0
5062           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5063           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5064      &            dersc0(2),esclocbi,dersc02)
5065           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5066      &            dersc12,dersc01)
5067           dersc0(1)=dersc01
5068           dersc0(2)=dersc02
5069           dersc0(3)=0.0d0
5070           call splinthet(x(2),0.5d0*delta,ss,ssd)
5071           do k=1,3
5072             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5073           enddo
5074           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5075 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5076 c    &             esclocbi,ss,ssd
5077           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5078 c         write (iout,*) escloci
5079         else
5080           call enesc(x,escloci,dersc,ddummy,.false.)
5081         endif
5082
5083         escloc=escloc+escloci
5084         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5085      &     'escloc',i,escloci
5086 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5087
5088         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5089      &   wscloc*dersc(1)
5090         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5091         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5092     1   continue
5093       enddo
5094       return
5095       end
5096 C---------------------------------------------------------------------------
5097       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5098       implicit real*8 (a-h,o-z)
5099       include 'DIMENSIONS'
5100       include 'COMMON.GEO'
5101       include 'COMMON.LOCAL'
5102       include 'COMMON.IOUNITS'
5103       common /sccalc/ time11,time12,time112,theti,it,nlobit
5104       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5105       double precision contr(maxlob,-1:1)
5106       logical mixed
5107 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5108         escloc_i=0.0D0
5109         do j=1,3
5110           dersc(j)=0.0D0
5111           if (mixed) ddersc(j)=0.0d0
5112         enddo
5113         x3=x(3)
5114
5115 C Because of periodicity of the dependence of the SC energy in omega we have
5116 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5117 C To avoid underflows, first compute & store the exponents.
5118
5119         do iii=-1,1
5120
5121           x(3)=x3+iii*dwapi
5122
5123           do j=1,nlobit
5124             do k=1,3
5125               z(k)=x(k)-censc(k,j,it)
5126             enddo
5127             do k=1,3
5128               Axk=0.0D0
5129               do l=1,3
5130                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5131               enddo
5132               Ax(k,j,iii)=Axk
5133             enddo
5134             expfac=0.0D0
5135             do k=1,3
5136               expfac=expfac+Ax(k,j,iii)*z(k)
5137             enddo
5138             contr(j,iii)=expfac
5139           enddo ! j
5140
5141         enddo ! iii
5142
5143         x(3)=x3
5144 C As in the case of ebend, we want to avoid underflows in exponentiation and
5145 C subsequent NaNs and INFs in energy calculation.
5146 C Find the largest exponent
5147         emin=contr(1,-1)
5148         do iii=-1,1
5149           do j=1,nlobit
5150             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5151           enddo
5152         enddo
5153         emin=0.5D0*emin
5154 cd      print *,'it=',it,' emin=',emin
5155
5156 C Compute the contribution to SC energy and derivatives
5157         do iii=-1,1
5158
5159           do j=1,nlobit
5160 #ifdef OSF
5161             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5162             if(adexp.ne.adexp) adexp=1.0
5163             expfac=dexp(adexp)
5164 #else
5165             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5166 #endif
5167 cd          print *,'j=',j,' expfac=',expfac
5168             escloc_i=escloc_i+expfac
5169             do k=1,3
5170               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5171             enddo
5172             if (mixed) then
5173               do k=1,3,2
5174                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5175      &            +gaussc(k,2,j,it))*expfac
5176               enddo
5177             endif
5178           enddo
5179
5180         enddo ! iii
5181
5182         dersc(1)=dersc(1)/cos(theti)**2
5183         ddersc(1)=ddersc(1)/cos(theti)**2
5184         ddersc(3)=ddersc(3)
5185
5186         escloci=-(dlog(escloc_i)-emin)
5187         do j=1,3
5188           dersc(j)=dersc(j)/escloc_i
5189         enddo
5190         if (mixed) then
5191           do j=1,3,2
5192             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5193           enddo
5194         endif
5195       return
5196       end
5197 C------------------------------------------------------------------------------
5198       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5199       implicit real*8 (a-h,o-z)
5200       include 'DIMENSIONS'
5201       include 'COMMON.GEO'
5202       include 'COMMON.LOCAL'
5203       include 'COMMON.IOUNITS'
5204       common /sccalc/ time11,time12,time112,theti,it,nlobit
5205       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5206       double precision contr(maxlob)
5207       logical mixed
5208
5209       escloc_i=0.0D0
5210
5211       do j=1,3
5212         dersc(j)=0.0D0
5213       enddo
5214
5215       do j=1,nlobit
5216         do k=1,2
5217           z(k)=x(k)-censc(k,j,it)
5218         enddo
5219         z(3)=dwapi
5220         do k=1,3
5221           Axk=0.0D0
5222           do l=1,3
5223             Axk=Axk+gaussc(l,k,j,it)*z(l)
5224           enddo
5225           Ax(k,j)=Axk
5226         enddo
5227         expfac=0.0D0
5228         do k=1,3
5229           expfac=expfac+Ax(k,j)*z(k)
5230         enddo
5231         contr(j)=expfac
5232       enddo ! j
5233
5234 C As in the case of ebend, we want to avoid underflows in exponentiation and
5235 C subsequent NaNs and INFs in energy calculation.
5236 C Find the largest exponent
5237       emin=contr(1)
5238       do j=1,nlobit
5239         if (emin.gt.contr(j)) emin=contr(j)
5240       enddo
5241       emin=0.5D0*emin
5242
5243 C Compute the contribution to SC energy and derivatives
5244
5245       dersc12=0.0d0
5246       do j=1,nlobit
5247         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5248         escloc_i=escloc_i+expfac
5249         do k=1,2
5250           dersc(k)=dersc(k)+Ax(k,j)*expfac
5251         enddo
5252         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5253      &            +gaussc(1,2,j,it))*expfac
5254         dersc(3)=0.0d0
5255       enddo
5256
5257       dersc(1)=dersc(1)/cos(theti)**2
5258       dersc12=dersc12/cos(theti)**2
5259       escloci=-(dlog(escloc_i)-emin)
5260       do j=1,2
5261         dersc(j)=dersc(j)/escloc_i
5262       enddo
5263       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5264       return
5265       end
5266 #else
5267 c----------------------------------------------------------------------------------
5268       subroutine esc(escloc)
5269 C Calculate the local energy of a side chain and its derivatives in the
5270 C corresponding virtual-bond valence angles THETA and the spherical angles
5271 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5272 C added by Urszula Kozlowska. 07/11/2007
5273 C
5274       implicit real*8 (a-h,o-z)
5275       include 'DIMENSIONS'
5276       include 'COMMON.GEO'
5277       include 'COMMON.LOCAL'
5278       include 'COMMON.VAR'
5279       include 'COMMON.SCROT'
5280       include 'COMMON.INTERACT'
5281       include 'COMMON.DERIV'
5282       include 'COMMON.CHAIN'
5283       include 'COMMON.IOUNITS'
5284       include 'COMMON.NAMES'
5285       include 'COMMON.FFIELD'
5286       include 'COMMON.CONTROL'
5287       include 'COMMON.VECTORS'
5288       double precision x_prime(3),y_prime(3),z_prime(3)
5289      &    , sumene,dsc_i,dp2_i,x(65),
5290      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5291      &    de_dxx,de_dyy,de_dzz,de_dt
5292       double precision s1_t,s1_6_t,s2_t,s2_6_t
5293       double precision
5294      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5295      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5296      & dt_dCi(3),dt_dCi1(3)
5297       common /sccalc/ time11,time12,time112,theti,it,nlobit
5298       delta=0.02d0*pi
5299       escloc=0.0D0
5300       do i=loc_start,loc_end
5301         costtab(i+1) =dcos(theta(i+1))
5302         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5303         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5304         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5305         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5306         cosfac=dsqrt(cosfac2)
5307         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5308         sinfac=dsqrt(sinfac2)
5309         it=iabs(itype(i))
5310         if (it.eq.10) goto 1
5311 c
5312 C  Compute the axes of tghe local cartesian coordinates system; store in
5313 c   x_prime, y_prime and z_prime
5314 c
5315         do j=1,3
5316           x_prime(j) = 0.00
5317           y_prime(j) = 0.00
5318           z_prime(j) = 0.00
5319         enddo
5320 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5321 C     &   dc_norm(3,i+nres)
5322         do j = 1,3
5323           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5324           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5325         enddo
5326         do j = 1,3
5327           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5328         enddo
5329 c       write (2,*) "i",i
5330 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5331 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5332 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5333 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5334 c      & " xy",scalar(x_prime(1),y_prime(1)),
5335 c      & " xz",scalar(x_prime(1),z_prime(1)),
5336 c      & " yy",scalar(y_prime(1),y_prime(1)),
5337 c      & " yz",scalar(y_prime(1),z_prime(1)),
5338 c      & " zz",scalar(z_prime(1),z_prime(1))
5339 c
5340 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5341 C to local coordinate system. Store in xx, yy, zz.
5342 c
5343         xx=0.0d0
5344         yy=0.0d0
5345         zz=0.0d0
5346         do j = 1,3
5347           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5348           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5349           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5350         enddo
5351
5352         xxtab(i)=xx
5353         yytab(i)=yy
5354         zztab(i)=zz
5355 C
5356 C Compute the energy of the ith side cbain
5357 C
5358 c        write (2,*) "xx",xx," yy",yy," zz",zz
5359         it=iabs(itype(i))
5360         do j = 1,65
5361           x(j) = sc_parmin(j,it)
5362         enddo
5363 #ifdef CHECK_COORD
5364 Cc diagnostics - remove later
5365         xx1 = dcos(alph(2))
5366         yy1 = dsin(alph(2))*dcos(omeg(2))
5367         zz1 = -dsign(1.0, dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5368         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5369      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5370      &    xx1,yy1,zz1
5371 C,"  --- ", xx_w,yy_w,zz_w
5372 c end diagnostics
5373 #endif
5374         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5375      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5376      &   + x(10)*yy*zz
5377         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5378      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5379      & + x(20)*yy*zz
5380         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5381      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5382      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5383      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5384      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5385      &  +x(40)*xx*yy*zz
5386         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5387      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5388      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5389      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5390      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5391      &  +x(60)*xx*yy*zz
5392         dsc_i   = 0.743d0+x(61)
5393         dp2_i   = 1.9d0+x(62)
5394         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5395      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5396         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5397      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5398         s1=(1+x(63))/(0.1d0 + dscp1)
5399         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5400         s2=(1+x(65))/(0.1d0 + dscp2)
5401         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5402         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5403      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5404 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5405 c     &   sumene4,
5406 c     &   dscp1,dscp2,sumene
5407 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5408         escloc = escloc + sumene
5409 c        write (2,*) "i",i," escloc",sumene,escloc
5410 #ifdef DEBUG
5411 C
5412 C This section to check the numerical derivatives of the energy of ith side
5413 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5414 C #define DEBUG in the code to turn it on.
5415 C
5416         write (2,*) "sumene               =",sumene
5417         aincr=1.0d-7
5418         xxsave=xx
5419         xx=xx+aincr
5420         write (2,*) xx,yy,zz
5421         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5422         de_dxx_num=(sumenep-sumene)/aincr
5423         xx=xxsave
5424         write (2,*) "xx+ sumene from enesc=",sumenep
5425         yysave=yy
5426         yy=yy+aincr
5427         write (2,*) xx,yy,zz
5428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5429         de_dyy_num=(sumenep-sumene)/aincr
5430         yy=yysave
5431         write (2,*) "yy+ sumene from enesc=",sumenep
5432         zzsave=zz
5433         zz=zz+aincr
5434         write (2,*) xx,yy,zz
5435         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5436         de_dzz_num=(sumenep-sumene)/aincr
5437         zz=zzsave
5438         write (2,*) "zz+ sumene from enesc=",sumenep
5439         costsave=cost2tab(i+1)
5440         sintsave=sint2tab(i+1)
5441         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5442         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5443         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5444         de_dt_num=(sumenep-sumene)/aincr
5445         write (2,*) " t+ sumene from enesc=",sumenep
5446         cost2tab(i+1)=costsave
5447         sint2tab(i+1)=sintsave
5448 C End of diagnostics section.
5449 #endif
5450 C
5451 C Compute the gradient of esc
5452 C
5453         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5454         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5455         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5456         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5457         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5458         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5459         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5460         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5461         pom1=(sumene3*sint2tab(i+1)+sumene1)
5462      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5463         pom2=(sumene4*cost2tab(i+1)+sumene2)
5464      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5465         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5466         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5467      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5468      &  +x(40)*yy*zz
5469         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5470         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5471      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5472      &  +x(60)*yy*zz
5473         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5474      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5475      &        +(pom1+pom2)*pom_dx
5476 #ifdef DEBUG
5477         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5478 #endif
5479 C
5480         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5481         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5482      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5483      &  +x(40)*xx*zz
5484         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5485         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5486      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5487      &  +x(59)*zz**2 +x(60)*xx*zz
5488         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5489      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5490      &        +(pom1-pom2)*pom_dy
5491 #ifdef DEBUG
5492         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5493 #endif
5494 C
5495         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5496      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5497      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5498      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5499      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5500      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5501      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5502      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5503 #ifdef DEBUG
5504         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5505 #endif
5506 C
5507         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5508      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5509      &  +pom1*pom_dt1+pom2*pom_dt2
5510 #ifdef DEBUG
5511         write(2,*), "de_dt = ", de_dt,de_dt_num
5512 #endif
5513 c
5514 C
5515        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5516        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5517        cosfac2xx=cosfac2*xx
5518        sinfac2yy=sinfac2*yy
5519        do k = 1,3
5520          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5521      &      vbld_inv(i+1)
5522          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5523      &      vbld_inv(i)
5524          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5525          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5526 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5527 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5528 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5529 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5530          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5531          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5532          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5533          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5534          dZZ_Ci1(k)=0.0d0
5535          dZZ_Ci(k)=0.0d0
5536          do j=1,3
5537            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5538      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5539            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5540      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5541          enddo
5542
5543          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5544          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5545          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5546 c
5547          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5548          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5549        enddo
5550
5551        do k=1,3
5552          dXX_Ctab(k,i)=dXX_Ci(k)
5553          dXX_C1tab(k,i)=dXX_Ci1(k)
5554          dYY_Ctab(k,i)=dYY_Ci(k)
5555          dYY_C1tab(k,i)=dYY_Ci1(k)
5556          dZZ_Ctab(k,i)=dZZ_Ci(k)
5557          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5558          dXX_XYZtab(k,i)=dXX_XYZ(k)
5559          dYY_XYZtab(k,i)=dYY_XYZ(k)
5560          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5561        enddo
5562
5563        do k = 1,3
5564 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5565 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5566 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5567 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5568 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5569 c     &    dt_dci(k)
5570 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5571 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5572          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5573      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5574          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5575      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5576          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5577      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5578        enddo
5579 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5580 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5581
5582 C to check gradient call subroutine check_grad
5583
5584     1 continue
5585       enddo
5586       return
5587       end
5588 c------------------------------------------------------------------------------
5589       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5590       implicit none
5591       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5592      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5593       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5594      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5595      &   + x(10)*yy*zz
5596       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5597      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5598      & + x(20)*yy*zz
5599       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5600      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5601      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5602      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5603      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5604      &  +x(40)*xx*yy*zz
5605       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5606      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5607      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5608      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5609      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5610      &  +x(60)*xx*yy*zz
5611       dsc_i   = 0.743d0+x(61)
5612       dp2_i   = 1.9d0+x(62)
5613       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5614      &          *(xx*cost2+yy*sint2))
5615       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5616      &          *(xx*cost2-yy*sint2))
5617       s1=(1+x(63))/(0.1d0 + dscp1)
5618       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5619       s2=(1+x(65))/(0.1d0 + dscp2)
5620       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5621       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5622      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5623       enesc=sumene
5624       return
5625       end
5626 #endif
5627 c------------------------------------------------------------------------------
5628       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5629 C
5630 C This procedure calculates two-body contact function g(rij) and its derivative:
5631 C
5632 C           eps0ij                                     !       x < -1
5633 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5634 C            0                                         !       x > 1
5635 C
5636 C where x=(rij-r0ij)/delta
5637 C
5638 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5639 C
5640       implicit none
5641       double precision rij,r0ij,eps0ij,fcont,fprimcont
5642       double precision x,x2,x4,delta
5643 c     delta=0.02D0*r0ij
5644 c      delta=0.2D0*r0ij
5645       x=(rij-r0ij)/delta
5646       if (x.lt.-1.0D0) then
5647         fcont=eps0ij
5648         fprimcont=0.0D0
5649       else if (x.le.1.0D0) then
5650         x2=x*x
5651         x4=x2*x2
5652         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5653         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5654       else
5655         fcont=0.0D0
5656         fprimcont=0.0D0
5657       endif
5658       return
5659       end
5660 c------------------------------------------------------------------------------
5661       subroutine splinthet(theti,delta,ss,ssder)
5662       implicit real*8 (a-h,o-z)
5663       include 'DIMENSIONS'
5664       include 'COMMON.VAR'
5665       include 'COMMON.GEO'
5666       thetup=pi-delta
5667       thetlow=delta
5668       if (theti.gt.pipol) then
5669         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5670       else
5671         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5672         ssder=-ssder
5673       endif
5674       return
5675       end
5676 c------------------------------------------------------------------------------
5677       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5678       implicit none
5679       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5680       double precision ksi,ksi2,ksi3,a1,a2,a3
5681       a1=fprim0*delta/(f1-f0)
5682       a2=3.0d0-2.0d0*a1
5683       a3=a1-2.0d0
5684       ksi=(x-x0)/delta
5685       ksi2=ksi*ksi
5686       ksi3=ksi2*ksi
5687       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5688       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5689       return
5690       end
5691 c------------------------------------------------------------------------------
5692       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5693       implicit none
5694       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5695       double precision ksi,ksi2,ksi3,a1,a2,a3
5696       ksi=(x-x0)/delta
5697       ksi2=ksi*ksi
5698       ksi3=ksi2*ksi
5699       a1=fprim0x*delta
5700       a2=3*(f1x-f0x)-2*fprim0x*delta
5701       a3=fprim0x*delta-2*(f1x-f0x)
5702       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5703       return
5704       end
5705 C-----------------------------------------------------------------------------
5706 #ifdef CRYST_TOR
5707 C-----------------------------------------------------------------------------
5708       subroutine etor(etors,edihcnstr)
5709       implicit real*8 (a-h,o-z)
5710       include 'DIMENSIONS'
5711       include 'COMMON.VAR'
5712       include 'COMMON.GEO'
5713       include 'COMMON.LOCAL'
5714       include 'COMMON.TORSION'
5715       include 'COMMON.INTERACT'
5716       include 'COMMON.DERIV'
5717       include 'COMMON.CHAIN'
5718       include 'COMMON.NAMES'
5719       include 'COMMON.IOUNITS'
5720       include 'COMMON.FFIELD'
5721       include 'COMMON.TORCNSTR'
5722       include 'COMMON.CONTROL'
5723       logical lprn
5724 C Set lprn=.true. for debugging
5725       lprn=.false.
5726 c      lprn=.true.
5727       etors=0.0D0
5728       do i=iphi_start,iphi_end
5729       etors_ii=0.0D0
5730         itori=itortyp(itype(i-2))
5731         itori1=itortyp(itype(i-1))
5732         phii=phi(i)
5733         gloci=0.0D0
5734 C Proline-Proline pair is a special case...
5735         if (itori.eq.3 .and. itori1.eq.3) then
5736           if (phii.gt.-dwapi3) then
5737             cosphi=dcos(3*phii)
5738             fac=1.0D0/(1.0D0-cosphi)
5739             etorsi=v1(1,3,3)*fac
5740             etorsi=etorsi+etorsi
5741             etors=etors+etorsi-v1(1,3,3)
5742             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5743             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5744           endif
5745           do j=1,3
5746             v1ij=v1(j+1,itori,itori1)
5747             v2ij=v2(j+1,itori,itori1)
5748             cosphi=dcos(j*phii)
5749             sinphi=dsin(j*phii)
5750             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5751             if (energy_dec) etors_ii=etors_ii+
5752      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5753             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5754           enddo
5755         else
5756           do j=1,nterm_old
5757             v1ij=v1(j,itori,itori1)
5758             v2ij=v2(j,itori,itori1)
5759             cosphi=dcos(j*phii)
5760             sinphi=dsin(j*phii)
5761             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5762             if (energy_dec) etors_ii=etors_ii+
5763      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5764             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5765           enddo
5766         endif
5767         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5768      &        'etor',i,etors_ii
5769         if (lprn)
5770      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5771      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5772      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5773         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5774         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5775       enddo
5776 ! 6/20/98 - dihedral angle constraints
5777       edihcnstr=0.0d0
5778       do i=1,ndih_constr
5779         itori=idih_constr(i)
5780         phii=phi(itori)
5781         difi=phii-phi0(i)
5782         if (difi.gt.drange(i)) then
5783           difi=difi-drange(i)
5784           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5785           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5786         else if (difi.lt.-drange(i)) then
5787           difi=difi+drange(i)
5788           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5789           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5790         endif
5791 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5792 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5793       enddo
5794 !      write (iout,*) 'edihcnstr',edihcnstr
5795       return
5796       end
5797 c------------------------------------------------------------------------------
5798       subroutine etor_d(etors_d)
5799       etors_d=0.0d0
5800       return
5801       end
5802 c----------------------------------------------------------------------------
5803 #else
5804       subroutine etor(etors,edihcnstr)
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.VAR'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.TORSION'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.CHAIN'
5814       include 'COMMON.NAMES'
5815       include 'COMMON.IOUNITS'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.TORCNSTR'
5818       include 'COMMON.CONTROL'
5819       logical lprn
5820 C Set lprn=.true. for debugging
5821       lprn=.false.
5822 c     lprn=.true.
5823       etors=0.0D0
5824       do i=iphi_start,iphi_end
5825       etors_ii=0.0D0
5826 c        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5827 c     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5828         itori=itortyp(itype(i-2))
5829         itori1=itortyp(itype(i-1))
5830         phii=phi(i)
5831         gloci=0.0D0
5832 C Regular cosine and sine terms
5833         do j=1,nterm(itori,itori1)
5834           v1ij=v1(j,itori,itori1)
5835           v2ij=v2(j,itori,itori1)
5836           cosphi=dcos(j*phii)
5837           sinphi=dsin(j*phii)
5838           etors=etors+v1ij*cosphi+v2ij*sinphi
5839           if (energy_dec) etors_ii=etors_ii+
5840      &                v1ij*cosphi+v2ij*sinphi
5841           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5842         enddo
5843 C Lorentz terms
5844 C                         v1
5845 C  E = SUM ----------------------------------- - v1
5846 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5847 C
5848         cosphi=dcos(0.5d0*phii)
5849         sinphi=dsin(0.5d0*phii)
5850         do j=1,nlor(itori,itori1)
5851           vl1ij=vlor1(j,itori,itori1)
5852           vl2ij=vlor2(j,itori,itori1)
5853           vl3ij=vlor3(j,itori,itori1)
5854           pom=vl2ij*cosphi+vl3ij*sinphi
5855           pom1=1.0d0/(pom*pom+1.0d0)
5856           etors=etors+vl1ij*pom1
5857           if (energy_dec) etors_ii=etors_ii+
5858      &                vl1ij*pom1
5859           pom=-pom*pom1*pom1
5860           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5861         enddo
5862 C Subtract the constant term
5863         etors=etors-v0(itori,itori1)
5864           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5865      &         'etor',i,etors_ii-v0(itori,itori1)
5866         if (lprn)
5867      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5868      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5869      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5870         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5871 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5872       enddo
5873 ! 6/20/98 - dihedral angle constraints
5874       edihcnstr=0.0d0
5875 c      do i=1,ndih_constr
5876       do i=idihconstr_start,idihconstr_end
5877         itori=idih_constr(i)
5878         phii=phi(itori)
5879         difi=pinorm(phii-phi0(i))
5880         if (difi.gt.drange(i)) then
5881           difi=difi-drange(i)
5882           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5883           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5884         else if (difi.lt.-drange(i)) then
5885           difi=difi+drange(i)
5886           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5887           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5888         else
5889           difi=0.0
5890         endif
5891 c        write (iout,*) "gloci", gloc(i-3,icg)
5892 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5893 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5894 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5895       enddo
5896 cd       write (iout,*) 'edihcnstr',edihcnstr
5897       return
5898       end
5899 c----------------------------------------------------------------------------
5900       subroutine etor_d(etors_d)
5901 C 6/23/01 Compute double torsional energy
5902       implicit real*8 (a-h,o-z)
5903       include 'DIMENSIONS'
5904       include 'COMMON.VAR'
5905       include 'COMMON.GEO'
5906       include 'COMMON.LOCAL'
5907       include 'COMMON.TORSION'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.DERIV'
5910       include 'COMMON.CHAIN'
5911       include 'COMMON.NAMES'
5912       include 'COMMON.IOUNITS'
5913       include 'COMMON.FFIELD'
5914       include 'COMMON.TORCNSTR'
5915       logical lprn
5916 C Set lprn=.true. for debugging
5917       lprn=.false.
5918 c     lprn=.true.
5919       etors_d=0.0D0
5920       do i=iphid_start,iphid_end
5921 c        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5922 c     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5923         itori=itortyp(itype(i-2))
5924         itori1=itortyp(itype(i-1))
5925         itori2=itortyp(itype(i))
5926         phii=phi(i)
5927         phii1=phi(i+1)
5928         gloci1=0.0D0
5929         gloci2=0.0D0
5930         do j=1,ntermd_1(itori,itori1,itori2)
5931           v1cij=v1c(1,j,itori,itori1,itori2)
5932           v1sij=v1s(1,j,itori,itori1,itori2)
5933           v2cij=v1c(2,j,itori,itori1,itori2)
5934           v2sij=v1s(2,j,itori,itori1,itori2)
5935           cosphi1=dcos(j*phii)
5936           sinphi1=dsin(j*phii)
5937           cosphi2=dcos(j*phii1)
5938           sinphi2=dsin(j*phii1)
5939           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5940      &     v2cij*cosphi2+v2sij*sinphi2
5941           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5942           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5943         enddo
5944         do k=2,ntermd_2(itori,itori1,itori2)
5945           do l=1,k-1
5946             v1cdij = v2c(k,l,itori,itori1,itori2)
5947             v2cdij = v2c(l,k,itori,itori1,itori2)
5948             v1sdij = v2s(k,l,itori,itori1,itori2)
5949             v2sdij = v2s(l,k,itori,itori1,itori2)
5950             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5951             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5952             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5953             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5954             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5955      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5956             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5957      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5958             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5959      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5960           enddo
5961         enddo
5962         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5963         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5964 c        write (iout,*) "gloci", gloc(i-3,icg)
5965       enddo
5966       return
5967       end
5968 #endif
5969 c------------------------------------------------------------------------------
5970       subroutine eback_sc_corr(esccor)
5971 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5972 c        conformational states; temporarily implemented as differences
5973 c        between UNRES torsional potentials (dependent on three types of
5974 c        residues) and the torsional potentials dependent on all 20 types
5975 c        of residues computed from AM1  energy surfaces of terminally-blocked
5976 c        amino-acid residues.
5977       implicit real*8 (a-h,o-z)
5978       include 'DIMENSIONS'
5979       include 'COMMON.VAR'
5980       include 'COMMON.GEO'
5981       include 'COMMON.LOCAL'
5982       include 'COMMON.TORSION'
5983       include 'COMMON.SCCOR'
5984       include 'COMMON.INTERACT'
5985       include 'COMMON.DERIV'
5986       include 'COMMON.CHAIN'
5987       include 'COMMON.NAMES'
5988       include 'COMMON.IOUNITS'
5989       include 'COMMON.FFIELD'
5990       include 'COMMON.CONTROL'
5991       logical lprn
5992 C Set lprn=.true. for debugging
5993       lprn=.false.
5994 c      lprn=.true.
5995 c     write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5996       esccor=0.0D0
5997       do i=itau_start,itau_end
5998         esccor_ii=0.0D0
5999         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6000         isccori=isccortyp(itype(i-2))
6001         isccori1=isccortyp(itype(i-1))
6002         phii=phi(i)
6003 cccc  Added 9 May 2012
6004 cc Tauangle is torsional engle depending on the value of first digit
6005 c(see comment below)
6006 cc Omicron is flat angle depending on the value of first digit
6007 c(see comment below)
6008
6009
6010         do intertyp=1,3 !intertyp
6011 cc Added 09 May 2012 (Adasko)
6012 cc  Intertyp means interaction type of backbone mainchain correlation:
6013 c   1 = SC...Ca...Ca...Ca
6014 c   2 = Ca...Ca...Ca...SC
6015 c   3 = SC...Ca...Ca...SCi
6016         gloci=0.0D0
6017         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6018      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6019      &      (itype(i-1).eq.ntyp1)))
6020      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6021      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6022      &     .or.(itype(i).eq.ntyp1)))
6023      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6024      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6025      &      (itype(i-3).eq.ntyp1)))) cycle
6026         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6027         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6028      & cycle
6029         do j=1,nterm_sccor(isccori,isccori1)
6030           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6031           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6032           cosphi=dcos(j*tauangle(intertyp,i))
6033           sinphi=dsin(j*tauangle(intertyp,i))
6034           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6035           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6036         enddo
6037         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6038 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6039 c     &gloc_sc(intertyp,i-3,icg)
6040         if (lprn)
6041      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6042      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6043      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6044      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6045         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6046        enddo !intertyp
6047       enddo
6048 c        do i=1,nres
6049 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6050 c        enddo
6051       return
6052       end
6053 c----------------------------------------------------------------------------
6054       subroutine multibody(ecorr)
6055 C This subroutine calculates multi-body contributions to energy following
6056 C the idea of Skolnick et al. If side chains I and J make a contact and
6057 C at the same time side chains I+1 and J+1 make a contact, an extra
6058 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6059       implicit real*8 (a-h,o-z)
6060       include 'DIMENSIONS'
6061       include 'COMMON.IOUNITS'
6062       include 'COMMON.DERIV'
6063       include 'COMMON.INTERACT'
6064       include 'COMMON.CONTACTS'
6065       double precision gx(3),gx1(3)
6066       logical lprn
6067
6068 C Set lprn=.true. for debugging
6069       lprn=.false.
6070
6071       if (lprn) then
6072         write (iout,'(a)') 'Contact function values:'
6073         do i=nnt,nct-2
6074           write (iout,'(i2,20(1x,i2,f10.5))')
6075      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6076         enddo
6077       endif
6078       ecorr=0.0D0
6079       do i=nnt,nct
6080         do j=1,3
6081           gradcorr(j,i)=0.0D0
6082           gradxorr(j,i)=0.0D0
6083         enddo
6084       enddo
6085       do i=nnt,nct-2
6086
6087         DO ISHIFT = 3,4
6088
6089         i1=i+ishift
6090         num_conti=num_cont(i)
6091         num_conti1=num_cont(i1)
6092         do jj=1,num_conti
6093           j=jcont(jj,i)
6094           do kk=1,num_conti1
6095             j1=jcont(kk,i1)
6096             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6097 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6098 cd   &                   ' ishift=',ishift
6099 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6100 C The system gains extra energy.
6101               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6102             endif   ! j1==j+-ishift
6103           enddo     ! kk
6104         enddo       ! jj
6105
6106         ENDDO ! ISHIFT
6107
6108       enddo         ! i
6109       return
6110       end
6111 c------------------------------------------------------------------------------
6112       double precision function esccorr(i,j,k,l,jj,kk)
6113       implicit real*8 (a-h,o-z)
6114       include 'DIMENSIONS'
6115       include 'COMMON.IOUNITS'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       double precision gx(3),gx1(3)
6120       logical lprn
6121       lprn=.false.
6122       eij=facont(jj,i)
6123       ekl=facont(kk,k)
6124 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6125 C Calculate the multi-body contribution to energy.
6126 C Calculate multi-body contributions to the gradient.
6127 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6128 cd   & k,l,(gacont(m,kk,k),m=1,3)
6129       do m=1,3
6130         gx(m) =ekl*gacont(m,jj,i)
6131         gx1(m)=eij*gacont(m,kk,k)
6132         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6133         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6134         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6135         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6136       enddo
6137       do m=i,j-1
6138         do ll=1,3
6139           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6140         enddo
6141       enddo
6142       do m=k,l-1
6143         do ll=1,3
6144           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6145         enddo
6146       enddo
6147       esccorr=-eij*ekl
6148       return
6149       end
6150 c------------------------------------------------------------------------------
6151       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6152 C This subroutine calculates multi-body contributions to hydrogen-bonding
6153       implicit real*8 (a-h,o-z)
6154       include 'DIMENSIONS'
6155       include 'COMMON.IOUNITS'
6156 #ifdef MPI
6157       include "mpif.h"
6158       parameter (max_cont=maxconts)
6159       parameter (max_dim=26)
6160       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6161       double precision zapas(max_dim,maxconts,max_fg_procs),
6162      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6163       common /przechowalnia/ zapas
6164       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6165      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6166 #endif
6167       include 'COMMON.SETUP'
6168       include 'COMMON.FFIELD'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.INTERACT'
6171       include 'COMMON.CONTACTS'
6172       include 'COMMON.CONTROL'
6173       include 'COMMON.LOCAL'
6174       double precision gx(3),gx1(3),time00
6175       logical lprn,ldone
6176
6177 C Set lprn=.true. for debugging
6178       lprn=.false.
6179 #ifdef MPI
6180       n_corr=0
6181       n_corr1=0
6182       if (nfgtasks.le.1) goto 30
6183       if (lprn) then
6184         write (iout,'(a)') 'Contact function values before RECEIVE:'
6185         do i=nnt,nct-2
6186           write (iout,'(2i3,50(1x,i2,f5.2))')
6187      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6188      &    j=1,num_cont_hb(i))
6189         enddo
6190       endif
6191       call flush(iout)
6192       do i=1,ntask_cont_from
6193         ncont_recv(i)=0
6194       enddo
6195       do i=1,ntask_cont_to
6196         ncont_sent(i)=0
6197       enddo
6198 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6199 c     & ntask_cont_to
6200 C Make the list of contacts to send to send to other procesors
6201 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6202 c      call flush(iout)
6203       do i=iturn3_start,iturn3_end
6204 c        write (iout,*) "make contact list turn3",i," num_cont",
6205 c     &    num_cont_hb(i)
6206         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6207       enddo
6208       do i=iturn4_start,iturn4_end
6209 c        write (iout,*) "make contact list turn4",i," num_cont",
6210 c     &   num_cont_hb(i)
6211         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6212       enddo
6213       do ii=1,nat_sent
6214         i=iat_sent(ii)
6215 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6216 c     &    num_cont_hb(i)
6217         do j=1,num_cont_hb(i)
6218         do k=1,4
6219           jjc=jcont_hb(j,i)
6220           iproc=iint_sent_local(k,jjc,ii)
6221 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6222           if (iproc.gt.0) then
6223             ncont_sent(iproc)=ncont_sent(iproc)+1
6224             nn=ncont_sent(iproc)
6225             zapas(1,nn,iproc)=i
6226             zapas(2,nn,iproc)=jjc
6227             zapas(3,nn,iproc)=facont_hb(j,i)
6228             zapas(4,nn,iproc)=ees0p(j,i)
6229             zapas(5,nn,iproc)=ees0m(j,i)
6230             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6231             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6232             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6233             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6234             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6235             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6236             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6237             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6238             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6239             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6240             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6241             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6242             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6243             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6244             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6245             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6246             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6247             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6248             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6249             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6250             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6251           endif
6252         enddo
6253         enddo
6254       enddo
6255       if (lprn) then
6256       write (iout,*)
6257      &  "Numbers of contacts to be sent to other processors",
6258      &  (ncont_sent(i),i=1,ntask_cont_to)
6259       write (iout,*) "Contacts sent"
6260       do ii=1,ntask_cont_to
6261         nn=ncont_sent(ii)
6262         iproc=itask_cont_to(ii)
6263         write (iout,*) nn," contacts to processor",iproc,
6264      &   " of CONT_TO_COMM group"
6265         do i=1,nn
6266           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6267         enddo
6268       enddo
6269       call flush(iout)
6270       endif
6271       CorrelType=477
6272       CorrelID=fg_rank+1
6273       CorrelType1=478
6274       CorrelID1=nfgtasks+fg_rank+1
6275       ireq=0
6276 C Receive the numbers of needed contacts from other processors
6277       do ii=1,ntask_cont_from
6278         iproc=itask_cont_from(ii)
6279         ireq=ireq+1
6280         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6281      &    FG_COMM,req(ireq),IERR)
6282       enddo
6283 c      write (iout,*) "IRECV ended"
6284 c      call flush(iout)
6285 C Send the number of contacts needed by other processors
6286       do ii=1,ntask_cont_to
6287         iproc=itask_cont_to(ii)
6288         ireq=ireq+1
6289         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6290      &    FG_COMM,req(ireq),IERR)
6291       enddo
6292 c      write (iout,*) "ISEND ended"
6293 c      write (iout,*) "number of requests (nn)",ireq
6294       call flush(iout)
6295       if (ireq.gt.0)
6296      &  call MPI_Waitall(ireq,req,status_array,ierr)
6297 c      write (iout,*)
6298 c     &  "Numbers of contacts to be received from other processors",
6299 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6300 c      call flush(iout)
6301 C Receive contacts
6302       ireq=0
6303       do ii=1,ntask_cont_from
6304         iproc=itask_cont_from(ii)
6305         nn=ncont_recv(ii)
6306 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6307 c     &   " of CONT_TO_COMM group"
6308         call flush(iout)
6309         if (nn.gt.0) then
6310           ireq=ireq+1
6311           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6312      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6313 c          write (iout,*) "ireq,req",ireq,req(ireq)
6314         endif
6315       enddo
6316 C Send the contacts to processors that need them
6317       do ii=1,ntask_cont_to
6318         iproc=itask_cont_to(ii)
6319         nn=ncont_sent(ii)
6320 c        write (iout,*) nn," contacts to processor",iproc,
6321 c     &   " of CONT_TO_COMM group"
6322         if (nn.gt.0) then
6323           ireq=ireq+1
6324           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6325      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6326 c          write (iout,*) "ireq,req",ireq,req(ireq)
6327 c          do i=1,nn
6328 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6329 c          enddo
6330         endif
6331       enddo
6332 c      write (iout,*) "number of requests (contacts)",ireq
6333 c      write (iout,*) "req",(req(i),i=1,4)
6334 c      call flush(iout)
6335       if (ireq.gt.0)
6336      & call MPI_Waitall(ireq,req,status_array,ierr)
6337       do iii=1,ntask_cont_from
6338         iproc=itask_cont_from(iii)
6339         nn=ncont_recv(iii)
6340         if (lprn) then
6341         write (iout,*) "Received",nn," contacts from processor",iproc,
6342      &   " of CONT_FROM_COMM group"
6343         call flush(iout)
6344         do i=1,nn
6345           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6346         enddo
6347         call flush(iout)
6348         endif
6349         do i=1,nn
6350           ii=zapas_recv(1,i,iii)
6351 c Flag the received contacts to prevent double-counting
6352           jj=-zapas_recv(2,i,iii)
6353 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6354 c          call flush(iout)
6355           nnn=num_cont_hb(ii)+1
6356           num_cont_hb(ii)=nnn
6357           jcont_hb(nnn,ii)=jj
6358           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6359           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6360           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6361           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6362           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6363           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6364           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6365           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6366           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6367           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6368           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6369           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6370           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6371           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6372           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6373           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6374           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6375           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6376           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6377           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6378           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6379           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6380           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6381           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6382         enddo
6383       enddo
6384       call flush(iout)
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values after receive:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i3,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392         call flush(iout)
6393       endif
6394    30 continue
6395 #endif
6396       if (lprn) then
6397         write (iout,'(a)') 'Contact function values:'
6398         do i=nnt,nct-2
6399           write (iout,'(2i3,50(1x,i3,f5.2))')
6400      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6401      &    j=1,num_cont_hb(i))
6402         enddo
6403       endif
6404       ecorr=0.0D0
6405 C Remove the loop below after debugging !!!
6406       do i=nnt,nct
6407         do j=1,3
6408           gradcorr(j,i)=0.0D0
6409           gradxorr(j,i)=0.0D0
6410         enddo
6411       enddo
6412 C Calculate the local-electrostatic correlation terms
6413       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6414         i1=i+1
6415         num_conti=num_cont_hb(i)
6416         num_conti1=num_cont_hb(i+1)
6417         do jj=1,num_conti
6418           j=jcont_hb(jj,i)
6419           jp=iabs(j)
6420           do kk=1,num_conti1
6421             j1=jcont_hb(kk,i1)
6422             jp1=iabs(j1)
6423 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6424 c     &         ' jj=',jj,' kk=',kk
6425             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6426      &          .or. j.lt.0 .and. j1.gt.0) .and.
6427      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6428 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6429 C The system gains extra energy.
6430               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6431               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6432      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6433               n_corr=n_corr+1
6434             else if (j1.eq.j) then
6435 C Contacts I-J and I-(J+1) occur simultaneously.
6436 C The system loses extra energy.
6437 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6438             endif
6439           enddo ! kk
6440           do kk=1,num_conti
6441             j1=jcont_hb(kk,i)
6442 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6443 c    &         ' jj=',jj,' kk=',kk
6444             if (j1.eq.j+1) then
6445 C Contacts I-J and (I+1)-J occur simultaneously.
6446 C The system loses extra energy.
6447 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6448             endif ! j1==j+1
6449           enddo ! kk
6450         enddo ! jj
6451       enddo ! i
6452       return
6453       end
6454 c------------------------------------------------------------------------------
6455       subroutine add_hb_contact(ii,jj,itask)
6456       implicit real*8 (a-h,o-z)
6457       include "DIMENSIONS"
6458       include "COMMON.IOUNITS"
6459       integer max_cont
6460       integer max_dim
6461       parameter (max_cont=maxconts)
6462       parameter (max_dim=26)
6463       include "COMMON.CONTACTS"
6464       double precision zapas(max_dim,maxconts,max_fg_procs),
6465      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6466       common /przechowalnia/ zapas
6467       integer i,j,ii,jj,iproc,itask(4),nn
6468 c      write (iout,*) "itask",itask
6469       do i=1,2
6470         iproc=itask(i)
6471         if (iproc.gt.0) then
6472           do j=1,num_cont_hb(ii)
6473             jjc=jcont_hb(j,ii)
6474 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6475             if (jjc.eq.jj) then
6476               ncont_sent(iproc)=ncont_sent(iproc)+1
6477               nn=ncont_sent(iproc)
6478               zapas(1,nn,iproc)=ii
6479               zapas(2,nn,iproc)=jjc
6480               zapas(3,nn,iproc)=facont_hb(j,ii)
6481               zapas(4,nn,iproc)=ees0p(j,ii)
6482               zapas(5,nn,iproc)=ees0m(j,ii)
6483               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6484               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6485               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6486               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6487               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6488               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6489               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6490               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6491               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6492               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6493               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6494               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6495               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6496               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6497               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6498               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6499               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6500               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6501               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6502               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6503               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6504               exit
6505             endif
6506           enddo
6507         endif
6508       enddo
6509       return
6510       end
6511 c------------------------------------------------------------------------------
6512       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6513      &  n_corr1)
6514 C This subroutine calculates multi-body contributions to hydrogen-bonding
6515       implicit real*8 (a-h,o-z)
6516       include 'DIMENSIONS'
6517       include 'COMMON.IOUNITS'
6518 #ifdef MPI
6519       include "mpif.h"
6520       parameter (max_cont=maxconts)
6521       parameter (max_dim=70)
6522       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6523       double precision zapas(max_dim,maxconts,max_fg_procs),
6524      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6525       common /przechowalnia/ zapas
6526       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6527      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6528 #endif
6529       include 'COMMON.SETUP'
6530       include 'COMMON.FFIELD'
6531       include 'COMMON.DERIV'
6532       include 'COMMON.LOCAL'
6533       include 'COMMON.INTERACT'
6534       include 'COMMON.CONTACTS'
6535       include 'COMMON.CHAIN'
6536       include 'COMMON.CONTROL'
6537       double precision gx(3),gx1(3)
6538       integer num_cont_hb_old(maxres)
6539       logical lprn,ldone
6540       double precision eello4,eello5,eelo6,eello_turn6
6541       external eello4,eello5,eello6,eello_turn6
6542 C Set lprn=.true. for debugging
6543       lprn=.false.
6544       eturn6=0.0d0
6545 #ifdef MPI
6546       do i=1,nres
6547         num_cont_hb_old(i)=num_cont_hb(i)
6548       enddo
6549       n_corr=0
6550       n_corr1=0
6551       if (nfgtasks.le.1) goto 30
6552       if (lprn) then
6553         write (iout,'(a)') 'Contact function values before RECEIVE:'
6554         do i=nnt,nct-2
6555           write (iout,'(2i3,50(1x,i2,f5.2))')
6556      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6557      &    j=1,num_cont_hb(i))
6558         enddo
6559       endif
6560       call flush(iout)
6561       do i=1,ntask_cont_from
6562         ncont_recv(i)=0
6563       enddo
6564       do i=1,ntask_cont_to
6565         ncont_sent(i)=0
6566       enddo
6567 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6568 c     & ntask_cont_to
6569 C Make the list of contacts to send to send to other procesors
6570       do i=iturn3_start,iturn3_end
6571 c        write (iout,*) "make contact list turn3",i," num_cont",
6572 c     &    num_cont_hb(i)
6573         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6574       enddo
6575       do i=iturn4_start,iturn4_end
6576 c        write (iout,*) "make contact list turn4",i," num_cont",
6577 c     &   num_cont_hb(i)
6578         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6579       enddo
6580       do ii=1,nat_sent
6581         i=iat_sent(ii)
6582 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6583 c     &    num_cont_hb(i)
6584         do j=1,num_cont_hb(i)
6585         do k=1,4
6586           jjc=jcont_hb(j,i)
6587           iproc=iint_sent_local(k,jjc,ii)
6588 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6589           if (iproc.ne.0) then
6590             ncont_sent(iproc)=ncont_sent(iproc)+1
6591             nn=ncont_sent(iproc)
6592             zapas(1,nn,iproc)=i
6593             zapas(2,nn,iproc)=jjc
6594             zapas(3,nn,iproc)=d_cont(j,i)
6595             ind=3
6596             do kk=1,3
6597               ind=ind+1
6598               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6599             enddo
6600             do kk=1,2
6601               do ll=1,2
6602                 ind=ind+1
6603                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6604               enddo
6605             enddo
6606             do jj=1,5
6607               do kk=1,3
6608                 do ll=1,2
6609                   do mm=1,2
6610                     ind=ind+1
6611                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6612                   enddo
6613                 enddo
6614               enddo
6615             enddo
6616           endif
6617         enddo
6618         enddo
6619       enddo
6620       if (lprn) then
6621       write (iout,*)
6622      &  "Numbers of contacts to be sent to other processors",
6623      &  (ncont_sent(i),i=1,ntask_cont_to)
6624       write (iout,*) "Contacts sent"
6625       do ii=1,ntask_cont_to
6626         nn=ncont_sent(ii)
6627         iproc=itask_cont_to(ii)
6628         write (iout,*) nn," contacts to processor",iproc,
6629      &   " of CONT_TO_COMM group"
6630         do i=1,nn
6631           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6632         enddo
6633       enddo
6634       call flush(iout)
6635       endif
6636       CorrelType=477
6637       CorrelID=fg_rank+1
6638       CorrelType1=478
6639       CorrelID1=nfgtasks+fg_rank+1
6640       ireq=0
6641 C Receive the numbers of needed contacts from other processors
6642       do ii=1,ntask_cont_from
6643         iproc=itask_cont_from(ii)
6644         ireq=ireq+1
6645         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6646      &    FG_COMM,req(ireq),IERR)
6647       enddo
6648 c      write (iout,*) "IRECV ended"
6649 c      call flush(iout)
6650 C Send the number of contacts needed by other processors
6651       do ii=1,ntask_cont_to
6652         iproc=itask_cont_to(ii)
6653         ireq=ireq+1
6654         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6655      &    FG_COMM,req(ireq),IERR)
6656       enddo
6657 c      write (iout,*) "ISEND ended"
6658 c      write (iout,*) "number of requests (nn)",ireq
6659       call flush(iout)
6660       if (ireq.gt.0)
6661      &  call MPI_Waitall(ireq,req,status_array,ierr)
6662 c      write (iout,*)
6663 c     &  "Numbers of contacts to be received from other processors",
6664 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6665 c      call flush(iout)
6666 C Receive contacts
6667       ireq=0
6668       do ii=1,ntask_cont_from
6669         iproc=itask_cont_from(ii)
6670         nn=ncont_recv(ii)
6671 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6672 c     &   " of CONT_TO_COMM group"
6673         call flush(iout)
6674         if (nn.gt.0) then
6675           ireq=ireq+1
6676           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6677      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6678 c          write (iout,*) "ireq,req",ireq,req(ireq)
6679         endif
6680       enddo
6681 C Send the contacts to processors that need them
6682       do ii=1,ntask_cont_to
6683         iproc=itask_cont_to(ii)
6684         nn=ncont_sent(ii)
6685 c        write (iout,*) nn," contacts to processor",iproc,
6686 c     &   " of CONT_TO_COMM group"
6687         if (nn.gt.0) then
6688           ireq=ireq+1
6689           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6690      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6691 c          write (iout,*) "ireq,req",ireq,req(ireq)
6692 c          do i=1,nn
6693 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6694 c          enddo
6695         endif
6696       enddo
6697 c      write (iout,*) "number of requests (contacts)",ireq
6698 c      write (iout,*) "req",(req(i),i=1,4)
6699 c      call flush(iout)
6700       if (ireq.gt.0)
6701      & call MPI_Waitall(ireq,req,status_array,ierr)
6702       do iii=1,ntask_cont_from
6703         iproc=itask_cont_from(iii)
6704         nn=ncont_recv(iii)
6705         if (lprn) then
6706         write (iout,*) "Received",nn," contacts from processor",iproc,
6707      &   " of CONT_FROM_COMM group"
6708         call flush(iout)
6709         do i=1,nn
6710           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6711         enddo
6712         call flush(iout)
6713         endif
6714         do i=1,nn
6715           ii=zapas_recv(1,i,iii)
6716 c Flag the received contacts to prevent double-counting
6717           jj=-zapas_recv(2,i,iii)
6718 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6719 c          call flush(iout)
6720           nnn=num_cont_hb(ii)+1
6721           num_cont_hb(ii)=nnn
6722           jcont_hb(nnn,ii)=jj
6723           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6724           ind=3
6725           do kk=1,3
6726             ind=ind+1
6727             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6728           enddo
6729           do kk=1,2
6730             do ll=1,2
6731               ind=ind+1
6732               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6733             enddo
6734           enddo
6735           do jj=1,5
6736             do kk=1,3
6737               do ll=1,2
6738                 do mm=1,2
6739                   ind=ind+1
6740                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6741                 enddo
6742               enddo
6743             enddo
6744           enddo
6745         enddo
6746       enddo
6747       call flush(iout)
6748       if (lprn) then
6749         write (iout,'(a)') 'Contact function values after receive:'
6750         do i=nnt,nct-2
6751           write (iout,'(2i3,50(1x,i3,5f6.3))')
6752      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6753      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6754         enddo
6755         call flush(iout)
6756       endif
6757    30 continue
6758 #endif
6759       if (lprn) then
6760         write (iout,'(a)') 'Contact function values:'
6761         do i=nnt,nct-2
6762           write (iout,'(2i3,50(1x,i2,5f6.3))')
6763      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6764      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6765         enddo
6766       endif
6767       ecorr=0.0D0
6768       ecorr5=0.0d0
6769       ecorr6=0.0d0
6770 C Remove the loop below after debugging !!!
6771       do i=nnt,nct
6772         do j=1,3
6773           gradcorr(j,i)=0.0D0
6774           gradxorr(j,i)=0.0D0
6775         enddo
6776       enddo
6777 C Calculate the dipole-dipole interaction energies
6778       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6779       do i=iatel_s,iatel_e+1
6780         num_conti=num_cont_hb(i)
6781         do jj=1,num_conti
6782           j=jcont_hb(jj,i)
6783 #ifdef MOMENT
6784           call dipole(i,j,jj)
6785 #endif
6786         enddo
6787       enddo
6788       endif
6789 C Calculate the local-electrostatic correlation terms
6790 c                write (iout,*) "gradcorr5 in eello5 before loop"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6796 c        write (iout,*) "corr loop i",i
6797         i1=i+1
6798         num_conti=num_cont_hb(i)
6799         num_conti1=num_cont_hb(i+1)
6800         do jj=1,num_conti
6801           j=jcont_hb(jj,i)
6802           jp=iabs(j)
6803           do kk=1,num_conti1
6804             j1=jcont_hb(kk,i1)
6805             jp1=iabs(j1)
6806 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6807 c     &         ' jj=',jj,' kk=',kk
6808 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6809             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6810      &          .or. j.lt.0 .and. j1.gt.0) .and.
6811      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6812 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6813 C The system gains extra energy.
6814               n_corr=n_corr+1
6815               sqd1=dsqrt(d_cont(jj,i))
6816               sqd2=dsqrt(d_cont(kk,i1))
6817               sred_geom = sqd1*sqd2
6818               IF (sred_geom.lt.cutoff_corr) THEN
6819                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6820      &            ekont,fprimcont)
6821 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6822 cd     &         ' jj=',jj,' kk=',kk
6823                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6824                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6825                 do l=1,3
6826                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6827                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6828                 enddo
6829                 n_corr1=n_corr1+1
6830 cd               write (iout,*) 'sred_geom=',sred_geom,
6831 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6832 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6833 cd               write (iout,*) "g_contij",g_contij
6834 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6835 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6836                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6837                 if (wcorr4.gt.0.0d0)
6838      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6839                   if (energy_dec.and.wcorr4.gt.0.0d0)
6840      1                 write (iout,'(a6,4i5,0pf7.3)')
6841      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6842 c                write (iout,*) "gradcorr5 before eello5"
6843 c                do iii=1,nres
6844 c                  write (iout,'(i5,3f10.5)')
6845 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6846 c                enddo
6847                 if (wcorr5.gt.0.0d0)
6848      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6849 c                write (iout,*) "gradcorr5 after eello5"
6850 c                do iii=1,nres
6851 c                  write (iout,'(i5,3f10.5)')
6852 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6853 c                enddo
6854                   if (energy_dec.and.wcorr5.gt.0.0d0)
6855      1                 write (iout,'(a6,4i5,0pf7.3)')
6856      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6857 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6858 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6859                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6860      &               .or. wturn6.eq.0.0d0))then
6861 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6862                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6863                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6864      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6865 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6866 cd     &            'ecorr6=',ecorr6
6867 cd                write (iout,'(4e15.5)') sred_geom,
6868 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6869 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6870 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6871                 else if (wturn6.gt.0.0d0
6872      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6873 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6874                   eturn6=eturn6+eello_turn6(i,jj,kk)
6875                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6876      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6877 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6878                 endif
6879               ENDIF
6880 1111          continue
6881             endif
6882           enddo ! kk
6883         enddo ! jj
6884       enddo ! i
6885       do i=1,nres
6886         num_cont_hb(i)=num_cont_hb_old(i)
6887       enddo
6888 c                write (iout,*) "gradcorr5 in eello5"
6889 c                do iii=1,nres
6890 c                  write (iout,'(i5,3f10.5)')
6891 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6892 c                enddo
6893       return
6894       end
6895 c------------------------------------------------------------------------------
6896       subroutine add_hb_contact_eello(ii,jj,itask)
6897       implicit real*8 (a-h,o-z)
6898       include "DIMENSIONS"
6899       include "COMMON.IOUNITS"
6900       integer max_cont
6901       integer max_dim
6902       parameter (max_cont=maxconts)
6903       parameter (max_dim=70)
6904       include "COMMON.CONTACTS"
6905       double precision zapas(max_dim,maxconts,max_fg_procs),
6906      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6907       common /przechowalnia/ zapas
6908       integer i,j,ii,jj,iproc,itask(4),nn
6909 c      write (iout,*) "itask",itask
6910       do i=1,2
6911         iproc=itask(i)
6912         if (iproc.gt.0) then
6913           do j=1,num_cont_hb(ii)
6914             jjc=jcont_hb(j,ii)
6915 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6916             if (jjc.eq.jj) then
6917               ncont_sent(iproc)=ncont_sent(iproc)+1
6918               nn=ncont_sent(iproc)
6919               zapas(1,nn,iproc)=ii
6920               zapas(2,nn,iproc)=jjc
6921               zapas(3,nn,iproc)=d_cont(j,ii)
6922               ind=3
6923               do kk=1,3
6924                 ind=ind+1
6925                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6926               enddo
6927               do kk=1,2
6928                 do ll=1,2
6929                   ind=ind+1
6930                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6931                 enddo
6932               enddo
6933               do jj=1,5
6934                 do kk=1,3
6935                   do ll=1,2
6936                     do mm=1,2
6937                       ind=ind+1
6938                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6939                     enddo
6940                   enddo
6941                 enddo
6942               enddo
6943               exit
6944             endif
6945           enddo
6946         endif
6947       enddo
6948       return
6949       end
6950 c------------------------------------------------------------------------------
6951       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6952       implicit real*8 (a-h,o-z)
6953       include 'DIMENSIONS'
6954       include 'COMMON.IOUNITS'
6955       include 'COMMON.DERIV'
6956       include 'COMMON.INTERACT'
6957       include 'COMMON.CONTACTS'
6958       double precision gx(3),gx1(3)
6959       logical lprn
6960       lprn=.false.
6961       eij=facont_hb(jj,i)
6962       ekl=facont_hb(kk,k)
6963       ees0pij=ees0p(jj,i)
6964       ees0pkl=ees0p(kk,k)
6965       ees0mij=ees0m(jj,i)
6966       ees0mkl=ees0m(kk,k)
6967       ekont=eij*ekl
6968       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6969 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6970 C Following 4 lines for diagnostics.
6971 cd    ees0pkl=0.0D0
6972 cd    ees0pij=1.0D0
6973 cd    ees0mkl=0.0D0
6974 cd    ees0mij=1.0D0
6975 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6976 c     & 'Contacts ',i,j,
6977 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6978 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6979 c     & 'gradcorr_long'
6980 C Calculate the multi-body contribution to energy.
6981 c      ecorr=ecorr+ekont*ees
6982 C Calculate multi-body contributions to the gradient.
6983       coeffpees0pij=coeffp*ees0pij
6984       coeffmees0mij=coeffm*ees0mij
6985       coeffpees0pkl=coeffp*ees0pkl
6986       coeffmees0mkl=coeffm*ees0mkl
6987       do ll=1,3
6988 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6989         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6990      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6991      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6992         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6993      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6994      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6995 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6996         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6997      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6998      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6999         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7000      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7001      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7002         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7003      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7004      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7005         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7006         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7007         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7008      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7009      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7010         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7011         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7012 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7013       enddo
7014 c      write (iout,*)
7015 cgrad      do m=i+1,j-1
7016 cgrad        do ll=1,3
7017 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7018 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7019 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7020 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7021 cgrad        enddo
7022 cgrad      enddo
7023 cgrad      do m=k+1,l-1
7024 cgrad        do ll=1,3
7025 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7026 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7027 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7028 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7029 cgrad        enddo
7030 cgrad      enddo
7031 c      write (iout,*) "ehbcorr",ekont*ees
7032       ehbcorr=ekont*ees
7033       return
7034       end
7035 #ifdef MOMENT
7036 C---------------------------------------------------------------------------
7037       subroutine dipole(i,j,jj)
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.CHAIN'
7042       include 'COMMON.FFIELD'
7043       include 'COMMON.DERIV'
7044       include 'COMMON.INTERACT'
7045       include 'COMMON.CONTACTS'
7046       include 'COMMON.TORSION'
7047       include 'COMMON.VAR'
7048       include 'COMMON.GEO'
7049       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7050      &  auxmat(2,2)
7051       iti1 = itortyp(itype(i+1))
7052       if (j.lt.nres-1) then
7053         itj1 = itortyp(itype(j+1))
7054       else
7055         itj1=ntortyp+1
7056       endif
7057       do iii=1,2
7058         dipi(iii,1)=Ub2(iii,i)
7059         dipderi(iii)=Ub2der(iii,i)
7060         dipi(iii,2)=b1(iii,iti1)
7061         dipj(iii,1)=Ub2(iii,j)
7062         dipderj(iii)=Ub2der(iii,j)
7063         dipj(iii,2)=b1(iii,itj1)
7064       enddo
7065       kkk=0
7066       do iii=1,2
7067         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7068         do jjj=1,2
7069           kkk=kkk+1
7070           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7071         enddo
7072       enddo
7073       do kkk=1,5
7074         do lll=1,3
7075           mmm=0
7076           do iii=1,2
7077             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7078      &        auxvec(1))
7079             do jjj=1,2
7080               mmm=mmm+1
7081               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7082             enddo
7083           enddo
7084         enddo
7085       enddo
7086       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7087       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7088       do iii=1,2
7089         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7090       enddo
7091       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7092       do iii=1,2
7093         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7094       enddo
7095       return
7096       end
7097 #endif
7098 C---------------------------------------------------------------------------
7099       subroutine calc_eello(i,j,k,l,jj,kk)
7100 C
7101 C This subroutine computes matrices and vectors needed to calculate
7102 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7103 C
7104       implicit real*8 (a-h,o-z)
7105       include 'DIMENSIONS'
7106       include 'COMMON.IOUNITS'
7107       include 'COMMON.CHAIN'
7108       include 'COMMON.DERIV'
7109       include 'COMMON.INTERACT'
7110       include 'COMMON.CONTACTS'
7111       include 'COMMON.TORSION'
7112       include 'COMMON.VAR'
7113       include 'COMMON.GEO'
7114       include 'COMMON.FFIELD'
7115       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7116      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7117       logical lprn
7118       common /kutas/ lprn
7119 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7120 cd     & ' jj=',jj,' kk=',kk
7121 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7122 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7123 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7124       do iii=1,2
7125         do jjj=1,2
7126           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7127           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7128         enddo
7129       enddo
7130       call transpose2(aa1(1,1),aa1t(1,1))
7131       call transpose2(aa2(1,1),aa2t(1,1))
7132       do kkk=1,5
7133         do lll=1,3
7134           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7135      &      aa1tder(1,1,lll,kkk))
7136           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7137      &      aa2tder(1,1,lll,kkk))
7138         enddo
7139       enddo
7140       if (l.eq.j+1) then
7141 C parallel orientation of the two CA-CA-CA frames.
7142         if (i.gt.1) then
7143           iti=itortyp(itype(i))
7144         else
7145           iti=ntortyp+1
7146         endif
7147         itk1=itortyp(itype(k+1))
7148         itj=itortyp(itype(j))
7149         if (l.lt.nres-1) then
7150           itl1=itortyp(itype(l+1))
7151         else
7152           itl1=ntortyp+1
7153         endif
7154 C A1 kernel(j+1) A2T
7155 cd        do iii=1,2
7156 cd          write (iout,'(3f10.5,5x,3f10.5)')
7157 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7158 cd        enddo
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.,EUg(1,1,l),EUgder(1,1,l),
7161      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7162 C Following matrices are needed only for 6-th order cumulants
7163         IF (wcorr6.gt.0.0d0) THEN
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7165      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7166      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),
7169      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7170      &   ADtEAderx(1,1,1,1,1,1))
7171         lprn=.false.
7172         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7173      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7174      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7175      &   ADtEA1derx(1,1,1,1,1,1))
7176         ENDIF
7177 C End 6-th order cumulants
7178 cd        lprn=.false.
7179 cd        if (lprn) then
7180 cd        write (2,*) 'In calc_eello6'
7181 cd        do iii=1,2
7182 cd          write (2,*) 'iii=',iii
7183 cd          do kkk=1,5
7184 cd            write (2,*) 'kkk=',kkk
7185 cd            do jjj=1,2
7186 cd              write (2,'(3(2f10.5),5x)')
7187 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7188 cd            enddo
7189 cd          enddo
7190 cd        enddo
7191 cd        endif
7192         call transpose2(EUgder(1,1,k),auxmat(1,1))
7193         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7194         call transpose2(EUg(1,1,k),auxmat(1,1))
7195         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7196         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7197         do iii=1,2
7198           do kkk=1,5
7199             do lll=1,3
7200               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7201      &          EAEAderx(1,1,lll,kkk,iii,1))
7202             enddo
7203           enddo
7204         enddo
7205 C A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),
7208      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7209 C Following matrices are needed only for 6-th order cumulants
7210         IF (wcorr6.gt.0.0d0) THEN
7211         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7212      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7213      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7214         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7215      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7216      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7217      &   ADtEAderx(1,1,1,1,1,2))
7218         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7219      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7220      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7221      &   ADtEA1derx(1,1,1,1,1,2))
7222         ENDIF
7223 C End 6-th order cumulants
7224         call transpose2(EUgder(1,1,l),auxmat(1,1))
7225         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7226         call transpose2(EUg(1,1,l),auxmat(1,1))
7227         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7228         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7229         do iii=1,2
7230           do kkk=1,5
7231             do lll=1,3
7232               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7233      &          EAEAderx(1,1,lll,kkk,iii,2))
7234             enddo
7235           enddo
7236         enddo
7237 C AEAb1 and AEAb2
7238 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7239 C They are needed only when the fifth- or the sixth-order cumulants are
7240 C indluded.
7241         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7242         call transpose2(AEA(1,1,1),auxmat(1,1))
7243         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7244         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7245         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7246         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7247         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7248         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7249         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7250         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7251         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7252         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7253         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7254         call transpose2(AEA(1,1,2),auxmat(1,1))
7255         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7256         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7257         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7258         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7259         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7260         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7261         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7262         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7263         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7264         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7265         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7266 C Calculate the Cartesian derivatives of the vectors.
7267         do iii=1,2
7268           do kkk=1,5
7269             do lll=1,3
7270               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7271               call matvec2(auxmat(1,1),b1(1,iti),
7272      &          AEAb1derx(1,lll,kkk,iii,1,1))
7273               call matvec2(auxmat(1,1),Ub2(1,i),
7274      &          AEAb2derx(1,lll,kkk,iii,1,1))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7276      &          AEAb1derx(1,lll,kkk,iii,2,1))
7277               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7278      &          AEAb2derx(1,lll,kkk,iii,2,1))
7279               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7280               call matvec2(auxmat(1,1),b1(1,itj),
7281      &          AEAb1derx(1,lll,kkk,iii,1,2))
7282               call matvec2(auxmat(1,1),Ub2(1,j),
7283      &          AEAb2derx(1,lll,kkk,iii,1,2))
7284               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7285      &          AEAb1derx(1,lll,kkk,iii,2,2))
7286               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7287      &          AEAb2derx(1,lll,kkk,iii,2,2))
7288             enddo
7289           enddo
7290         enddo
7291         ENDIF
7292 C End vectors
7293       else
7294 C Antiparallel orientation of the two CA-CA-CA frames.
7295         if (i.gt.1) then
7296           iti=itortyp(itype(i))
7297         else
7298           iti=ntortyp+1
7299         endif
7300         itk1=itortyp(itype(k+1))
7301         itl=itortyp(itype(l))
7302         itj=itortyp(itype(j))
7303         if (j.lt.nres-1) then
7304           itj1=itortyp(itype(j+1))
7305         else
7306           itj1=ntortyp+1
7307         endif
7308 C A2 kernel(j-1)T A1T
7309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7310      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7311      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7312 C Following matrices are needed only for 6-th order cumulants
7313         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7314      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7315         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7316      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7317      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7318         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7319      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7320      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7321      &   ADtEAderx(1,1,1,1,1,1))
7322         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7323      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7324      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7325      &   ADtEA1derx(1,1,1,1,1,1))
7326         ENDIF
7327 C End 6-th order cumulants
7328         call transpose2(EUgder(1,1,k),auxmat(1,1))
7329         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7330         call transpose2(EUg(1,1,k),auxmat(1,1))
7331         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7332         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7333         do iii=1,2
7334           do kkk=1,5
7335             do lll=1,3
7336               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7337      &          EAEAderx(1,1,lll,kkk,iii,1))
7338             enddo
7339           enddo
7340         enddo
7341 C A2T kernel(i+1)T A1
7342         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7343      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7344      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7345 C Following matrices are needed only for 6-th order cumulants
7346         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7347      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7348         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7349      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7350      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7351         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7352      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7353      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7354      &   ADtEAderx(1,1,1,1,1,2))
7355         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7356      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7357      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7358      &   ADtEA1derx(1,1,1,1,1,2))
7359         ENDIF
7360 C End 6-th order cumulants
7361         call transpose2(EUgder(1,1,j),auxmat(1,1))
7362         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7363         call transpose2(EUg(1,1,j),auxmat(1,1))
7364         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7365         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7366         do iii=1,2
7367           do kkk=1,5
7368             do lll=1,3
7369               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7370      &          EAEAderx(1,1,lll,kkk,iii,2))
7371             enddo
7372           enddo
7373         enddo
7374 C AEAb1 and AEAb2
7375 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7376 C They are needed only when the fifth- or the sixth-order cumulants are
7377 C indluded.
7378         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7379      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7380         call transpose2(AEA(1,1,1),auxmat(1,1))
7381         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7382         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7383         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7384         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7385         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7386         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7387         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7388         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7389         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7390         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7391         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7392         call transpose2(AEA(1,1,2),auxmat(1,1))
7393         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7394         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7395         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7396         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7397         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7398         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7399         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7400         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7401         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7402         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7403         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7404 C Calculate the Cartesian derivatives of the vectors.
7405         do iii=1,2
7406           do kkk=1,5
7407             do lll=1,3
7408               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7409               call matvec2(auxmat(1,1),b1(1,iti),
7410      &          AEAb1derx(1,lll,kkk,iii,1,1))
7411               call matvec2(auxmat(1,1),Ub2(1,i),
7412      &          AEAb2derx(1,lll,kkk,iii,1,1))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7414      &          AEAb1derx(1,lll,kkk,iii,2,1))
7415               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7416      &          AEAb2derx(1,lll,kkk,iii,2,1))
7417               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7418               call matvec2(auxmat(1,1),b1(1,itl),
7419      &          AEAb1derx(1,lll,kkk,iii,1,2))
7420               call matvec2(auxmat(1,1),Ub2(1,l),
7421      &          AEAb2derx(1,lll,kkk,iii,1,2))
7422               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7423      &          AEAb1derx(1,lll,kkk,iii,2,2))
7424               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7425      &          AEAb2derx(1,lll,kkk,iii,2,2))
7426             enddo
7427           enddo
7428         enddo
7429         ENDIF
7430 C End vectors
7431       endif
7432       return
7433       end
7434 C---------------------------------------------------------------------------
7435       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7436      &  KK,KKderg,AKA,AKAderg,AKAderx)
7437       implicit none
7438       integer nderg
7439       logical transp
7440       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7441      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7442      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7443       integer iii,kkk,lll
7444       integer jjj,mmm
7445       logical lprn
7446       common /kutas/ lprn
7447       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7448       do iii=1,nderg
7449         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7450      &    AKAderg(1,1,iii))
7451       enddo
7452 cd      if (lprn) write (2,*) 'In kernel'
7453       do kkk=1,5
7454 cd        if (lprn) write (2,*) 'kkk=',kkk
7455         do lll=1,3
7456           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7457      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7458 cd          if (lprn) then
7459 cd            write (2,*) 'lll=',lll
7460 cd            write (2,*) 'iii=1'
7461 cd            do jjj=1,2
7462 cd              write (2,'(3(2f10.5),5x)')
7463 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7464 cd            enddo
7465 cd          endif
7466           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7467      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7468 cd          if (lprn) then
7469 cd            write (2,*) 'lll=',lll
7470 cd            write (2,*) 'iii=2'
7471 cd            do jjj=1,2
7472 cd              write (2,'(3(2f10.5),5x)')
7473 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7474 cd            enddo
7475 cd          endif
7476         enddo
7477       enddo
7478       return
7479       end
7480 C---------------------------------------------------------------------------
7481       double precision function eello4(i,j,k,l,jj,kk)
7482       implicit real*8 (a-h,o-z)
7483       include 'DIMENSIONS'
7484       include 'COMMON.IOUNITS'
7485       include 'COMMON.CHAIN'
7486       include 'COMMON.DERIV'
7487       include 'COMMON.INTERACT'
7488       include 'COMMON.CONTACTS'
7489       include 'COMMON.TORSION'
7490       include 'COMMON.VAR'
7491       include 'COMMON.GEO'
7492       double precision pizda(2,2),ggg1(3),ggg2(3)
7493 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7494 cd        eello4=0.0d0
7495 cd        return
7496 cd      endif
7497 cd      print *,'eello4:',i,j,k,l,jj,kk
7498 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7499 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7500 cold      eij=facont_hb(jj,i)
7501 cold      ekl=facont_hb(kk,k)
7502 cold      ekont=eij*ekl
7503       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7504 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7505       gcorr_loc(k-1)=gcorr_loc(k-1)
7506      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7507       if (l.eq.j+1) then
7508         gcorr_loc(l-1)=gcorr_loc(l-1)
7509      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7510       else
7511         gcorr_loc(j-1)=gcorr_loc(j-1)
7512      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7513       endif
7514       do iii=1,2
7515         do kkk=1,5
7516           do lll=1,3
7517             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7518      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7519 cd            derx(lll,kkk,iii)=0.0d0
7520           enddo
7521         enddo
7522       enddo
7523 cd      gcorr_loc(l-1)=0.0d0
7524 cd      gcorr_loc(j-1)=0.0d0
7525 cd      gcorr_loc(k-1)=0.0d0
7526 cd      eel4=1.0d0
7527 cd      write (iout,*)'Contacts have occurred for peptide groups',
7528 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7529 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7530       if (j.lt.nres-1) then
7531         j1=j+1
7532         j2=j-1
7533       else
7534         j1=j-1
7535         j2=j-2
7536       endif
7537       if (l.lt.nres-1) then
7538         l1=l+1
7539         l2=l-1
7540       else
7541         l1=l-1
7542         l2=l-2
7543       endif
7544       do ll=1,3
7545 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7546 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7547         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7548         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7549 cgrad        ghalf=0.5d0*ggg1(ll)
7550         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7551         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7552         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7553         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7554         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7555         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7556 cgrad        ghalf=0.5d0*ggg2(ll)
7557         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7558         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7559         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7560         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7561         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7562         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7563       enddo
7564 cgrad      do m=i+1,j-1
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cgrad      do m=k+1,l-1
7570 cgrad        do ll=1,3
7571 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7572 cgrad        enddo
7573 cgrad      enddo
7574 cgrad      do m=i+2,j2
7575 cgrad        do ll=1,3
7576 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7577 cgrad        enddo
7578 cgrad      enddo
7579 cgrad      do m=k+2,l2
7580 cgrad        do ll=1,3
7581 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7582 cgrad        enddo
7583 cgrad      enddo
7584 cd      do iii=1,nres-3
7585 cd        write (2,*) iii,gcorr_loc(iii)
7586 cd      enddo
7587       eello4=ekont*eel4
7588 cd      write (2,*) 'ekont',ekont
7589 cd      write (iout,*) 'eello4',ekont*eel4
7590       return
7591       end
7592 C---------------------------------------------------------------------------
7593       double precision function eello5(i,j,k,l,jj,kk)
7594       implicit real*8 (a-h,o-z)
7595       include 'DIMENSIONS'
7596       include 'COMMON.IOUNITS'
7597       include 'COMMON.CHAIN'
7598       include 'COMMON.DERIV'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.CONTACTS'
7601       include 'COMMON.TORSION'
7602       include 'COMMON.VAR'
7603       include 'COMMON.GEO'
7604       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7605       double precision ggg1(3),ggg2(3)
7606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7607 C                                                                              C
7608 C                            Parallel chains                                   C
7609 C                                                                              C
7610 C          o             o                   o             o                   C
7611 C         /l\           / \             \   / \           / \   /              C
7612 C        /   \         /   \             \ /   \         /   \ /               C
7613 C       j| o |l1       | o |              o| o |         | o |o                C
7614 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7615 C      \i/   \         /   \ /             /   \         /   \                 C
7616 C       o    k1             o                                                  C
7617 C         (I)          (II)                (III)          (IV)                 C
7618 C                                                                              C
7619 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7620 C                                                                              C
7621 C                            Antiparallel chains                               C
7622 C                                                                              C
7623 C          o             o                   o             o                   C
7624 C         /j\           / \             \   / \           / \   /              C
7625 C        /   \         /   \             \ /   \         /   \ /               C
7626 C      j1| o |l        | o |              o| o |         | o |o                C
7627 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7628 C      \i/   \         /   \ /             /   \         /   \                 C
7629 C       o     k1            o                                                  C
7630 C         (I)          (II)                (III)          (IV)                 C
7631 C                                                                              C
7632 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7633 C                                                                              C
7634 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7635 C                                                                              C
7636 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7637 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7638 cd        eello5=0.0d0
7639 cd        return
7640 cd      endif
7641 cd      write (iout,*)
7642 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7643 cd     &   ' and',k,l
7644       itk=itortyp(itype(k))
7645       itl=itortyp(itype(l))
7646       itj=itortyp(itype(j))
7647       eello5_1=0.0d0
7648       eello5_2=0.0d0
7649       eello5_3=0.0d0
7650       eello5_4=0.0d0
7651 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7652 cd     &   eel5_3_num,eel5_4_num)
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656             derx(lll,kkk,iii)=0.0d0
7657           enddo
7658         enddo
7659       enddo
7660 cd      eij=facont_hb(jj,i)
7661 cd      ekl=facont_hb(kk,k)
7662 cd      ekont=eij*ekl
7663 cd      write (iout,*)'Contacts have occurred for peptide groups',
7664 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7665 cd      goto 1111
7666 C Contribution from the graph I.
7667 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7668 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7669       call transpose2(EUg(1,1,k),auxmat(1,1))
7670       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7671       vv(1)=pizda(1,1)-pizda(2,2)
7672       vv(2)=pizda(1,2)+pizda(2,1)
7673       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7674      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7675 C Explicit gradient in virtual-dihedral angles.
7676       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7677      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7678      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7679       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7680       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7681       vv(1)=pizda(1,1)-pizda(2,2)
7682       vv(2)=pizda(1,2)+pizda(2,1)
7683       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7684      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7685      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7686       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7687       vv(1)=pizda(1,1)-pizda(2,2)
7688       vv(2)=pizda(1,2)+pizda(2,1)
7689       if (l.eq.j+1) then
7690         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7691      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7692      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7693       else
7694         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7695      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7696      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7697       endif
7698 C Cartesian gradient
7699       do iii=1,2
7700         do kkk=1,5
7701           do lll=1,3
7702             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7703      &        pizda(1,1))
7704             vv(1)=pizda(1,1)-pizda(2,2)
7705             vv(2)=pizda(1,2)+pizda(2,1)
7706             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7707      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7708      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7709           enddo
7710         enddo
7711       enddo
7712 c      goto 1112
7713 c1111  continue
7714 C Contribution from graph II
7715       call transpose2(EE(1,1,itk),auxmat(1,1))
7716       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7717       vv(1)=pizda(1,1)+pizda(2,2)
7718       vv(2)=pizda(2,1)-pizda(1,2)
7719       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7720      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7721 C Explicit gradient in virtual-dihedral angles.
7722       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7723      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7724       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7725       vv(1)=pizda(1,1)+pizda(2,2)
7726       vv(2)=pizda(2,1)-pizda(1,2)
7727       if (l.eq.j+1) then
7728         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7729      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7730      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7731       else
7732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7733      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7734      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7735       endif
7736 C Cartesian gradient
7737       do iii=1,2
7738         do kkk=1,5
7739           do lll=1,3
7740             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7741      &        pizda(1,1))
7742             vv(1)=pizda(1,1)+pizda(2,2)
7743             vv(2)=pizda(2,1)-pizda(1,2)
7744             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7745      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7746      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7747           enddo
7748         enddo
7749       enddo
7750 cd      goto 1112
7751 cd1111  continue
7752       if (l.eq.j+1) then
7753 cd        goto 1110
7754 C Parallel orientation
7755 C Contribution from graph III
7756         call transpose2(EUg(1,1,l),auxmat(1,1))
7757         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7758         vv(1)=pizda(1,1)-pizda(2,2)
7759         vv(2)=pizda(1,2)+pizda(2,1)
7760         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7762 C Explicit gradient in virtual-dihedral angles.
7763         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7764      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7765      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7766         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7767         vv(1)=pizda(1,1)-pizda(2,2)
7768         vv(2)=pizda(1,2)+pizda(2,1)
7769         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7770      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7771      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7772         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7773         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7774         vv(1)=pizda(1,1)-pizda(2,2)
7775         vv(2)=pizda(1,2)+pizda(2,1)
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7778      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7779 C Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7784      &          pizda(1,1))
7785               vv(1)=pizda(1,1)-pizda(2,2)
7786               vv(2)=pizda(1,2)+pizda(2,1)
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7788      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7789      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7790             enddo
7791           enddo
7792         enddo
7793 cd        goto 1112
7794 C Contribution from graph IV
7795 cd1110    continue
7796         call transpose2(EE(1,1,itl),auxmat(1,1))
7797         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7798         vv(1)=pizda(1,1)+pizda(2,2)
7799         vv(2)=pizda(2,1)-pizda(1,2)
7800         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7801      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7802 C Explicit gradient in virtual-dihedral angles.
7803         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7804      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7805         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7806         vv(1)=pizda(1,1)+pizda(2,2)
7807         vv(2)=pizda(2,1)-pizda(1,2)
7808         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7809      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7810      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7811 C Cartesian gradient
7812         do iii=1,2
7813           do kkk=1,5
7814             do lll=1,3
7815               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7816      &          pizda(1,1))
7817               vv(1)=pizda(1,1)+pizda(2,2)
7818               vv(2)=pizda(2,1)-pizda(1,2)
7819               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7820      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7821      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7822             enddo
7823           enddo
7824         enddo
7825       else
7826 C Antiparallel orientation
7827 C Contribution from graph III
7828 c        goto 1110
7829         call transpose2(EUg(1,1,j),auxmat(1,1))
7830         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7831         vv(1)=pizda(1,1)-pizda(2,2)
7832         vv(2)=pizda(1,2)+pizda(2,1)
7833         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7834      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7835 C Explicit gradient in virtual-dihedral angles.
7836         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7837      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7838      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7839         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7840         vv(1)=pizda(1,1)-pizda(2,2)
7841         vv(2)=pizda(1,2)+pizda(2,1)
7842         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7843      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7844      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7845         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7846         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7847         vv(1)=pizda(1,1)-pizda(2,2)
7848         vv(2)=pizda(1,2)+pizda(2,1)
7849         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7850      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7851      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7852 C Cartesian gradient
7853         do iii=1,2
7854           do kkk=1,5
7855             do lll=1,3
7856               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7857      &          pizda(1,1))
7858               vv(1)=pizda(1,1)-pizda(2,2)
7859               vv(2)=pizda(1,2)+pizda(2,1)
7860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7861      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7862      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7863             enddo
7864           enddo
7865         enddo
7866 cd        goto 1112
7867 C Contribution from graph IV
7868 1110    continue
7869         call transpose2(EE(1,1,itj),auxmat(1,1))
7870         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7871         vv(1)=pizda(1,1)+pizda(2,2)
7872         vv(2)=pizda(2,1)-pizda(1,2)
7873         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7874      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7875 C Explicit gradient in virtual-dihedral angles.
7876         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7877      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7878         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7879         vv(1)=pizda(1,1)+pizda(2,2)
7880         vv(2)=pizda(2,1)-pizda(1,2)
7881         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7882      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7883      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7884 C Cartesian gradient
7885         do iii=1,2
7886           do kkk=1,5
7887             do lll=1,3
7888               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7889      &          pizda(1,1))
7890               vv(1)=pizda(1,1)+pizda(2,2)
7891               vv(2)=pizda(2,1)-pizda(1,2)
7892               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7893      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7894      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7895             enddo
7896           enddo
7897         enddo
7898       endif
7899 1112  continue
7900       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7901 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7902 cd        write (2,*) 'ijkl',i,j,k,l
7903 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7904 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7905 cd      endif
7906 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7907 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7908 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7909 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7910       if (j.lt.nres-1) then
7911         j1=j+1
7912         j2=j-1
7913       else
7914         j1=j-1
7915         j2=j-2
7916       endif
7917       if (l.lt.nres-1) then
7918         l1=l+1
7919         l2=l-1
7920       else
7921         l1=l-1
7922         l2=l-2
7923       endif
7924 cd      eij=1.0d0
7925 cd      ekl=1.0d0
7926 cd      ekont=1.0d0
7927 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7928 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7929 C        summed up outside the subrouine as for the other subroutines
7930 C        handling long-range interactions. The old code is commented out
7931 C        with "cgrad" to keep track of changes.
7932       do ll=1,3
7933 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7934 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7935         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7936         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7937 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7938 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7939 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7940 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7941 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7942 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7943 c     &   gradcorr5ij,
7944 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7945 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7946 cgrad        ghalf=0.5d0*ggg1(ll)
7947 cd        ghalf=0.0d0
7948         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7949         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7950         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7951         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7952         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7953         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7954 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7955 cgrad        ghalf=0.5d0*ggg2(ll)
7956 cd        ghalf=0.0d0
7957         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7958         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7959         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7960         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7961         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7962         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7963       enddo
7964 cd      goto 1112
7965 cgrad      do m=i+1,j-1
7966 cgrad        do ll=1,3
7967 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7968 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7969 cgrad        enddo
7970 cgrad      enddo
7971 cgrad      do m=k+1,l-1
7972 cgrad        do ll=1,3
7973 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7974 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7975 cgrad        enddo
7976 cgrad      enddo
7977 c1112  continue
7978 cgrad      do m=i+2,j2
7979 cgrad        do ll=1,3
7980 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7981 cgrad        enddo
7982 cgrad      enddo
7983 cgrad      do m=k+2,l2
7984 cgrad        do ll=1,3
7985 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cd      do iii=1,nres-3
7989 cd        write (2,*) iii,g_corr5_loc(iii)
7990 cd      enddo
7991       eello5=ekont*eel5
7992 cd      write (2,*) 'ekont',ekont
7993 cd      write (iout,*) 'eello5',ekont*eel5
7994       return
7995       end
7996 c--------------------------------------------------------------------------
7997       double precision function eello6(i,j,k,l,jj,kk)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       include 'COMMON.IOUNITS'
8001       include 'COMMON.CHAIN'
8002       include 'COMMON.DERIV'
8003       include 'COMMON.INTERACT'
8004       include 'COMMON.CONTACTS'
8005       include 'COMMON.TORSION'
8006       include 'COMMON.VAR'
8007       include 'COMMON.GEO'
8008       include 'COMMON.FFIELD'
8009       double precision ggg1(3),ggg2(3)
8010 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8011 cd        eello6=0.0d0
8012 cd        return
8013 cd      endif
8014 cd      write (iout,*)
8015 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8016 cd     &   ' and',k,l
8017       eello6_1=0.0d0
8018       eello6_2=0.0d0
8019       eello6_3=0.0d0
8020       eello6_4=0.0d0
8021       eello6_5=0.0d0
8022       eello6_6=0.0d0
8023 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8024 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8025       do iii=1,2
8026         do kkk=1,5
8027           do lll=1,3
8028             derx(lll,kkk,iii)=0.0d0
8029           enddo
8030         enddo
8031       enddo
8032 cd      eij=facont_hb(jj,i)
8033 cd      ekl=facont_hb(kk,k)
8034 cd      ekont=eij*ekl
8035 cd      eij=1.0d0
8036 cd      ekl=1.0d0
8037 cd      ekont=1.0d0
8038       if (l.eq.j+1) then
8039         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8040         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8041         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8042         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8043         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8044         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8045       else
8046         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8047         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8048         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8049         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8050         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8051           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8052         else
8053           eello6_5=0.0d0
8054         endif
8055         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8056       endif
8057 C If turn contributions are considered, they will be handled separately.
8058       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8059 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8060 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8061 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8062 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8063 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8064 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8065 cd      goto 1112
8066       if (j.lt.nres-1) then
8067         j1=j+1
8068         j2=j-1
8069       else
8070         j1=j-1
8071         j2=j-2
8072       endif
8073       if (l.lt.nres-1) then
8074         l1=l+1
8075         l2=l-1
8076       else
8077         l1=l-1
8078         l2=l-2
8079       endif
8080       do ll=1,3
8081 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8082 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8083 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8084 cgrad        ghalf=0.5d0*ggg1(ll)
8085 cd        ghalf=0.0d0
8086         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8087         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8088         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8089         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8090         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8091         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8092         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8093         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8094 cgrad        ghalf=0.5d0*ggg2(ll)
8095 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8096 cd        ghalf=0.0d0
8097         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8098         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8099         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8100         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8101         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8102         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8103       enddo
8104 cd      goto 1112
8105 cgrad      do m=i+1,j-1
8106 cgrad        do ll=1,3
8107 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8108 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8109 cgrad        enddo
8110 cgrad      enddo
8111 cgrad      do m=k+1,l-1
8112 cgrad        do ll=1,3
8113 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8114 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8115 cgrad        enddo
8116 cgrad      enddo
8117 cgrad1112  continue
8118 cgrad      do m=i+2,j2
8119 cgrad        do ll=1,3
8120 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8121 cgrad        enddo
8122 cgrad      enddo
8123 cgrad      do m=k+2,l2
8124 cgrad        do ll=1,3
8125 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8126 cgrad        enddo
8127 cgrad      enddo
8128 cd      do iii=1,nres-3
8129 cd        write (2,*) iii,g_corr6_loc(iii)
8130 cd      enddo
8131       eello6=ekont*eel6
8132 cd      write (2,*) 'ekont',ekont
8133 cd      write (iout,*) 'eello6',ekont*eel6
8134       return
8135       end
8136 c--------------------------------------------------------------------------
8137       double precision function eello6_graph1(i,j,k,l,imat,swap)
8138       implicit real*8 (a-h,o-z)
8139       include 'DIMENSIONS'
8140       include 'COMMON.IOUNITS'
8141       include 'COMMON.CHAIN'
8142       include 'COMMON.DERIV'
8143       include 'COMMON.INTERACT'
8144       include 'COMMON.CONTACTS'
8145       include 'COMMON.TORSION'
8146       include 'COMMON.VAR'
8147       include 'COMMON.GEO'
8148       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8149       logical swap
8150       logical lprn
8151       common /kutas/ lprn
8152 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8153 C
8154 C      Parallel       Antiparallel
8155 C
8156 C          o             o
8157 C         /l\           /j\
8158 C        /   \         /   \
8159 C       /| o |         | o |\
8160 C     \ j|/k\|  /   \  |/k\|l /
8161 C      \ /   \ /     \ /   \ /
8162 C       o     o       o     o
8163 C       i             i
8164 C
8165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8166       itk=itortyp(itype(k))
8167       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8168       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8169       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8170       call transpose2(EUgC(1,1,k),auxmat(1,1))
8171       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8172       vv1(1)=pizda1(1,1)-pizda1(2,2)
8173       vv1(2)=pizda1(1,2)+pizda1(2,1)
8174       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8175       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8176       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8177       s5=scalar2(vv(1),Dtobr2(1,i))
8178 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8179       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8180       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8181      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8182      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8183      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8184      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8185      & +scalar2(vv(1),Dtobr2der(1,i)))
8186       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8187       vv1(1)=pizda1(1,1)-pizda1(2,2)
8188       vv1(2)=pizda1(1,2)+pizda1(2,1)
8189       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8190       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8191       if (l.eq.j+1) then
8192         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8193      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8194      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8195      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8196      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8197       else
8198         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8199      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8200      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8201      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8202      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8203       endif
8204       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8205       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8206       vv1(1)=pizda1(1,1)-pizda1(2,2)
8207       vv1(2)=pizda1(1,2)+pizda1(2,1)
8208       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8209      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8210      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8211      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8212       do iii=1,2
8213         if (swap) then
8214           ind=3-iii
8215         else
8216           ind=iii
8217         endif
8218         do kkk=1,5
8219           do lll=1,3
8220             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8221             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8222             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8223             call transpose2(EUgC(1,1,k),auxmat(1,1))
8224             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8225      &        pizda1(1,1))
8226             vv1(1)=pizda1(1,1)-pizda1(2,2)
8227             vv1(2)=pizda1(1,2)+pizda1(2,1)
8228             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8229             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8230      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8231             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8232      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8233             s5=scalar2(vv(1),Dtobr2(1,i))
8234             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8235           enddo
8236         enddo
8237       enddo
8238       return
8239       end
8240 c----------------------------------------------------------------------------
8241       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8242       implicit real*8 (a-h,o-z)
8243       include 'DIMENSIONS'
8244       include 'COMMON.IOUNITS'
8245       include 'COMMON.CHAIN'
8246       include 'COMMON.DERIV'
8247       include 'COMMON.INTERACT'
8248       include 'COMMON.CONTACTS'
8249       include 'COMMON.TORSION'
8250       include 'COMMON.VAR'
8251       include 'COMMON.GEO'
8252       logical swap
8253       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8254      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8255       logical lprn
8256       common /kutas/ lprn
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 C                                                                              C
8259 C      Parallel       Antiparallel                                             C
8260 C                                                                              C
8261 C          o             o                                                     C
8262 C     \   /l\           /j\   /                                                C
8263 C      \ /   \         /   \ /                                                 C
8264 C       o| o |         | o |o                                                  C
8265 C     \ j|/k\|      \  |/k\|l                                                  C
8266 C      \ /   \       \ /   \                                                   C
8267 C       o             o                                                        C
8268 C       i             i                                                        C
8269 C                                                                              C
8270 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8271 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8272 C AL 7/4/01 s1 would occur in the sixth-order moment,
8273 C           but not in a cluster cumulant
8274 #ifdef MOMENT
8275       s1=dip(1,jj,i)*dip(1,kk,k)
8276 #endif
8277       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8278       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8279       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8280       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8281       call transpose2(EUg(1,1,k),auxmat(1,1))
8282       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)-pizda(2,2)
8284       vv(2)=pizda(1,2)+pizda(2,1)
8285       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8286 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8287 #ifdef MOMENT
8288       eello6_graph2=-(s1+s2+s3+s4)
8289 #else
8290       eello6_graph2=-(s2+s3+s4)
8291 #endif
8292 c      eello6_graph2=-s3
8293 C Derivatives in gamma(i-1)
8294       if (i.gt.1) then
8295 #ifdef MOMENT
8296         s1=dipderg(1,jj,i)*dip(1,kk,k)
8297 #endif
8298         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8299         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8300         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8301         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8302 #ifdef MOMENT
8303         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8304 #else
8305         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8306 #endif
8307 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8308       endif
8309 C Derivatives in gamma(k-1)
8310 #ifdef MOMENT
8311       s1=dip(1,jj,i)*dipderg(1,kk,k)
8312 #endif
8313       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8314       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8316       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8317       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8318       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8319       vv(1)=pizda(1,1)-pizda(2,2)
8320       vv(2)=pizda(1,2)+pizda(2,1)
8321       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8322 #ifdef MOMENT
8323       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8324 #else
8325       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8326 #endif
8327 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8328 C Derivatives in gamma(j-1) or gamma(l-1)
8329       if (j.gt.1) then
8330 #ifdef MOMENT
8331         s1=dipderg(3,jj,i)*dip(1,kk,k)
8332 #endif
8333         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8334         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8335         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8336         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8337         vv(1)=pizda(1,1)-pizda(2,2)
8338         vv(2)=pizda(1,2)+pizda(2,1)
8339         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8340 #ifdef MOMENT
8341         if (swap) then
8342           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8343         else
8344           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8345         endif
8346 #endif
8347         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8348 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8349       endif
8350 C Derivatives in gamma(l-1) or gamma(j-1)
8351       if (l.gt.1) then
8352 #ifdef MOMENT
8353         s1=dip(1,jj,i)*dipderg(3,kk,k)
8354 #endif
8355         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8356         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8357         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8358         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8359         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8363 #ifdef MOMENT
8364         if (swap) then
8365           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8366         else
8367           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8368         endif
8369 #endif
8370         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8371 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8372       endif
8373 C Cartesian derivatives.
8374       if (lprn) then
8375         write (2,*) 'In eello6_graph2'
8376         do iii=1,2
8377           write (2,*) 'iii=',iii
8378           do kkk=1,5
8379             write (2,*) 'kkk=',kkk
8380             do jjj=1,2
8381               write (2,'(3(2f10.5),5x)')
8382      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8383             enddo
8384           enddo
8385         enddo
8386       endif
8387       do iii=1,2
8388         do kkk=1,5
8389           do lll=1,3
8390 #ifdef MOMENT
8391             if (iii.eq.1) then
8392               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8393             else
8394               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8395             endif
8396 #endif
8397             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8398      &        auxvec(1))
8399             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8400             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8401      &        auxvec(1))
8402             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8403             call transpose2(EUg(1,1,k),auxmat(1,1))
8404             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8405      &        pizda(1,1))
8406             vv(1)=pizda(1,1)-pizda(2,2)
8407             vv(2)=pizda(1,2)+pizda(2,1)
8408             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8409 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8410 #ifdef MOMENT
8411             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8412 #else
8413             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8414 #endif
8415             if (swap) then
8416               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8417             else
8418               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8419             endif
8420           enddo
8421         enddo
8422       enddo
8423       return
8424       end
8425 c----------------------------------------------------------------------------
8426       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8427       implicit real*8 (a-h,o-z)
8428       include 'DIMENSIONS'
8429       include 'COMMON.IOUNITS'
8430       include 'COMMON.CHAIN'
8431       include 'COMMON.DERIV'
8432       include 'COMMON.INTERACT'
8433       include 'COMMON.CONTACTS'
8434       include 'COMMON.TORSION'
8435       include 'COMMON.VAR'
8436       include 'COMMON.GEO'
8437       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8438       logical swap
8439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8440 C                                                                              C
8441 C      Parallel       Antiparallel                                             C
8442 C                                                                              C
8443 C          o             o                                                     C
8444 C         /l\   /   \   /j\                                                    C
8445 C        /   \ /     \ /   \                                                   C
8446 C       /| o |o       o| o |\                                                  C
8447 C       j|/k\|  /      |/k\|l /                                                C
8448 C        /   \ /       /   \ /                                                 C
8449 C       /     o       /     o                                                  C
8450 C       i             i                                                        C
8451 C                                                                              C
8452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8453 C
8454 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8455 C           energy moment and not to the cluster cumulant.
8456       iti=itortyp(itype(i))
8457       if (j.lt.nres-1) then
8458         itj1=itortyp(itype(j+1))
8459       else
8460         itj1=ntortyp+1
8461       endif
8462       itk=itortyp(itype(k))
8463       itk1=itortyp(itype(k+1))
8464       if (l.lt.nres-1) then
8465         itl1=itortyp(itype(l+1))
8466       else
8467         itl1=ntortyp+1
8468       endif
8469 #ifdef MOMENT
8470       s1=dip(4,jj,i)*dip(4,kk,k)
8471 #endif
8472       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8473       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8474       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8475       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8476       call transpose2(EE(1,1,itk),auxmat(1,1))
8477       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8478       vv(1)=pizda(1,1)+pizda(2,2)
8479       vv(2)=pizda(2,1)-pizda(1,2)
8480       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8481 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8482 cd     & "sum",-(s2+s3+s4)
8483 #ifdef MOMENT
8484       eello6_graph3=-(s1+s2+s3+s4)
8485 #else
8486       eello6_graph3=-(s2+s3+s4)
8487 #endif
8488 c      eello6_graph3=-s4
8489 C Derivatives in gamma(k-1)
8490       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8491       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8492       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8493       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8494 C Derivatives in gamma(l-1)
8495       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8496       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8497       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8498       vv(1)=pizda(1,1)+pizda(2,2)
8499       vv(2)=pizda(2,1)-pizda(1,2)
8500       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8501       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8502 C Cartesian derivatives.
8503       do iii=1,2
8504         do kkk=1,5
8505           do lll=1,3
8506 #ifdef MOMENT
8507             if (iii.eq.1) then
8508               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8509             else
8510               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8511             endif
8512 #endif
8513             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8514      &        auxvec(1))
8515             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8516             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8517      &        auxvec(1))
8518             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8519             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8520      &        pizda(1,1))
8521             vv(1)=pizda(1,1)+pizda(2,2)
8522             vv(2)=pizda(2,1)-pizda(1,2)
8523             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8524 #ifdef MOMENT
8525             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8526 #else
8527             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8528 #endif
8529             if (swap) then
8530               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8531             else
8532               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8533             endif
8534 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8535           enddo
8536         enddo
8537       enddo
8538       return
8539       end
8540 c----------------------------------------------------------------------------
8541       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8542       implicit real*8 (a-h,o-z)
8543       include 'DIMENSIONS'
8544       include 'COMMON.IOUNITS'
8545       include 'COMMON.CHAIN'
8546       include 'COMMON.DERIV'
8547       include 'COMMON.INTERACT'
8548       include 'COMMON.CONTACTS'
8549       include 'COMMON.TORSION'
8550       include 'COMMON.VAR'
8551       include 'COMMON.GEO'
8552       include 'COMMON.FFIELD'
8553       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8554      & auxvec1(2),auxmat1(2,2)
8555       logical swap
8556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8557 C                                                                              C
8558 C      Parallel       Antiparallel                                             C
8559 C                                                                              C
8560 C          o             o                                                     C
8561 C         /l\   /   \   /j\                                                    C
8562 C        /   \ /     \ /   \                                                   C
8563 C       /| o |o       o| o |\                                                  C
8564 C     \ j|/k\|      \  |/k\|l                                                  C
8565 C      \ /   \       \ /   \                                                   C
8566 C       o     \       o     \                                                  C
8567 C       i             i                                                        C
8568 C                                                                              C
8569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8570 C
8571 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8572 C           energy moment and not to the cluster cumulant.
8573 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8574       iti=itortyp(itype(i))
8575       itj=itortyp(itype(j))
8576       if (j.lt.nres-1) then
8577         itj1=itortyp(itype(j+1))
8578       else
8579         itj1=ntortyp+1
8580       endif
8581       itk=itortyp(itype(k))
8582       if (k.lt.nres-1) then
8583         itk1=itortyp(itype(k+1))
8584       else
8585         itk1=ntortyp+1
8586       endif
8587       itl=itortyp(itype(l))
8588       if (l.lt.nres-1) then
8589         itl1=itortyp(itype(l+1))
8590       else
8591         itl1=ntortyp+1
8592       endif
8593 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8594 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8595 cd     & ' itl',itl,' itl1',itl1
8596 #ifdef MOMENT
8597       if (imat.eq.1) then
8598         s1=dip(3,jj,i)*dip(3,kk,k)
8599       else
8600         s1=dip(2,jj,j)*dip(2,kk,l)
8601       endif
8602 #endif
8603       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8604       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8605       if (j.eq.l+1) then
8606         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8607         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8608       else
8609         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8610         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8611       endif
8612       call transpose2(EUg(1,1,k),auxmat(1,1))
8613       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8614       vv(1)=pizda(1,1)-pizda(2,2)
8615       vv(2)=pizda(2,1)+pizda(1,2)
8616       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8617 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8618 #ifdef MOMENT
8619       eello6_graph4=-(s1+s2+s3+s4)
8620 #else
8621       eello6_graph4=-(s2+s3+s4)
8622 #endif
8623 C Derivatives in gamma(i-1)
8624       if (i.gt.1) then
8625 #ifdef MOMENT
8626         if (imat.eq.1) then
8627           s1=dipderg(2,jj,i)*dip(3,kk,k)
8628         else
8629           s1=dipderg(4,jj,j)*dip(2,kk,l)
8630         endif
8631 #endif
8632         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8633         if (j.eq.l+1) then
8634           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8635           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8636         else
8637           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8638           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8639         endif
8640         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8641         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8642 cd          write (2,*) 'turn6 derivatives'
8643 #ifdef MOMENT
8644           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8647 #endif
8648         else
8649 #ifdef MOMENT
8650           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8651 #else
8652           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8653 #endif
8654         endif
8655       endif
8656 C Derivatives in gamma(k-1)
8657 #ifdef MOMENT
8658       if (imat.eq.1) then
8659         s1=dip(3,jj,i)*dipderg(2,kk,k)
8660       else
8661         s1=dip(2,jj,j)*dipderg(4,kk,l)
8662       endif
8663 #endif
8664       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8665       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8666       if (j.eq.l+1) then
8667         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8668         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8669       else
8670         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8671         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8672       endif
8673       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8674       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8675       vv(1)=pizda(1,1)-pizda(2,2)
8676       vv(2)=pizda(2,1)+pizda(1,2)
8677       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8678       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8679 #ifdef MOMENT
8680         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8681 #else
8682         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8683 #endif
8684       else
8685 #ifdef MOMENT
8686         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8687 #else
8688         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8689 #endif
8690       endif
8691 C Derivatives in gamma(j-1) or gamma(l-1)
8692       if (l.eq.j+1 .and. l.gt.1) then
8693         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8694         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8695         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8696         vv(1)=pizda(1,1)-pizda(2,2)
8697         vv(2)=pizda(2,1)+pizda(1,2)
8698         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8699         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8700       else if (j.gt.1) then
8701         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8702         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8703         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8704         vv(1)=pizda(1,1)-pizda(2,2)
8705         vv(2)=pizda(2,1)+pizda(1,2)
8706         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8707         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8708           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8709         else
8710           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8711         endif
8712       endif
8713 C Cartesian derivatives.
8714       do iii=1,2
8715         do kkk=1,5
8716           do lll=1,3
8717 #ifdef MOMENT
8718             if (iii.eq.1) then
8719               if (imat.eq.1) then
8720                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8721               else
8722                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8723               endif
8724             else
8725               if (imat.eq.1) then
8726                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8727               else
8728                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8729               endif
8730             endif
8731 #endif
8732             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8733      &        auxvec(1))
8734             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8735             if (j.eq.l+1) then
8736               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8737      &          b1(1,itj1),auxvec(1))
8738               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8739             else
8740               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8741      &          b1(1,itl1),auxvec(1))
8742               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8743             endif
8744             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8745      &        pizda(1,1))
8746             vv(1)=pizda(1,1)-pizda(2,2)
8747             vv(2)=pizda(2,1)+pizda(1,2)
8748             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8749             if (swap) then
8750               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8751 #ifdef MOMENT
8752                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8753      &             -(s1+s2+s4)
8754 #else
8755                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8756      &             -(s2+s4)
8757 #endif
8758                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8759               else
8760 #ifdef MOMENT
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8762 #else
8763                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8764 #endif
8765                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8766               endif
8767             else
8768 #ifdef MOMENT
8769               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8770 #else
8771               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8772 #endif
8773               if (l.eq.j+1) then
8774                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8775               else
8776                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8777               endif
8778             endif
8779           enddo
8780         enddo
8781       enddo
8782       return
8783       end
8784 c----------------------------------------------------------------------------
8785       double precision function eello_turn6(i,jj,kk)
8786       implicit real*8 (a-h,o-z)
8787       include 'DIMENSIONS'
8788       include 'COMMON.IOUNITS'
8789       include 'COMMON.CHAIN'
8790       include 'COMMON.DERIV'
8791       include 'COMMON.INTERACT'
8792       include 'COMMON.CONTACTS'
8793       include 'COMMON.TORSION'
8794       include 'COMMON.VAR'
8795       include 'COMMON.GEO'
8796       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8797      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8798      &  ggg1(3),ggg2(3)
8799       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8800      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8801 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8802 C           the respective energy moment and not to the cluster cumulant.
8803       s1=0.0d0
8804       s8=0.0d0
8805       s13=0.0d0
8806 c
8807       eello_turn6=0.0d0
8808       j=i+4
8809       k=i+1
8810       l=i+3
8811       iti=itortyp(itype(i))
8812       itk=itortyp(itype(k))
8813       itk1=itortyp(itype(k+1))
8814       itl=itortyp(itype(l))
8815       itj=itortyp(itype(j))
8816 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8817 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8818 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8819 cd        eello6=0.0d0
8820 cd        return
8821 cd      endif
8822 cd      write (iout,*)
8823 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8824 cd     &   ' and',k,l
8825 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8826       do iii=1,2
8827         do kkk=1,5
8828           do lll=1,3
8829             derx_turn(lll,kkk,iii)=0.0d0
8830           enddo
8831         enddo
8832       enddo
8833 cd      eij=1.0d0
8834 cd      ekl=1.0d0
8835 cd      ekont=1.0d0
8836       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8837 cd      eello6_5=0.0d0
8838 cd      write (2,*) 'eello6_5',eello6_5
8839 #ifdef MOMENT
8840       call transpose2(AEA(1,1,1),auxmat(1,1))
8841       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8842       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8843       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8844 #endif
8845       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8846       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8847       s2 = scalar2(b1(1,itk),vtemp1(1))
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,2),atemp(1,1))
8850       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8851       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8852       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8853 #endif
8854       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8855       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8856       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8857 #ifdef MOMENT
8858       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8859       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8860       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8861       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8862       ss13 = scalar2(b1(1,itk),vtemp4(1))
8863       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8864 #endif
8865 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8866 c      s1=0.0d0
8867 c      s2=0.0d0
8868 c      s8=0.0d0
8869 c      s12=0.0d0
8870 c      s13=0.0d0
8871       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8872 C Derivatives in gamma(i+2)
8873       s1d =0.0d0
8874       s8d =0.0d0
8875 #ifdef MOMENT
8876       call transpose2(AEA(1,1,1),auxmatd(1,1))
8877       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8878       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8879       call transpose2(AEAderg(1,1,2),atempd(1,1))
8880       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8881       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8882 #endif
8883       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8884       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8885       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8886 c      s1d=0.0d0
8887 c      s2d=0.0d0
8888 c      s8d=0.0d0
8889 c      s12d=0.0d0
8890 c      s13d=0.0d0
8891       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8892 C Derivatives in gamma(i+3)
8893 #ifdef MOMENT
8894       call transpose2(AEA(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8897       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8898 #endif
8899       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8900       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8901       s2d = scalar2(b1(1,itk),vtemp1d(1))
8902 #ifdef MOMENT
8903       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8904       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8905 #endif
8906       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8907 #ifdef MOMENT
8908       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8909       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8910       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8911 #endif
8912 c      s1d=0.0d0
8913 c      s2d=0.0d0
8914 c      s8d=0.0d0
8915 c      s12d=0.0d0
8916 c      s13d=0.0d0
8917 #ifdef MOMENT
8918       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8919      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8920 #else
8921       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8922      &               -0.5d0*ekont*(s2d+s12d)
8923 #endif
8924 C Derivatives in gamma(i+4)
8925       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8926       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8927       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8928 #ifdef MOMENT
8929       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8930       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8931       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8932 #endif
8933 c      s1d=0.0d0
8934 c      s2d=0.0d0
8935 c      s8d=0.0d0
8936 C      s12d=0.0d0
8937 c      s13d=0.0d0
8938 #ifdef MOMENT
8939       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8940 #else
8941       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8942 #endif
8943 C Derivatives in gamma(i+5)
8944 #ifdef MOMENT
8945       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8946       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8947       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8948 #endif
8949       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8950       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8951       s2d = scalar2(b1(1,itk),vtemp1d(1))
8952 #ifdef MOMENT
8953       call transpose2(AEA(1,1,2),atempd(1,1))
8954       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8955       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8956 #endif
8957       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8958       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8959 #ifdef MOMENT
8960       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8961       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8962       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8963 #endif
8964 c      s1d=0.0d0
8965 c      s2d=0.0d0
8966 c      s8d=0.0d0
8967 c      s12d=0.0d0
8968 c      s13d=0.0d0
8969 #ifdef MOMENT
8970       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8971      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8972 #else
8973       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8974      &               -0.5d0*ekont*(s2d+s12d)
8975 #endif
8976 C Cartesian derivatives
8977       do iii=1,2
8978         do kkk=1,5
8979           do lll=1,3
8980 #ifdef MOMENT
8981             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8982             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8983             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8984 #endif
8985             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8986             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8987      &          vtemp1d(1))
8988             s2d = scalar2(b1(1,itk),vtemp1d(1))
8989 #ifdef MOMENT
8990             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8991             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8992             s8d = -(atempd(1,1)+atempd(2,2))*
8993      &           scalar2(cc(1,1,itl),vtemp2(1))
8994 #endif
8995             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8996      &           auxmatd(1,1))
8997             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8998             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8999 c      s1d=0.0d0
9000 c      s2d=0.0d0
9001 c      s8d=0.0d0
9002 c      s12d=0.0d0
9003 c      s13d=0.0d0
9004 #ifdef MOMENT
9005             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9006      &        - 0.5d0*(s1d+s2d)
9007 #else
9008             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9009      &        - 0.5d0*s2d
9010 #endif
9011 #ifdef MOMENT
9012             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9013      &        - 0.5d0*(s8d+s12d)
9014 #else
9015             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9016      &        - 0.5d0*s12d
9017 #endif
9018           enddo
9019         enddo
9020       enddo
9021 #ifdef MOMENT
9022       do kkk=1,5
9023         do lll=1,3
9024           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9025      &      achuj_tempd(1,1))
9026           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9027           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9028           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9029           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9030           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9031      &      vtemp4d(1))
9032           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9033           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9034           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9035         enddo
9036       enddo
9037 #endif
9038 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9039 cd     &  16*eel_turn6_num
9040 cd      goto 1112
9041       if (j.lt.nres-1) then
9042         j1=j+1
9043         j2=j-1
9044       else
9045         j1=j-1
9046         j2=j-2
9047       endif
9048       if (l.lt.nres-1) then
9049         l1=l+1
9050         l2=l-1
9051       else
9052         l1=l-1
9053         l2=l-2
9054       endif
9055       do ll=1,3
9056 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9057 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9058 cgrad        ghalf=0.5d0*ggg1(ll)
9059 cd        ghalf=0.0d0
9060         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9061         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9062         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9063      &    +ekont*derx_turn(ll,2,1)
9064         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9065         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9066      &    +ekont*derx_turn(ll,4,1)
9067         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9068         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9069         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9070 cgrad        ghalf=0.5d0*ggg2(ll)
9071 cd        ghalf=0.0d0
9072         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9073      &    +ekont*derx_turn(ll,2,2)
9074         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9075         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9076      &    +ekont*derx_turn(ll,4,2)
9077         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9078         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9079         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9080       enddo
9081 cd      goto 1112
9082 cgrad      do m=i+1,j-1
9083 cgrad        do ll=1,3
9084 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9085 cgrad        enddo
9086 cgrad      enddo
9087 cgrad      do m=k+1,l-1
9088 cgrad        do ll=1,3
9089 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9090 cgrad        enddo
9091 cgrad      enddo
9092 cgrad1112  continue
9093 cgrad      do m=i+2,j2
9094 cgrad        do ll=1,3
9095 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9096 cgrad        enddo
9097 cgrad      enddo
9098 cgrad      do m=k+2,l2
9099 cgrad        do ll=1,3
9100 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9101 cgrad        enddo
9102 cgrad      enddo
9103 cd      do iii=1,nres-3
9104 cd        write (2,*) iii,g_corr6_loc(iii)
9105 cd      enddo
9106       eello_turn6=ekont*eel_turn6
9107 cd      write (2,*) 'ekont',ekont
9108 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9109       return
9110       end
9111
9112 C-----------------------------------------------------------------------------
9113       double precision function scalar(u,v)
9114 !DIR$ INLINEALWAYS scalar
9115 #ifndef OSF
9116 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9117 #endif
9118       implicit none
9119       double precision u(3),v(3)
9120 cd      double precision sc
9121 cd      integer i
9122 cd      sc=0.0d0
9123 cd      do i=1,3
9124 cd        sc=sc+u(i)*v(i)
9125 cd      enddo
9126 cd      scalar=sc
9127
9128       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9129       return
9130       end
9131 crc-------------------------------------------------
9132       SUBROUTINE MATVEC2(A1,V1,V2)
9133 !DIR$ INLINEALWAYS MATVEC2
9134 #ifndef OSF
9135 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9136 #endif
9137       implicit real*8 (a-h,o-z)
9138       include 'DIMENSIONS'
9139       DIMENSION A1(2,2),V1(2),V2(2)
9140 c      DO 1 I=1,2
9141 c        VI=0.0
9142 c        DO 3 K=1,2
9143 c    3     VI=VI+A1(I,K)*V1(K)
9144 c        Vaux(I)=VI
9145 c    1 CONTINUE
9146
9147       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9148       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9149
9150       v2(1)=vaux1
9151       v2(2)=vaux2
9152       END
9153 C---------------------------------------
9154       SUBROUTINE MATMAT2(A1,A2,A3)
9155 #ifndef OSF
9156 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9157 #endif
9158       implicit real*8 (a-h,o-z)
9159       include 'DIMENSIONS'
9160       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9161 c      DIMENSION AI3(2,2)
9162 c        DO  J=1,2
9163 c          A3IJ=0.0
9164 c          DO K=1,2
9165 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9166 c          enddo
9167 c          A3(I,J)=A3IJ
9168 c       enddo
9169 c      enddo
9170
9171       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9172       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9173       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9174       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9175
9176       A3(1,1)=AI3_11
9177       A3(2,1)=AI3_21
9178       A3(1,2)=AI3_12
9179       A3(2,2)=AI3_22
9180       END
9181
9182 c-------------------------------------------------------------------------
9183       double precision function scalar2(u,v)
9184 !DIR$ INLINEALWAYS scalar2
9185       implicit none
9186       double precision u(2),v(2)
9187       double precision sc
9188       integer i
9189       scalar2=u(1)*v(1)+u(2)*v(2)
9190       return
9191       end
9192
9193 C-----------------------------------------------------------------------------
9194
9195       subroutine transpose2(a,at)
9196 !DIR$ INLINEALWAYS transpose2
9197 #ifndef OSF
9198 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9199 #endif
9200       implicit none
9201       double precision a(2,2),at(2,2)
9202       at(1,1)=a(1,1)
9203       at(1,2)=a(2,1)
9204       at(2,1)=a(1,2)
9205       at(2,2)=a(2,2)
9206       return
9207       end
9208 c--------------------------------------------------------------------------
9209       subroutine transpose(n,a,at)
9210       implicit none
9211       integer n,i,j
9212       double precision a(n,n),at(n,n)
9213       do i=1,n
9214         do j=1,n
9215           at(j,i)=a(i,j)
9216         enddo
9217       enddo
9218       return
9219       end
9220 C---------------------------------------------------------------------------
9221       subroutine prodmat3(a1,a2,kk,transp,prod)
9222 !DIR$ INLINEALWAYS prodmat3
9223 #ifndef OSF
9224 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9225 #endif
9226       implicit none
9227       integer i,j
9228       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9229       logical transp
9230 crc      double precision auxmat(2,2),prod_(2,2)
9231
9232       if (transp) then
9233 crc        call transpose2(kk(1,1),auxmat(1,1))
9234 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9235 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9236
9237            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9238      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9239            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9240      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9241            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9242      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9243            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9244      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9245
9246       else
9247 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9248 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9249
9250            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9251      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9252            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9253      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9254            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9255      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9256            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9257      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9258
9259       endif
9260 c      call transpose2(a2(1,1),a2t(1,1))
9261
9262 crc      print *,transp
9263 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9264 crc      print *,((prod(i,j),i=1,2),j=1,2)
9265
9266       return
9267       end
9268