source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137 c      if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334       if (dyn_ss) call dyn_set_nss
 335 c      print *," Processor",myrank," left SUM_ENERGY"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time_sumene=time_sumene+MPI_Wtime()-time00
 339 #else
 340       time_sumene=time_sumene+tcpu()-time00
 341 #endif
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395 #ifdef TSCSC
 396       evdw=energia(22)+wsct*energia(23)
 397 #else
 398       evdw=energia(1)
 399 #endif
 400 #ifdef SCP14
 401       evdw2=energia(2)+energia(18)
 402       evdw2_14=energia(18)
 403 #else
 404       evdw2=energia(2)
 405 #endif
 406 #ifdef SPLITELE
 407       ees=energia(3)
 408       evdw1=energia(16)
 409 #else
 410       ees=energia(3)
 411       evdw1=0.0d0
 412 #endif
 413       ecorr=energia(4)
 414       ecorr5=energia(5)
 415       ecorr6=energia(6)
 416       eel_loc=energia(7)
 417       eello_turn3=energia(8)
 418       eello_turn4=energia(9)
 419       eturn6=energia(10)
 420       ebe=energia(11)
 421       escloc=energia(12)
 422       etors=energia(13)
 423       etors_d=energia(14)
 424       ehpb=energia(15)
 425       edihcnstr=energia(19)
 426       estr=energia(17)
 427       Uconst=energia(20)
 428       esccor=energia(21)
 429 #ifdef SPLITELE
 430       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 431      & +wang*ebe+wtor*etors+wscloc*escloc
 432      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 433      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 434      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 435      & +wbond*estr+Uconst+wsccor*esccor
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor
 443 #endif
 444       energia(0)=etot
 445 c detecting NaNQ
 446 #ifdef ISNAN
 447 #ifdef AIX
 448       if (isnan(etot).ne.0) energia(0)=1.0d+99
 449 #else
 450       if (isnan(etot)) energia(0)=1.0d+99
 451 #endif
 452 #else
 453       i=0
 454 #ifdef WINPGI
 455       idumm=proc_proc(etot,i)
 456 #else
 457       call proc_proc(etot,i)
 458 #endif
 459       if(i.eq.1)energia(0)=1.0d+99
 460 #endif
 461 #ifdef MPI
 462       endif
 463 #endif
 464       return
 465       end
 466 c-------------------------------------------------------------------------------
 467       subroutine sum_gradient
 468       implicit real*8 (a-h,o-z)
 469       include 'DIMENSIONS'
 470 #ifndef ISNAN
 471       external proc_proc
 472 #ifdef WINPGI
 473 cMS$ATTRIBUTES C ::  proc_proc
 474 #endif
 475 #endif
 476 #ifdef MPI
 477       include 'mpif.h'
 478 #endif
 479       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 480      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 481       include 'COMMON.SETUP'
 482       include 'COMMON.IOUNITS'
 483       include 'COMMON.FFIELD'
 484       include 'COMMON.DERIV'
 485       include 'COMMON.INTERACT'
 486       include 'COMMON.SBRIDGE'
 487       include 'COMMON.CHAIN'
 488       include 'COMMON.VAR'
 489       include 'COMMON.CONTROL'
 490       include 'COMMON.TIME1'
 491       include 'COMMON.MAXGRAD'
 492       include 'COMMON.SCCOR'
 493 #ifdef TIMING
 494 #ifdef MPI
 495       time01=MPI_Wtime()
 496 #else
 497       time01=tcpu()
 498 #endif
 499 #endif
 500 #ifdef DEBUG
 501       write (iout,*) "sum_gradient gvdwc, gvdwx"
 502       do i=1,nres
 503         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 504      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 505      &   (gvdwcT(j,i),j=1,3)
 506       enddo
 507       call flush(iout)
 508 #endif
 509 #ifdef MPI
 510 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 511         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 512      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 513 #endif
 514 C
 515 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 516 C            in virtual-bond-vector coordinates
 517 C
 518 #ifdef DEBUG
 519 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 520 c      do i=1,nres-1
 521 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 522 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 523 c      enddo
 524 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 525 c      do i=1,nres-1
 526 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 527 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 528 c      enddo
 529       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 530       do i=1,nres
 531         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 532      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 533      &   g_corr5_loc(i)
 534       enddo
 535       call flush(iout)
 536 #endif
 537 #ifdef SPLITELE
 538 #ifdef TSCSC
 539       do i=1,nct
 540         do j=1,3
 541           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 542      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 543      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 544      &                wel_loc*gel_loc_long(j,i)+
 545      &                wcorr*gradcorr_long(j,i)+
 546      &                wcorr5*gradcorr5_long(j,i)+
 547      &                wcorr6*gradcorr6_long(j,i)+
 548      &                wturn6*gcorr6_turn_long(j,i)+
 549      &                wstrain*ghpbc(j,i)
 550         enddo
 551       enddo
 552 #else
 553       do i=1,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564         enddo
 565       enddo
 566 #endif
 567 #else
 568       do i=1,nct
 569         do j=1,3
 570           gradbufc(j,i)=wsc*gvdwc(j,i)+
 571      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 572      &                welec*gelc_long(j,i)+
 573      &                wbond*gradb(j,i)+
 574      &                wel_loc*gel_loc_long(j,i)+
 575      &                wcorr*gradcorr_long(j,i)+
 576      &                wcorr5*gradcorr5_long(j,i)+
 577      &                wcorr6*gradcorr6_long(j,i)+
 578      &                wturn6*gcorr6_turn_long(j,i)+
 579      &                wstrain*ghpbc(j,i)
 580         enddo
 581       enddo
 582 #endif
 583 #ifdef MPI
 584       if (nfgtasks.gt.1) then
 585       time00=MPI_Wtime()
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc before allreduce"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       do i=1,nres
 594         do j=1,3
 595           gradbufc_sum(j,i)=gradbufc(j,i)
 596         enddo
 597       enddo
 598 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 599 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 600 c      time_reduce=time_reduce+MPI_Wtime()-time00
 601 #ifdef DEBUG
 602 c      write (iout,*) "gradbufc_sum after allreduce"
 603 c      do i=1,nres
 604 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 605 c      enddo
 606 c      call flush(iout)
 607 #endif
 608 #ifdef TIMING
 609 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 610 #endif
 611       do i=nnt,nres
 612         do k=1,3
 613           gradbufc(k,i)=0.0d0
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 618       write (iout,*) (i," jgrad_start",jgrad_start(i),
 619      &                  " jgrad_end  ",jgrad_end(i),
 620      &                  i=igrad_start,igrad_end)
 621 #endif
 622 c
 623 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 624 c do not parallelize this part.
 625 c
 626 c      do i=igrad_start,igrad_end
 627 c        do j=jgrad_start(i),jgrad_end(i)
 628 c          do k=1,3
 629 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 630 c          enddo
 631 c        enddo
 632 c      enddo
 633       do j=1,3
 634         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 635       enddo
 636       do i=nres-2,nnt,-1
 637         do j=1,3
 638           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 639         enddo
 640       enddo
 641 #ifdef DEBUG
 642       write (iout,*) "gradbufc after summing"
 643       do i=1,nres
 644         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 645       enddo
 646       call flush(iout)
 647 #endif
 648       else
 649 #endif
 650 #ifdef DEBUG
 651       write (iout,*) "gradbufc"
 652       do i=1,nres
 653         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 654       enddo
 655       call flush(iout)
 656 #endif
 657       do i=1,nres
 658         do j=1,3
 659           gradbufc_sum(j,i)=gradbufc(j,i)
 660           gradbufc(j,i)=0.0d0
 661         enddo
 662       enddo
 663       do j=1,3
 664         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 665       enddo
 666       do i=nres-2,nnt,-1
 667         do j=1,3
 668           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 669         enddo
 670       enddo
 671 c      do i=nnt,nres-1
 672 c        do k=1,3
 673 c          gradbufc(k,i)=0.0d0
 674 c        enddo
 675 c        do j=i+1,nres
 676 c          do k=1,3
 677 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 678 c          enddo
 679 c        enddo
 680 c      enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gradbufc after summing"
 683       do i=1,nres
 684         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 685       enddo
 686       call flush(iout)
 687 #endif
 688 #ifdef MPI
 689       endif
 690 #endif
 691       do k=1,3
 692         gradbufc(k,nres)=0.0d0
 693       enddo
 694       do i=1,nct
 695         do j=1,3
 696 #ifdef SPLITELE
 697           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 698      &                wel_loc*gel_loc(j,i)+
 699      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 700      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 701      &                wel_loc*gel_loc_long(j,i)+
 702      &                wcorr*gradcorr_long(j,i)+
 703      &                wcorr5*gradcorr5_long(j,i)+
 704      &                wcorr6*gradcorr6_long(j,i)+
 705      &                wturn6*gcorr6_turn_long(j,i))+
 706      &                wbond*gradb(j,i)+
 707      &                wcorr*gradcorr(j,i)+
 708      &                wturn3*gcorr3_turn(j,i)+
 709      &                wturn4*gcorr4_turn(j,i)+
 710      &                wcorr5*gradcorr5(j,i)+
 711      &                wcorr6*gradcorr6(j,i)+
 712      &                wturn6*gcorr6_turn(j,i)+
 713      &                wsccor*gsccorc(j,i)
 714      &               +wscloc*gscloc(j,i)
 715 #else
 716           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 717      &                wel_loc*gel_loc(j,i)+
 718      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 719      &                welec*gelc_long(j,i)+
 720      &                wel_loc*gel_loc_long(j,i)+
 721      &                wcorr*gcorr_long(j,i)+
 722      &                wcorr5*gradcorr5_long(j,i)+
 723      &                wcorr6*gradcorr6_long(j,i)+
 724      &                wturn6*gcorr6_turn_long(j,i))+
 725      &                wbond*gradb(j,i)+
 726      &                wcorr*gradcorr(j,i)+
 727      &                wturn3*gcorr3_turn(j,i)+
 728      &                wturn4*gcorr4_turn(j,i)+
 729      &                wcorr5*gradcorr5(j,i)+
 730      &                wcorr6*gradcorr6(j,i)+
 731      &                wturn6*gcorr6_turn(j,i)+
 732      &                wsccor*gsccorc(j,i)
 733      &               +wscloc*gscloc(j,i)
 734 #endif
 735 #ifdef TSCSC
 736           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 737      &                  wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #else
 743           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 744      &                  wbond*gradbx(j,i)+
 745      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 746      &                  wsccor*gsccorx(j,i)
 747      &                 +wscloc*gsclocx(j,i)
 748 #endif
 749         enddo
 750       enddo
 751 #ifdef DEBUG
 752       write (iout,*) "gloc before adding corr"
 753       do i=1,4*nres
 754         write (iout,*) i,gloc(i,icg)
 755       enddo
 756 #endif
 757       do i=1,nres-3
 758         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 759      &   +wcorr5*g_corr5_loc(i)
 760      &   +wcorr6*g_corr6_loc(i)
 761      &   +wturn4*gel_loc_turn4(i)
 762      &   +wturn3*gel_loc_turn3(i)
 763      &   +wturn6*gel_loc_turn6(i)
 764      &   +wel_loc*gel_loc_loc(i)
 765       enddo
 766 #ifdef DEBUG
 767       write (iout,*) "gloc after adding corr"
 768       do i=1,4*nres
 769         write (iout,*) i,gloc(i,icg)
 770       enddo
 771 #endif
 772 #ifdef MPI
 773       if (nfgtasks.gt.1) then
 774         do j=1,3
 775           do i=1,nres
 776             gradbufc(j,i)=gradc(j,i,icg)
 777             gradbufx(j,i)=gradx(j,i,icg)
 778           enddo
 779         enddo
 780         do i=1,4*nres
 781           glocbuf(i)=gloc(i,icg)
 782         enddo
 783 #ifdef DEBUG
 784       write (iout,*) "gloc_sc before reduce"
 785       do i=1,nres
 786        do j=1,3
 787         write (iout,*) i,j,gloc_sc(j,i,icg)
 788        enddo
 789       enddo
 790 #endif
 791         do i=1,nres
 792          do j=1,3
 793           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 794          enddo
 795         enddo
 796         time00=MPI_Wtime()
 797         call MPI_Barrier(FG_COMM,IERR)
 798         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 799         time00=MPI_Wtime()
 800         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 #ifdef DEBUG
 810       write (iout,*) "gloc_sc after reduce"
 811       do i=1,nres
 812        do j=1,3
 813         write (iout,*) i,j,gloc_sc(j,i,icg)
 814        enddo
 815       enddo
 816 #endif
 817 #ifdef DEBUG
 818       write (iout,*) "gloc after reduce"
 819       do i=1,4*nres
 820         write (iout,*) i,gloc(i,icg)
 821       enddo
 822 #endif
 823       endif
 824 #endif
 825       if (gnorm_check) then
 826 c
 827 c Compute the maximum elements of the gradient
 828 c
 829       gvdwc_max=0.0d0
 830       gvdwc_scp_max=0.0d0
 831       gelc_max=0.0d0
 832       gvdwpp_max=0.0d0
 833       gradb_max=0.0d0
 834       ghpbc_max=0.0d0
 835       gradcorr_max=0.0d0
 836       gel_loc_max=0.0d0
 837       gcorr3_turn_max=0.0d0
 838       gcorr4_turn_max=0.0d0
 839       gradcorr5_max=0.0d0
 840       gradcorr6_max=0.0d0
 841       gcorr6_turn_max=0.0d0
 842       gsccorc_max=0.0d0
 843       gscloc_max=0.0d0
 844       gvdwx_max=0.0d0
 845       gradx_scp_max=0.0d0
 846       ghpbx_max=0.0d0
 847       gradxorr_max=0.0d0
 848       gsccorx_max=0.0d0
 849       gsclocx_max=0.0d0
 850       do i=1,nct
 851         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 852         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 853 #ifdef TSCSC
 854         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 855         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 856 #endif
 857         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 858         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 859      &   gvdwc_scp_max=gvdwc_scp_norm
 860         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 861         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 862         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 863         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 864         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 865         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 866         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 867         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 868         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 869         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 870         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 871         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 872         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 873      &    gcorr3_turn(1,i)))
 874         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 875      &    gcorr3_turn_max=gcorr3_turn_norm
 876         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 877      &    gcorr4_turn(1,i)))
 878         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 879      &    gcorr4_turn_max=gcorr4_turn_norm
 880         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 881         if (gradcorr5_norm.gt.gradcorr5_max)
 882      &    gradcorr5_max=gradcorr5_norm
 883         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 884         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 885         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 886      &    gcorr6_turn(1,i)))
 887         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 888      &    gcorr6_turn_max=gcorr6_turn_norm
 889         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 890         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 891         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 892         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 893         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 894         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 895 #ifdef TSCSC
 896         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898 #endif
 899         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 900         if (gradx_scp_norm.gt.gradx_scp_max)
 901      &    gradx_scp_max=gradx_scp_norm
 902         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 903         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 904         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 905         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 906         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 907         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 908         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 909         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 910       enddo
 911       if (gradout) then
 912 #ifdef AIX
 913         open(istat,file=statname,position="append")
 914 #else
 915         open(istat,file=statname,access="append")
 916 #endif
 917         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 918      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 919      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 920      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 921      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 922      &     gsccorx_max,gsclocx_max
 923         close(istat)
 924         if (gvdwc_max.gt.1.0d4) then
 925           write (iout,*) "gvdwc gvdwx gradb gradbx"
 926           do i=nnt,nct
 927             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 928      &        gradb(j,i),gradbx(j,i),j=1,3)
 929           enddo
 930           call pdbout(0.0d0,'cipiszcze',iout)
 931           call flush(iout)
 932         endif
 933       endif
 934       endif
 935 #ifdef DEBUG
 936       write (iout,*) "gradc gradx gloc"
 937       do i=1,nres
 938         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 939      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 940       enddo
 941 #endif
 942 #ifdef TIMING
 943 #ifdef MPI
 944       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 945 #else
 946       time_sumgradient=time_sumgradient+tcpu()-time01
 947 #endif
 948 #endif
 949       return
 950       end
 951 c-------------------------------------------------------------------------------
 952       subroutine rescale_weights(t_bath)
 953       implicit real*8 (a-h,o-z)
 954       include 'DIMENSIONS'
 955       include 'COMMON.IOUNITS'
 956       include 'COMMON.FFIELD'
 957       include 'COMMON.SBRIDGE'
 958       double precision kfac /2.4d0/
 959       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 960 c      facT=temp0/t_bath
 961 c      facT=2*temp0/(t_bath+temp0)
 962       if (rescale_mode.eq.0) then
 963         facT=1.0d0
 964         facT2=1.0d0
 965         facT3=1.0d0
 966         facT4=1.0d0
 967         facT5=1.0d0
 968       else if (rescale_mode.eq.1) then
 969         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 970         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 971         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 972         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 973         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 974       else if (rescale_mode.eq.2) then
 975         x=t_bath/temp0
 976         x2=x*x
 977         x3=x2*x
 978         x4=x3*x
 979         x5=x4*x
 980         facT=licznik/dlog(dexp(x)+dexp(-x))
 981         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 982         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 983         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 984         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 985       else
 986         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 987         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 988 #ifdef MPI
 989        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 990 #endif
 991        stop 555
 992       endif
 993       welec=weights(3)*fact
 994       wcorr=weights(4)*fact3
 995       wcorr5=weights(5)*fact4
 996       wcorr6=weights(6)*fact5
 997       wel_loc=weights(7)*fact2
 998       wturn3=weights(8)*fact2
 999       wturn4=weights(9)*fact3
1000       wturn6=weights(10)*fact5
1001       wtor=weights(13)*fact
1002       wtor_d=weights(14)*fact2
1003       wsccor=weights(21)*fact
1004 #ifdef TSCSC
1005 c      wsct=t_bath/temp0
1006       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1007 #endif
1008       return
1009       end
1010 C------------------------------------------------------------------------
1011       subroutine enerprint(energia)
1012       implicit real*8 (a-h,o-z)
1013       include 'DIMENSIONS'
1014       include 'COMMON.IOUNITS'
1015       include 'COMMON.FFIELD'
1016       include 'COMMON.SBRIDGE'
1017       include 'COMMON.MD'
1018       double precision energia(0:n_ene)
1019       etot=energia(0)
1020 #ifdef TSCSC
1021       evdw=energia(22)+wsct*energia(23)
1022 #else
1023       evdw=energia(1)
1024 #endif
1025       evdw2=energia(2)
1026 #ifdef SCP14
1027       evdw2=energia(2)+energia(18)
1028 #else
1029       evdw2=energia(2)
1030 #endif
1031       ees=energia(3)
1032 #ifdef SPLITELE
1033       evdw1=energia(16)
1034 #endif
1035       ecorr=energia(4)
1036       ecorr5=energia(5)
1037       ecorr6=energia(6)
1038       eel_loc=energia(7)
1039       eello_turn3=energia(8)
1040       eello_turn4=energia(9)
1041       eello_turn6=energia(10)
1042       ebe=energia(11)
1043       escloc=energia(12)
1044       etors=energia(13)
1045       etors_d=energia(14)
1046       ehpb=energia(15)
1047       edihcnstr=energia(19)
1048       estr=energia(17)
1049       Uconst=energia(20)
1050       esccor=energia(21)
1051 #ifdef SPLITELE
1052       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1053      &  estr,wbond,ebe,wang,
1054      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1055      &  ecorr,wcorr,
1056      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1057      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1058      &  edihcnstr,ebr*nss,
1059      &  Uconst,etot
1060    10 format (/'Virtual-chain energies:'//
1061      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1062      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1063      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1064      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1065      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1066      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1067      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1068      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1069      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1070      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1071      & ' (SS bridges & dist. cnstr.)'/
1072      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1075      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1076      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1077      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1078      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1079      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1080      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1081      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1082      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1083      & 'ETOT=  ',1pE16.6,' (total)')
1084 #else
1085       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1086      &  estr,wbond,ebe,wang,
1087      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1088      &  ecorr,wcorr,
1089      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1090      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1091      &  ebr*nss,Uconst,etot
1092    10 format (/'Virtual-chain energies:'//
1093      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1094      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1095      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1096      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1097      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1098      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1099      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1100      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1101      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1102      & ' (SS bridges & dist. cnstr.)'/
1103      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1106      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1107      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1108      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1109      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1110      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1111      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1112      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1113      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1114      & 'ETOT=  ',1pE16.6,' (total)')
1115 #endif
1116       return
1117       end
1118 C-----------------------------------------------------------------------
1119       subroutine elj(evdw,evdw_p,evdw_m)
1120 C
1121 C This subroutine calculates the interaction energy of nonbonded side chains
1122 C assuming the LJ potential of interaction.
1123 C
1124       implicit real*8 (a-h,o-z)
1125       include 'DIMENSIONS'
1126       parameter (accur=1.0d-10)
1127       include 'COMMON.GEO'
1128       include 'COMMON.VAR'
1129       include 'COMMON.LOCAL'
1130       include 'COMMON.CHAIN'
1131       include 'COMMON.DERIV'
1132       include 'COMMON.INTERACT'
1133       include 'COMMON.TORSION'
1134       include 'COMMON.SBRIDGE'
1135       include 'COMMON.NAMES'
1136       include 'COMMON.IOUNITS'
1137       include 'COMMON.CONTACTS'
1138       dimension gg(3)
1139 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1140       evdw=0.0D0
1141       do i=iatsc_s,iatsc_e
1142         itypi=itype(i)
1143         itypi1=itype(i+1)
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=itype(j)
1157             xj=c(1,nres+j)-xi
1158             yj=c(2,nres+j)-yi
1159             zj=c(3,nres+j)-zi
1160 C Change 12/1/95 to calculate four-body interactions
1161             rij=xj*xj+yj*yj+zj*zj
1162             rrij=1.0D0/rij
1163 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1164             eps0ij=eps(itypi,itypj)
1165             fac=rrij**expon2
1166             e1=fac*fac*aa(itypi,itypj)
1167             e2=fac*bb(itypi,itypj)
1168             evdwij=e1+e2
1169 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1170 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1171 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1172 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1173 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1174 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1175 #ifdef TSCSC
1176             if (bb(itypi,itypj).gt.0) then
1177                evdw_p=evdw_p+evdwij
1178             else
1179                evdw_m=evdw_m+evdwij
1180             endif
1181 #else
1182             evdw=evdw+evdwij
1183 #endif
1184 C
1185 C Calculate the components of the gradient in DC and X
1186 C
1187             fac=-rrij*(e1+evdwij)
1188             gg(1)=xj*fac
1189             gg(2)=yj*fac
1190             gg(3)=zj*fac
1191 #ifdef TSCSC
1192             if (bb(itypi,itypj).gt.0.0d0) then
1193               do k=1,3
1194                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1195                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1197                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1198               enddo
1199             else
1200               do k=1,3
1201                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1202                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1203                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1204                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1205               enddo
1206             endif
1207 #else
1208             do k=1,3
1209               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1210               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1211               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1212               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1213             enddo
1214 #endif
1215 cgrad            do k=i,j-1
1216 cgrad              do l=1,3
1217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1218 cgrad              enddo
1219 cgrad            enddo
1220 C
1221 C 12/1/95, revised on 5/20/97
1222 C
1223 C Calculate the contact function. The ith column of the array JCONT will
1224 C contain the numbers of atoms that make contacts with the atom I (of numbers
1225 C greater than I). The arrays FACONT and GACONT will contain the values of
1226 C the contact function and its derivative.
1227 C
1228 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1229 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1230 C Uncomment next line, if the correlation interactions are contact function only
1231             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1232               rij=dsqrt(rij)
1233               sigij=sigma(itypi,itypj)
1234               r0ij=rs0(itypi,itypj)
1235 C
1236 C Check whether the SC's are not too far to make a contact.
1237 C
1238               rcut=1.5d0*r0ij
1239               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1240 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1241 C
1242               if (fcont.gt.0.0D0) then
1243 C If the SC-SC distance if close to sigma, apply spline.
1244 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1245 cAdam &             fcont1,fprimcont1)
1246 cAdam           fcont1=1.0d0-fcont1
1247 cAdam           if (fcont1.gt.0.0d0) then
1248 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1249 cAdam             fcont=fcont*fcont1
1250 cAdam           endif
1251 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1252 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1253 cga             do k=1,3
1254 cga               gg(k)=gg(k)*eps0ij
1255 cga             enddo
1256 cga             eps0ij=-evdwij*eps0ij
1257 C Uncomment for AL's type of SC correlation interactions.
1258 cadam           eps0ij=-evdwij
1259                 num_conti=num_conti+1
1260                 jcont(num_conti,i)=j
1261                 facont(num_conti,i)=fcont*eps0ij
1262                 fprimcont=eps0ij*fprimcont/rij
1263                 fcont=expon*fcont
1264 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1265 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1266 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1267 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1268                 gacont(1,num_conti,i)=-fprimcont*xj
1269                 gacont(2,num_conti,i)=-fprimcont*yj
1270                 gacont(3,num_conti,i)=-fprimcont*zj
1271 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1272 cd              write (iout,'(2i3,3f10.5)')
1273 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1274               endif
1275             endif
1276           enddo      ! j
1277         enddo        ! iint
1278 C Change 12/1/95
1279         num_cont(i)=num_conti
1280       enddo          ! i
1281       do i=1,nct
1282         do j=1,3
1283           gvdwc(j,i)=expon*gvdwc(j,i)
1284           gvdwx(j,i)=expon*gvdwx(j,i)
1285         enddo
1286       enddo
1287 C******************************************************************************
1288 C
1289 C                              N O T E !!!
1290 C
1291 C To save time, the factor of EXPON has been extracted from ALL components
1292 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1293 C use!
1294 C
1295 C******************************************************************************
1296       return
1297       end
1298 C-----------------------------------------------------------------------------
1299       subroutine eljk(evdw,evdw_p,evdw_m)
1300 C
1301 C This subroutine calculates the interaction energy of nonbonded side chains
1302 C assuming the LJK potential of interaction.
1303 C
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.INTERACT'
1312       include 'COMMON.IOUNITS'
1313       include 'COMMON.NAMES'
1314       dimension gg(3)
1315       logical scheck
1316 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1317       evdw=0.0D0
1318       do i=iatsc_s,iatsc_e
1319         itypi=itype(i)
1320         itypi1=itype(i+1)
1321         xi=c(1,nres+i)
1322         yi=c(2,nres+i)
1323         zi=c(3,nres+i)
1324 C
1325 C Calculate SC interaction energy.
1326 C
1327         do iint=1,nint_gr(i)
1328           do j=istart(i,iint),iend(i,iint)
1329             itypj=itype(j)
1330             xj=c(1,nres+j)-xi
1331             yj=c(2,nres+j)-yi
1332             zj=c(3,nres+j)-zi
1333             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1334             fac_augm=rrij**expon
1335             e_augm=augm(itypi,itypj)*fac_augm
1336             r_inv_ij=dsqrt(rrij)
1337             rij=1.0D0/r_inv_ij
1338             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1339             fac=r_shift_inv**expon
1340             e1=fac*fac*aa(itypi,itypj)
1341             e2=fac*bb(itypi,itypj)
1342             evdwij=e_augm+e1+e2
1343 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1344 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1345 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1346 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1347 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1348 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1349 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1350 #ifdef TSCSC
1351             if (bb(itypi,itypj).gt.0) then
1352                evdw_p=evdw_p+evdwij
1353             else
1354                evdw_m=evdw_m+evdwij
1355             endif
1356 #else
1357             evdw=evdw+evdwij
1358 #endif
1359 C
1360 C Calculate the components of the gradient in DC and X
1361 C
1362             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1363             gg(1)=xj*fac
1364             gg(2)=yj*fac
1365             gg(3)=zj*fac
1366 #ifdef TSCSC
1367             if (bb(itypi,itypj).gt.0.0d0) then
1368               do k=1,3
1369                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1370                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1371                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1372                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1373               enddo
1374             else
1375               do k=1,3
1376                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1377                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1378                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1379                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1380               enddo
1381             endif
1382 #else
1383             do k=1,3
1384               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1385               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1386               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1387               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1388             enddo
1389 #endif
1390 cgrad            do k=i,j-1
1391 cgrad              do l=1,3
1392 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1393 cgrad              enddo
1394 cgrad            enddo
1395           enddo      ! j
1396         enddo        ! iint
1397       enddo          ! i
1398       do i=1,nct
1399         do j=1,3
1400           gvdwc(j,i)=expon*gvdwc(j,i)
1401           gvdwx(j,i)=expon*gvdwx(j,i)
1402         enddo
1403       enddo
1404       return
1405       end
1406 C-----------------------------------------------------------------------------
1407       subroutine ebp(evdw,evdw_p,evdw_m)
1408 C
1409 C This subroutine calculates the interaction energy of nonbonded side chains
1410 C assuming the Berne-Pechukas potential of interaction.
1411 C
1412       implicit real*8 (a-h,o-z)
1413       include 'DIMENSIONS'
1414       include 'COMMON.GEO'
1415       include 'COMMON.VAR'
1416       include 'COMMON.LOCAL'
1417       include 'COMMON.CHAIN'
1418       include 'COMMON.DERIV'
1419       include 'COMMON.NAMES'
1420       include 'COMMON.INTERACT'
1421       include 'COMMON.IOUNITS'
1422       include 'COMMON.CALC'
1423       common /srutu/ icall
1424 c     double precision rrsave(maxdim)
1425       logical lprn
1426       evdw=0.0D0
1427 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1428       evdw=0.0D0
1429 c     if (icall.eq.0) then
1430 c       lprn=.true.
1431 c     else
1432         lprn=.false.
1433 c     endif
1434       ind=0
1435       do i=iatsc_s,iatsc_e
1436         itypi=itype(i)
1437         itypi1=itype(i+1)
1438         xi=c(1,nres+i)
1439         yi=c(2,nres+i)
1440         zi=c(3,nres+i)
1441         dxi=dc_norm(1,nres+i)
1442         dyi=dc_norm(2,nres+i)
1443         dzi=dc_norm(3,nres+i)
1444 c        dsci_inv=dsc_inv(itypi)
1445         dsci_inv=vbld_inv(i+nres)
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450           do j=istart(i,iint),iend(i,iint)
1451             ind=ind+1
1452             itypj=itype(j)
1453 c            dscj_inv=dsc_inv(itypj)
1454             dscj_inv=vbld_inv(j+nres)
1455             chi1=chi(itypi,itypj)
1456             chi2=chi(itypj,itypi)
1457             chi12=chi1*chi2
1458             chip1=chip(itypi)
1459             chip2=chip(itypj)
1460             chip12=chip1*chip2
1461             alf1=alp(itypi)
1462             alf2=alp(itypj)
1463             alf12=0.5D0*(alf1+alf2)
1464 C For diagnostics only!!!
1465 c           chi1=0.0D0
1466 c           chi2=0.0D0
1467 c           chi12=0.0D0
1468 c           chip1=0.0D0
1469 c           chip2=0.0D0
1470 c           chip12=0.0D0
1471 c           alf1=0.0D0
1472 c           alf2=0.0D0
1473 c           alf12=0.0D0
1474             xj=c(1,nres+j)-xi
1475             yj=c(2,nres+j)-yi
1476             zj=c(3,nres+j)-zi
1477             dxj=dc_norm(1,nres+j)
1478             dyj=dc_norm(2,nres+j)
1479             dzj=dc_norm(3,nres+j)
1480             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1481 cd          if (icall.eq.0) then
1482 cd            rrsave(ind)=rrij
1483 cd          else
1484 cd            rrij=rrsave(ind)
1485 cd          endif
1486             rij=dsqrt(rrij)
1487 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1488             call sc_angular
1489 C Calculate whole angle-dependent part of epsilon and contributions
1490 C to its derivatives
1491             fac=(rrij*sigsq)**expon2
1492             e1=fac*fac*aa(itypi,itypj)
1493             e2=fac*bb(itypi,itypj)
1494             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1495             eps2der=evdwij*eps3rt
1496             eps3der=evdwij*eps2rt
1497             evdwij=evdwij*eps2rt*eps3rt
1498 #ifdef TSCSC
1499             if (bb(itypi,itypj).gt.0) then
1500                evdw_p=evdw_p+evdwij
1501             else
1502                evdw_m=evdw_m+evdwij
1503             endif
1504 #else
1505             evdw=evdw+evdwij
1506 #endif
1507             if (lprn) then
1508             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1509             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1510 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1511 cd     &        restyp(itypi),i,restyp(itypj),j,
1512 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1513 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1514 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1515 cd     &        evdwij
1516             endif
1517 C Calculate gradient components.
1518             e1=e1*eps1*eps2rt**2*eps3rt**2
1519             fac=-expon*(e1+evdwij)
1520             sigder=fac/sigsq
1521             fac=rrij*fac
1522 C Calculate radial part of the gradient
1523             gg(1)=xj*fac
1524             gg(2)=yj*fac
1525             gg(3)=zj*fac
1526 C Calculate the angular part of the gradient and sum add the contributions
1527 C to the appropriate components of the Cartesian gradient.
1528 #ifdef TSCSC
1529             if (bb(itypi,itypj).gt.0) then
1530                call sc_grad
1531             else
1532                call sc_grad_T
1533             endif
1534 #else
1535             call sc_grad
1536 #endif
1537           enddo      ! j
1538         enddo        ! iint
1539       enddo          ! i
1540 c     stop
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egb(evdw,evdw_p,evdw_m)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       include 'COMMON.CONTROL'
1561       include 'COMMON.SBRIDGE'
1562       logical lprn
1563       evdw=0.0D0
1564 ccccc      energy_dec=.false.
1565 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1566       evdw=0.0D0
1567       evdw_p=0.0D0
1568       evdw_m=0.0D0
1569       lprn=.false.
1570 c     if (icall.eq.0) lprn=.false.
1571       ind=0
1572       do i=iatsc_s,iatsc_e
1573         itypi=itype(i)
1574         itypi1=itype(i+1)
1575         xi=c(1,nres+i)
1576         yi=c(2,nres+i)
1577         zi=c(3,nres+i)
1578         dxi=dc_norm(1,nres+i)
1579         dyi=dc_norm(2,nres+i)
1580         dzi=dc_norm(3,nres+i)
1581 c        dsci_inv=dsc_inv(itypi)
1582         dsci_inv=vbld_inv(i+nres)
1583 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1584 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1585 C
1586 C Calculate SC interaction energy.
1587 C
1588         do iint=1,nint_gr(i)
1589           do j=istart(i,iint),iend(i,iint)
1590             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1591               call dyn_ssbond_ene(i,j,evdwij)
1592               evdw=evdw+evdwij
1593               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1594      &                        'evdw',i,j,evdwij,' ss'
1595             ELSE
1596             ind=ind+1
1597             itypj=itype(j)
1598 c            dscj_inv=dsc_inv(itypj)
1599             dscj_inv=vbld_inv(j+nres)
1600 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1601 c     &       1.0d0/vbld(j+nres)
1602 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1603             sig0ij=sigma(itypi,itypj)
1604             chi1=chi(itypi,itypj)
1605             chi2=chi(itypj,itypi)
1606             chi12=chi1*chi2
1607             chip1=chip(itypi)
1608             chip2=chip(itypj)
1609             chip12=chip1*chip2
1610             alf1=alp(itypi)
1611             alf2=alp(itypj)
1612             alf12=0.5D0*(alf1+alf2)
1613 C For diagnostics only!!!
1614 c           chi1=0.0D0
1615 c           chi2=0.0D0
1616 c           chi12=0.0D0
1617 c           chip1=0.0D0
1618 c           chip2=0.0D0
1619 c           chip12=0.0D0
1620 c           alf1=0.0D0
1621 c           alf2=0.0D0
1622 c           alf12=0.0D0
1623             xj=c(1,nres+j)-xi
1624             yj=c(2,nres+j)-yi
1625             zj=c(3,nres+j)-zi
1626             dxj=dc_norm(1,nres+j)
1627             dyj=dc_norm(2,nres+j)
1628             dzj=dc_norm(3,nres+j)
1629 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1630 c            write (iout,*) "j",j," dc_norm",
1631 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1632             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1633             rij=dsqrt(rrij)
1634 C Calculate angle-dependent terms of energy and contributions to their
1635 C derivatives.
1636             call sc_angular
1637             sigsq=1.0D0/sigsq
1638             sig=sig0ij*dsqrt(sigsq)
1639             rij_shift=1.0D0/rij-sig+sig0ij
1640 c for diagnostics; uncomment
1641 c            rij_shift=1.2*sig0ij
1642 C I hate to put IF's in the loops, but here don't have another choice!!!!
1643             if (rij_shift.le.0.0D0) then
1644               evdw=1.0D20
1645 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1646 cd     &        restyp(itypi),i,restyp(itypj),j,
1647 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1648               return
1649             endif
1650             sigder=-sig*sigsq
1651 c---------------------------------------------------------------
1652             rij_shift=1.0D0/rij_shift
1653             fac=rij_shift**expon
1654             e1=fac*fac*aa(itypi,itypj)
1655             e2=fac*bb(itypi,itypj)
1656             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1657             eps2der=evdwij*eps3rt
1658             eps3der=evdwij*eps2rt
1659 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1660 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1661             evdwij=evdwij*eps2rt*eps3rt
1662 #ifdef TSCSC
1663             if (bb(itypi,itypj).gt.0) then
1664                evdw_p=evdw_p+evdwij
1665             else
1666                evdw_m=evdw_m+evdwij
1667             endif
1668 #else
1669             evdw=evdw+evdwij
1670 #endif
1671             if (lprn) then
1672             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1673             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1674             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1675      &        restyp(itypi),i,restyp(itypj),j,
1676      &        epsi,sigm,chi1,chi2,chip1,chip2,
1677      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1678      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1679      &        evdwij
1680             endif
1681
1682             if (energy_dec) 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 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3027 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21)
3028 C     &  cycle
3029         dxi=dc(1,i)
3030         dyi=dc(2,i)
3031         dzi=dc(3,i)
3032         dx_normi=dc_norm(1,i)
3033         dy_normi=dc_norm(2,i)
3034         dz_normi=dc_norm(3,i)
3035         xmedi=c(1,i)+0.5d0*dxi
3036         ymedi=c(2,i)+0.5d0*dyi
3037         zmedi=c(3,i)+0.5d0*dzi
3038         num_conti=0
3039         call eelecij(i,i+2,ees,evdw1,eel_loc)
3040         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3041         num_cont_hb(i)=num_conti
3042       enddo
3043       do i=iturn4_start,iturn4_end
3044 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3045 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21
3046 C     &  .or. itype(i+5).eq.21)
3047 C     & cycle
3048         dxi=dc(1,i)
3049         dyi=dc(2,i)
3050         dzi=dc(3,i)
3051         dx_normi=dc_norm(1,i)
3052         dy_normi=dc_norm(2,i)
3053         dz_normi=dc_norm(3,i)
3054         xmedi=c(1,i)+0.5d0*dxi
3055         ymedi=c(2,i)+0.5d0*dyi
3056         zmedi=c(3,i)+0.5d0*dzi
3057         num_conti=num_cont_hb(i)
3058         call eelecij(i,i+3,ees,evdw1,eel_loc)
3059         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3060         num_cont_hb(i)=num_conti
3061       enddo   ! i
3062 c
3063 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3064 c
3065       do i=iatel_s,iatel_e
3066 C          if (itype(i).eq.21 .or. itype(i+1).eq.21
3067 C     &.or.itype(i+2)) cycle
3068         dxi=dc(1,i)
3069         dyi=dc(2,i)
3070         dzi=dc(3,i)
3071         dx_normi=dc_norm(1,i)
3072         dy_normi=dc_norm(2,i)
3073         dz_normi=dc_norm(3,i)
3074         xmedi=c(1,i)+0.5d0*dxi
3075         ymedi=c(2,i)+0.5d0*dyi
3076         zmedi=c(3,i)+0.5d0*dzi
3077 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3078         num_conti=num_cont_hb(i)
3079         do j=ielstart(i),ielend(i)
3080 C          if (itype(j).eq.21 .or. itype(j+1).eq.21
3081 C     &.or.itype(j+2)) cycle
3082           call eelecij(i,j,ees,evdw1,eel_loc)
3083         enddo ! j
3084         num_cont_hb(i)=num_conti
3085       enddo   ! i
3086 c      write (iout,*) "Number of loop steps in EELEC:",ind
3087 cd      do i=1,nres
3088 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3089 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3090 cd      enddo
3091 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3092 ccc      eel_loc=eel_loc+eello_turn3
3093 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3094       return
3095       end
3096 C-------------------------------------------------------------------------------
3097       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3098       implicit real*8 (a-h,o-z)
3099       include 'DIMENSIONS'
3100 #ifdef MPI
3101       include "mpif.h"
3102 #endif
3103       include 'COMMON.CONTROL'
3104       include 'COMMON.IOUNITS'
3105       include 'COMMON.GEO'
3106       include 'COMMON.VAR'
3107       include 'COMMON.LOCAL'
3108       include 'COMMON.CHAIN'
3109       include 'COMMON.DERIV'
3110       include 'COMMON.INTERACT'
3111       include 'COMMON.CONTACTS'
3112       include 'COMMON.TORSION'
3113       include 'COMMON.VECTORS'
3114       include 'COMMON.FFIELD'
3115       include 'COMMON.TIME1'
3116       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3117      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3118       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3119      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3120       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3121      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3122      &    num_conti,j1,j2
3123 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3124 #ifdef MOMENT
3125       double precision scal_el /1.0d0/
3126 #else
3127       double precision scal_el /0.5d0/
3128 #endif
3129 C 12/13/98
3130 C 13-go grudnia roku pamietnego...
3131       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3132      &                   0.0d0,1.0d0,0.0d0,
3133      &                   0.0d0,0.0d0,1.0d0/
3134 c          time00=MPI_Wtime()
3135 cd      write (iout,*) "eelecij",i,j
3136 c          ind=ind+1
3137           iteli=itel(i)
3138           itelj=itel(j)
3139           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3140           aaa=app(iteli,itelj)
3141           bbb=bpp(iteli,itelj)
3142           ael6i=ael6(iteli,itelj)
3143           ael3i=ael3(iteli,itelj)
3144           dxj=dc(1,j)
3145           dyj=dc(2,j)
3146           dzj=dc(3,j)
3147           dx_normj=dc_norm(1,j)
3148           dy_normj=dc_norm(2,j)
3149           dz_normj=dc_norm(3,j)
3150           xj=c(1,j)+0.5D0*dxj-xmedi
3151           yj=c(2,j)+0.5D0*dyj-ymedi
3152           zj=c(3,j)+0.5D0*dzj-zmedi
3153           rij=xj*xj+yj*yj+zj*zj
3154           rrmij=1.0D0/rij
3155           rij=dsqrt(rij)
3156           rmij=1.0D0/rij
3157           r3ij=rrmij*rmij
3158           r6ij=r3ij*r3ij
3159           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3160           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3161           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3162           fac=cosa-3.0D0*cosb*cosg
3163           ev1=aaa*r6ij*r6ij
3164 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3165           if (j.eq.i+2) ev1=scal_el*ev1
3166           ev2=bbb*r6ij
3167           fac3=ael6i*r6ij
3168           fac4=ael3i*r3ij
3169           evdwij=ev1+ev2
3170           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3171           el2=fac4*fac
3172           eesij=el1+el2
3173 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3174           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3175           ees=ees+eesij
3176           evdw1=evdw1+evdwij
3177 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3178 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3179 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3180 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3181
3182           if (energy_dec) then
3183               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3184               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3185           endif
3186
3187 C
3188 C Calculate contributions to the Cartesian gradient.
3189 C
3190 #ifdef SPLITELE
3191           facvdw=-6*rrmij*(ev1+evdwij)
3192           facel=-3*rrmij*(el1+eesij)
3193           fac1=fac
3194           erij(1)=xj*rmij
3195           erij(2)=yj*rmij
3196           erij(3)=zj*rmij
3197 *
3198 * Radial derivatives. First process both termini of the fragment (i,j)
3199 *
3200           ggg(1)=facel*xj
3201           ggg(2)=facel*yj
3202           ggg(3)=facel*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gelc(k,i)=gelc(k,i)+ghalf
3206 c            gelc(k,j)=gelc(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3211             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221           ggg(1)=facvdw*xj
3222           ggg(2)=facvdw*yj
3223           ggg(3)=facvdw*zj
3224 c          do k=1,3
3225 c            ghalf=0.5D0*ggg(k)
3226 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3227 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3228 c          enddo
3229 c 9/28/08 AL Gradient compotents will be summed only at the end
3230           do k=1,3
3231             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3232             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3233           enddo
3234 *
3235 * Loop over residues i+1 thru j-1.
3236 *
3237 cgrad          do k=i+1,j-1
3238 cgrad            do l=1,3
3239 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3240 cgrad            enddo
3241 cgrad          enddo
3242 #else
3243           facvdw=ev1+evdwij
3244           facel=el1+eesij
3245           fac1=fac
3246           fac=-3*rrmij*(facvdw+facvdw+facel)
3247           erij(1)=xj*rmij
3248           erij(2)=yj*rmij
3249           erij(3)=zj*rmij
3250 *
3251 * Radial derivatives. First process both termini of the fragment (i,j)
3252 *
3253           ggg(1)=fac*xj
3254           ggg(2)=fac*yj
3255           ggg(3)=fac*zj
3256 c          do k=1,3
3257 c            ghalf=0.5D0*ggg(k)
3258 c            gelc(k,i)=gelc(k,i)+ghalf
3259 c            gelc(k,j)=gelc(k,j)+ghalf
3260 c          enddo
3261 c 9/28/08 AL Gradient compotents will be summed only at the end
3262           do k=1,3
3263             gelc_long(k,j)=gelc(k,j)+ggg(k)
3264             gelc_long(k,i)=gelc(k,i)-ggg(k)
3265           enddo
3266 *
3267 * Loop over residues i+1 thru j-1.
3268 *
3269 cgrad          do k=i+1,j-1
3270 cgrad            do l=1,3
3271 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3272 cgrad            enddo
3273 cgrad          enddo
3274 c 9/28/08 AL Gradient compotents will be summed only at the end
3275           ggg(1)=facvdw*xj
3276           ggg(2)=facvdw*yj
3277           ggg(3)=facvdw*zj
3278           do k=1,3
3279             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3280             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3281           enddo
3282 #endif
3283 *
3284 * Angular part
3285 *
3286           ecosa=2.0D0*fac3*fac1+fac4
3287           fac4=-3.0D0*fac4
3288           fac3=-6.0D0*fac3
3289           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3290           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3291           do k=1,3
3292             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3293             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3294           enddo
3295 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3296 cd   &          (dcosg(k),k=1,3)
3297           do k=1,3
3298             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3299           enddo
3300 c          do k=1,3
3301 c            ghalf=0.5D0*ggg(k)
3302 c            gelc(k,i)=gelc(k,i)+ghalf
3303 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3304 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3305 c            gelc(k,j)=gelc(k,j)+ghalf
3306 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3307 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3308 c          enddo
3309 cgrad          do k=i+1,j-1
3310 cgrad            do l=1,3
3311 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3312 cgrad            enddo
3313 cgrad          enddo
3314           do k=1,3
3315             gelc(k,i)=gelc(k,i)
3316      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3317      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3318             gelc(k,j)=gelc(k,j)
3319      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3320      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3321             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3322             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3323           enddo
3324           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3325      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3326      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3327 C
3328 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3329 C   energy of a peptide unit is assumed in the form of a second-order
3330 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3331 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3332 C   are computed for EVERY pair of non-contiguous peptide groups.
3333 C
3334           if (j.lt.nres-1) then
3335             j1=j+1
3336             j2=j-1
3337           else
3338             j1=j-1
3339             j2=j-2
3340           endif
3341           kkk=0
3342           do k=1,2
3343             do l=1,2
3344               kkk=kkk+1
3345               muij(kkk)=mu(k,i)*mu(l,j)
3346             enddo
3347           enddo
3348 cd         write (iout,*) 'EELEC: i',i,' j',j
3349 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3350 cd          write(iout,*) 'muij',muij
3351           ury=scalar(uy(1,i),erij)
3352           urz=scalar(uz(1,i),erij)
3353           vry=scalar(uy(1,j),erij)
3354           vrz=scalar(uz(1,j),erij)
3355           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3356           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3357           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3358           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3359           fac=dsqrt(-ael6i)*r3ij
3360           a22=a22*fac
3361           a23=a23*fac
3362           a32=a32*fac
3363           a33=a33*fac
3364 cd          write (iout,'(4i5,4f10.5)')
3365 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3366 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3367 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3368 cd     &      uy(:,j),uz(:,j)
3369 cd          write (iout,'(4f10.5)')
3370 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3371 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3372 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3373 cd           write (iout,'(9f10.5/)')
3374 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3375 C Derivatives of the elements of A in virtual-bond vectors
3376           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3377           do k=1,3
3378             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3379             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3380             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3381             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3382             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3383             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3384             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3385             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3386             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3387             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3388             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3389             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3390           enddo
3391 C Compute radial contributions to the gradient
3392           facr=-3.0d0*rrmij
3393           a22der=a22*facr
3394           a23der=a23*facr
3395           a32der=a32*facr
3396           a33der=a33*facr
3397           agg(1,1)=a22der*xj
3398           agg(2,1)=a22der*yj
3399           agg(3,1)=a22der*zj
3400           agg(1,2)=a23der*xj
3401           agg(2,2)=a23der*yj
3402           agg(3,2)=a23der*zj
3403           agg(1,3)=a32der*xj
3404           agg(2,3)=a32der*yj
3405           agg(3,3)=a32der*zj
3406           agg(1,4)=a33der*xj
3407           agg(2,4)=a33der*yj
3408           agg(3,4)=a33der*zj
3409 C Add the contributions coming from er
3410           fac3=-3.0d0*fac
3411           do k=1,3
3412             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3413             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3414             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3415             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3416           enddo
3417           do k=1,3
3418 C Derivatives in DC(i)
3419 cgrad            ghalf1=0.5d0*agg(k,1)
3420 cgrad            ghalf2=0.5d0*agg(k,2)
3421 cgrad            ghalf3=0.5d0*agg(k,3)
3422 cgrad            ghalf4=0.5d0*agg(k,4)
3423             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3424      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3425             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3426      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3427             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3428      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3429             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3430      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3431 C Derivatives in DC(i+1)
3432             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3433      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3434             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3435      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3436             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3437      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3438             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3439      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3440 C Derivatives in DC(j)
3441             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3442      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3443             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3444      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3445             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3446      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3447             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3448      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3449 C Derivatives in DC(j+1) or DC(nres-1)
3450             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3451      &      -3.0d0*vryg(k,3)*ury)
3452             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3453      &      -3.0d0*vrzg(k,3)*ury)
3454             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3455      &      -3.0d0*vryg(k,3)*urz)
3456             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3457      &      -3.0d0*vrzg(k,3)*urz)
3458 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3459 cgrad              do l=1,4
3460 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3461 cgrad              enddo
3462 cgrad            endif
3463           enddo
3464           acipa(1,1)=a22
3465           acipa(1,2)=a23
3466           acipa(2,1)=a32
3467           acipa(2,2)=a33
3468           a22=-a22
3469           a23=-a23
3470           do l=1,2
3471             do k=1,3
3472               agg(k,l)=-agg(k,l)
3473               aggi(k,l)=-aggi(k,l)
3474               aggi1(k,l)=-aggi1(k,l)
3475               aggj(k,l)=-aggj(k,l)
3476               aggj1(k,l)=-aggj1(k,l)
3477             enddo
3478           enddo
3479           if (j.lt.nres-1) then
3480             a22=-a22
3481             a32=-a32
3482             do l=1,3,2
3483               do k=1,3
3484                 agg(k,l)=-agg(k,l)
3485                 aggi(k,l)=-aggi(k,l)
3486                 aggi1(k,l)=-aggi1(k,l)
3487                 aggj(k,l)=-aggj(k,l)
3488                 aggj1(k,l)=-aggj1(k,l)
3489               enddo
3490             enddo
3491           else
3492             a22=-a22
3493             a23=-a23
3494             a32=-a32
3495             a33=-a33
3496             do l=1,4
3497               do k=1,3
3498                 agg(k,l)=-agg(k,l)
3499                 aggi(k,l)=-aggi(k,l)
3500                 aggi1(k,l)=-aggi1(k,l)
3501                 aggj(k,l)=-aggj(k,l)
3502                 aggj1(k,l)=-aggj1(k,l)
3503               enddo
3504             enddo
3505           endif
3506           ENDIF ! WCORR
3507           IF (wel_loc.gt.0.0d0) THEN
3508 C Contribution to the local-electrostatic energy coming from the i-j pair
3509           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3510      &     +a33*muij(4)
3511 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3512
3513           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3514      &            'eelloc',i,j,eel_loc_ij
3515
3516           eel_loc=eel_loc+eel_loc_ij
3517 C Partial derivatives in virtual-bond dihedral angles gamma
3518           if (i.gt.1)
3519      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3520      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3521      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3522           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3523      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3524      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3525 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3526           do l=1,3
3527             ggg(l)=agg(l,1)*muij(1)+
3528      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3529             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3530             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3531 cgrad            ghalf=0.5d0*ggg(l)
3532 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3533 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3534           enddo
3535 cgrad          do k=i+1,j2
3536 cgrad            do l=1,3
3537 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3538 cgrad            enddo
3539 cgrad          enddo
3540 C Remaining derivatives of eello
3541           do l=1,3
3542             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3543      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3544             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3545      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3546             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3547      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3548             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3549      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3550           enddo
3551           ENDIF
3552 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3553 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3554           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3555      &       .and. num_conti.le.maxconts) then
3556 c            write (iout,*) i,j," entered corr"
3557 C
3558 C Calculate the contact function. The ith column of the array JCONT will
3559 C contain the numbers of atoms that make contacts with the atom I (of numbers
3560 C greater than I). The arrays FACONT and GACONT will contain the values of
3561 C the contact function and its derivative.
3562 c           r0ij=1.02D0*rpp(iteli,itelj)
3563 c           r0ij=1.11D0*rpp(iteli,itelj)
3564             r0ij=2.20D0*rpp(iteli,itelj)
3565 c           r0ij=1.55D0*rpp(iteli,itelj)
3566             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3567             if (fcont.gt.0.0D0) then
3568               num_conti=num_conti+1
3569               if (num_conti.gt.maxconts) then
3570                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3571      &                         ' will skip next contacts for this conf.'
3572               else
3573                 jcont_hb(num_conti,i)=j
3574 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3575 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3576                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3577      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3578 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3579 C  terms.
3580                 d_cont(num_conti,i)=rij
3581 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3582 C     --- Electrostatic-interaction matrix ---
3583                 a_chuj(1,1,num_conti,i)=a22
3584                 a_chuj(1,2,num_conti,i)=a23
3585                 a_chuj(2,1,num_conti,i)=a32
3586                 a_chuj(2,2,num_conti,i)=a33
3587 C     --- Gradient of rij
3588                 do kkk=1,3
3589                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3590                 enddo
3591                 kkll=0
3592                 do k=1,2
3593                   do l=1,2
3594                     kkll=kkll+1
3595                     do m=1,3
3596                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3597                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3598                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3599                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3600                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3601                     enddo
3602                   enddo
3603                 enddo
3604                 ENDIF
3605                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3606 C Calculate contact energies
3607                 cosa4=4.0D0*cosa
3608                 wij=cosa-3.0D0*cosb*cosg
3609                 cosbg1=cosb+cosg
3610                 cosbg2=cosb-cosg
3611 c               fac3=dsqrt(-ael6i)/r0ij**3
3612                 fac3=dsqrt(-ael6i)*r3ij
3613 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3614                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3615                 if (ees0tmp.gt.0) then
3616                   ees0pij=dsqrt(ees0tmp)
3617                 else
3618                   ees0pij=0
3619                 endif
3620 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3621                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3622                 if (ees0tmp.gt.0) then
3623                   ees0mij=dsqrt(ees0tmp)
3624                 else
3625                   ees0mij=0
3626                 endif
3627 c               ees0mij=0.0D0
3628                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3629                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3630 C Diagnostics. Comment out or remove after debugging!
3631 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3632 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3633 c               ees0m(num_conti,i)=0.0D0
3634 C End diagnostics.
3635 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3636 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3637 C Angular derivatives of the contact function
3638                 ees0pij1=fac3/ees0pij
3639                 ees0mij1=fac3/ees0mij
3640                 fac3p=-3.0D0*fac3*rrmij
3641                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3642                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3643 c               ees0mij1=0.0D0
3644                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3645                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3646                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3647                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3648                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3649                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3650                 ecosap=ecosa1+ecosa2
3651                 ecosbp=ecosb1+ecosb2
3652                 ecosgp=ecosg1+ecosg2
3653                 ecosam=ecosa1-ecosa2
3654                 ecosbm=ecosb1-ecosb2
3655                 ecosgm=ecosg1-ecosg2
3656 C Diagnostics
3657 c               ecosap=ecosa1
3658 c               ecosbp=ecosb1
3659 c               ecosgp=ecosg1
3660 c               ecosam=0.0D0
3661 c               ecosbm=0.0D0
3662 c               ecosgm=0.0D0
3663 C End diagnostics
3664                 facont_hb(num_conti,i)=fcont
3665                 fprimcont=fprimcont/rij
3666 cd              facont_hb(num_conti,i)=1.0D0
3667 C Following line is for diagnostics.
3668 cd              fprimcont=0.0D0
3669                 do k=1,3
3670                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3671                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3672                 enddo
3673                 do k=1,3
3674                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3675                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3676                 enddo
3677                 gggp(1)=gggp(1)+ees0pijp*xj
3678                 gggp(2)=gggp(2)+ees0pijp*yj
3679                 gggp(3)=gggp(3)+ees0pijp*zj
3680                 gggm(1)=gggm(1)+ees0mijp*xj
3681                 gggm(2)=gggm(2)+ees0mijp*yj
3682                 gggm(3)=gggm(3)+ees0mijp*zj
3683 C Derivatives due to the contact function
3684                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3685                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3686                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3687                 do k=1,3
3688 c
3689 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3690 c          following the change of gradient-summation algorithm.
3691 c
3692 cgrad                  ghalfp=0.5D0*gggp(k)
3693 cgrad                  ghalfm=0.5D0*gggm(k)
3694                   gacontp_hb1(k,num_conti,i)=!ghalfp
3695      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3696      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3697                   gacontp_hb2(k,num_conti,i)=!ghalfp
3698      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3699      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3700                   gacontp_hb3(k,num_conti,i)=gggp(k)
3701                   gacontm_hb1(k,num_conti,i)=!ghalfm
3702      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3703      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3704                   gacontm_hb2(k,num_conti,i)=!ghalfm
3705      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3706      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3707                   gacontm_hb3(k,num_conti,i)=gggm(k)
3708                 enddo
3709 C Diagnostics. Comment out or remove after debugging!
3710 cdiag           do k=1,3
3711 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3712 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3713 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3714 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3715 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3716 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3717 cdiag           enddo
3718               ENDIF ! wcorr
3719               endif  ! num_conti.le.maxconts
3720             endif  ! fcont.gt.0
3721           endif    ! j.gt.i+1
3722           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3723             do k=1,4
3724               do l=1,3
3725                 ghalf=0.5d0*agg(l,k)
3726                 aggi(l,k)=aggi(l,k)+ghalf
3727                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3728                 aggj(l,k)=aggj(l,k)+ghalf
3729               enddo
3730             enddo
3731             if (j.eq.nres-1 .and. i.lt.j-2) then
3732               do k=1,4
3733                 do l=1,3
3734                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3735                 enddo
3736               enddo
3737             endif
3738           endif
3739 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3740       return
3741       end
3742 C-----------------------------------------------------------------------------
3743       subroutine eturn3(i,eello_turn3)
3744 C Third- and fourth-order contributions from turns
3745       implicit real*8 (a-h,o-z)
3746       include 'DIMENSIONS'
3747       include 'COMMON.IOUNITS'
3748       include 'COMMON.GEO'
3749       include 'COMMON.VAR'
3750       include 'COMMON.LOCAL'
3751       include 'COMMON.CHAIN'
3752       include 'COMMON.DERIV'
3753       include 'COMMON.INTERACT'
3754       include 'COMMON.CONTACTS'
3755       include 'COMMON.TORSION'
3756       include 'COMMON.VECTORS'
3757       include 'COMMON.FFIELD'
3758       include 'COMMON.CONTROL'
3759       dimension ggg(3)
3760       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3761      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3762      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3763       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3764      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3765       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3766      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3767      &    num_conti,j1,j2
3768       j=i+2
3769 c      write (iout,*) "eturn3",i,j,j1,j2
3770       a_temp(1,1)=a22
3771       a_temp(1,2)=a23
3772       a_temp(2,1)=a32
3773       a_temp(2,2)=a33
3774 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3775 C
3776 C               Third-order contributions
3777 C
3778 C                 (i+2)o----(i+3)
3779 C                      | |
3780 C                      | |
3781 C                 (i+1)o----i
3782 C
3783 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3784 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3785         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3786         call transpose2(auxmat(1,1),auxmat1(1,1))
3787         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3788         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3789         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3790      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3791 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3792 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3793 cd     &    ' eello_turn3_num',4*eello_turn3_num
3794 C Derivatives in gamma(i)
3795         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3796         call transpose2(auxmat2(1,1),auxmat3(1,1))
3797         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3798         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3799 C Derivatives in gamma(i+1)
3800         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3801         call transpose2(auxmat2(1,1),auxmat3(1,1))
3802         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3803         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3804      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3805 C Cartesian derivatives
3806         do l=1,3
3807 c            ghalf1=0.5d0*agg(l,1)
3808 c            ghalf2=0.5d0*agg(l,2)
3809 c            ghalf3=0.5d0*agg(l,3)
3810 c            ghalf4=0.5d0*agg(l,4)
3811           a_temp(1,1)=aggi(l,1)!+ghalf1
3812           a_temp(1,2)=aggi(l,2)!+ghalf2
3813           a_temp(2,1)=aggi(l,3)!+ghalf3
3814           a_temp(2,2)=aggi(l,4)!+ghalf4
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3819           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3820           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3821           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3822           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3823           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3824      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3825           a_temp(1,1)=aggj(l,1)!+ghalf1
3826           a_temp(1,2)=aggj(l,2)!+ghalf2
3827           a_temp(2,1)=aggj(l,3)!+ghalf3
3828           a_temp(2,2)=aggj(l,4)!+ghalf4
3829           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3830           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3831      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3832           a_temp(1,1)=aggj1(l,1)
3833           a_temp(1,2)=aggj1(l,2)
3834           a_temp(2,1)=aggj1(l,3)
3835           a_temp(2,2)=aggj1(l,4)
3836           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3837           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3838      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3839         enddo
3840       return
3841       end
3842 C-------------------------------------------------------------------------------
3843       subroutine eturn4(i,eello_turn4)
3844 C Third- and fourth-order contributions from turns
3845       implicit real*8 (a-h,o-z)
3846       include 'DIMENSIONS'
3847       include 'COMMON.IOUNITS'
3848       include 'COMMON.GEO'
3849       include 'COMMON.VAR'
3850       include 'COMMON.LOCAL'
3851       include 'COMMON.CHAIN'
3852       include 'COMMON.DERIV'
3853       include 'COMMON.INTERACT'
3854       include 'COMMON.CONTACTS'
3855       include 'COMMON.TORSION'
3856       include 'COMMON.VECTORS'
3857       include 'COMMON.FFIELD'
3858       include 'COMMON.CONTROL'
3859       dimension ggg(3)
3860       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3861      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3862      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3863       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3864      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3865       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3866      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3867      &    num_conti,j1,j2
3868       j=i+3
3869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3870 C
3871 C               Fourth-order contributions
3872 C
3873 C                 (i+3)o----(i+4)
3874 C                     /  |
3875 C               (i+2)o   |
3876 C                     \  |
3877 C                 (i+1)o----i
3878 C
3879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3880 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3881 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3882         a_temp(1,1)=a22
3883         a_temp(1,2)=a23
3884         a_temp(2,1)=a32
3885         a_temp(2,2)=a33
3886         iti1=itortyp(itype(i+1))
3887         iti2=itortyp(itype(i+2))
3888         iti3=itortyp(itype(i+3))
3889 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3890         call transpose2(EUg(1,1,i+1),e1t(1,1))
3891         call transpose2(Eug(1,1,i+2),e2t(1,1))
3892         call transpose2(Eug(1,1,i+3),e3t(1,1))
3893         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3894         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3895         s1=scalar2(b1(1,iti2),auxvec(1))
3896         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3897         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3898         s2=scalar2(b1(1,iti1),auxvec(1))
3899         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3900         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3901         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3902         eello_turn4=eello_turn4-(s1+s2+s3)
3903         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3904      &      'eturn4',i,j,-(s1+s2+s3)
3905 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3906 cd     &    ' eello_turn4_num',8*eello_turn4_num
3907 C Derivatives in gamma(i)
3908         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3909         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3910         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3911         s1=scalar2(b1(1,iti2),auxvec(1))
3912         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3913         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3914         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3915 C Derivatives in gamma(i+1)
3916         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3917         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3918         s2=scalar2(b1(1,iti1),auxvec(1))
3919         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3920         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3921         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3923 C Derivatives in gamma(i+2)
3924         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3925         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3926         s1=scalar2(b1(1,iti2),auxvec(1))
3927         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3928         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3929         s2=scalar2(b1(1,iti1),auxvec(1))
3930         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3931         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3932         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3933         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3934 C Cartesian derivatives
3935 C Derivatives of this turn contributions in DC(i+2)
3936         if (j.lt.nres-1) then
3937           do l=1,3
3938             a_temp(1,1)=agg(l,1)
3939             a_temp(1,2)=agg(l,2)
3940             a_temp(2,1)=agg(l,3)
3941             a_temp(2,2)=agg(l,4)
3942             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3943             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3944             s1=scalar2(b1(1,iti2),auxvec(1))
3945             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3946             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3947             s2=scalar2(b1(1,iti1),auxvec(1))
3948             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3949             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3950             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3951             ggg(l)=-(s1+s2+s3)
3952             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3953           enddo
3954         endif
3955 C Remaining derivatives of this turn contribution
3956         do l=1,3
3957           a_temp(1,1)=aggi(l,1)
3958           a_temp(1,2)=aggi(l,2)
3959           a_temp(2,1)=aggi(l,3)
3960           a_temp(2,2)=aggi(l,4)
3961           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3962           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3963           s1=scalar2(b1(1,iti2),auxvec(1))
3964           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3965           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3966           s2=scalar2(b1(1,iti1),auxvec(1))
3967           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3968           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3969           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3970           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3971           a_temp(1,1)=aggi1(l,1)
3972           a_temp(1,2)=aggi1(l,2)
3973           a_temp(2,1)=aggi1(l,3)
3974           a_temp(2,2)=aggi1(l,4)
3975           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977           s1=scalar2(b1(1,iti2),auxvec(1))
3978           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980           s2=scalar2(b1(1,iti1),auxvec(1))
3981           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3985           a_temp(1,1)=aggj(l,1)
3986           a_temp(1,2)=aggj(l,2)
3987           a_temp(2,1)=aggj(l,3)
3988           a_temp(2,2)=aggj(l,4)
3989           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3990           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3991           s1=scalar2(b1(1,iti2),auxvec(1))
3992           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3993           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3994           s2=scalar2(b1(1,iti1),auxvec(1))
3995           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3996           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3997           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3998           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3999           a_temp(1,1)=aggj1(l,1)
4000           a_temp(1,2)=aggj1(l,2)
4001           a_temp(2,1)=aggj1(l,3)
4002           a_temp(2,2)=aggj1(l,4)
4003           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4004           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4005           s1=scalar2(b1(1,iti2),auxvec(1))
4006           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4007           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4008           s2=scalar2(b1(1,iti1),auxvec(1))
4009           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4010           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4011           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4012 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4013           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4014         enddo
4015       return
4016       end
4017 C-----------------------------------------------------------------------------
4018       subroutine vecpr(u,v,w)
4019       implicit real*8(a-h,o-z)
4020       dimension u(3),v(3),w(3)
4021       w(1)=u(2)*v(3)-u(3)*v(2)
4022       w(2)=-u(1)*v(3)+u(3)*v(1)
4023       w(3)=u(1)*v(2)-u(2)*v(1)
4024       return
4025       end
4026 C-----------------------------------------------------------------------------
4027       subroutine unormderiv(u,ugrad,unorm,ungrad)
4028 C This subroutine computes the derivatives of a normalized vector u, given
4029 C the derivatives computed without normalization conditions, ugrad. Returns
4030 C ungrad.
4031       implicit none
4032       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4033       double precision vec(3)
4034       double precision scalar
4035       integer i,j
4036 c      write (2,*) 'ugrad',ugrad
4037 c      write (2,*) 'u',u
4038       do i=1,3
4039         vec(i)=scalar(ugrad(1,i),u(1))
4040       enddo
4041 c      write (2,*) 'vec',vec
4042       do i=1,3
4043         do j=1,3
4044           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4045         enddo
4046       enddo
4047 c      write (2,*) 'ungrad',ungrad
4048       return
4049       end
4050 C-----------------------------------------------------------------------------
4051       subroutine escp_soft_sphere(evdw2,evdw2_14)
4052 C
4053 C This subroutine calculates the excluded-volume interaction energy between
4054 C peptide-group centers and side chains and its gradient in virtual-bond and
4055 C side-chain vectors.
4056 C
4057       implicit real*8 (a-h,o-z)
4058       include 'DIMENSIONS'
4059       include 'COMMON.GEO'
4060       include 'COMMON.VAR'
4061       include 'COMMON.LOCAL'
4062       include 'COMMON.CHAIN'
4063       include 'COMMON.DERIV'
4064       include 'COMMON.INTERACT'
4065       include 'COMMON.FFIELD'
4066       include 'COMMON.IOUNITS'
4067       include 'COMMON.CONTROL'
4068       dimension ggg(3)
4069       evdw2=0.0D0
4070       evdw2_14=0.0d0
4071       r0_scp=4.5d0
4072 cd    print '(a)','Enter ESCP'
4073 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4074       do i=iatscp_s,iatscp_e
4075         iteli=itel(i)
4076         xi=0.5D0*(c(1,i)+c(1,i+1))
4077         yi=0.5D0*(c(2,i)+c(2,i+1))
4078         zi=0.5D0*(c(3,i)+c(3,i+1))
4079
4080         do iint=1,nscp_gr(i)
4081
4082         do j=iscpstart(i,iint),iscpend(i,iint)
4083           itypj=itype(j)
4084 C Uncomment following three lines for SC-p interactions
4085 c         xj=c(1,nres+j)-xi
4086 c         yj=c(2,nres+j)-yi
4087 c         zj=c(3,nres+j)-zi
4088 C Uncomment following three lines for Ca-p interactions
4089           xj=c(1,j)-xi
4090           yj=c(2,j)-yi
4091           zj=c(3,j)-zi
4092           rij=xj*xj+yj*yj+zj*zj
4093           r0ij=r0_scp
4094           r0ijsq=r0ij*r0ij
4095           if (rij.lt.r0ijsq) then
4096             evdwij=0.25d0*(rij-r0ijsq)**2
4097             fac=rij-r0ijsq
4098           else
4099             evdwij=0.0d0
4100             fac=0.0d0
4101           endif
4102           evdw2=evdw2+evdwij
4103 C
4104 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4105 C
4106           ggg(1)=xj*fac
4107           ggg(2)=yj*fac
4108           ggg(3)=zj*fac
4109 cgrad          if (j.lt.i) then
4110 cd          write (iout,*) 'j<i'
4111 C Uncomment following three lines for SC-p interactions
4112 c           do k=1,3
4113 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4114 c           enddo
4115 cgrad          else
4116 cd          write (iout,*) 'j>i'
4117 cgrad            do k=1,3
4118 cgrad              ggg(k)=-ggg(k)
4119 C Uncomment following line for SC-p interactions
4120 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4121 cgrad            enddo
4122 cgrad          endif
4123 cgrad          do k=1,3
4124 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4125 cgrad          enddo
4126 cgrad          kstart=min0(i+1,j)
4127 cgrad          kend=max0(i-1,j-1)
4128 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4129 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4130 cgrad          do k=kstart,kend
4131 cgrad            do l=1,3
4132 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4133 cgrad            enddo
4134 cgrad          enddo
4135           do k=1,3
4136             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4137             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4138           enddo
4139         enddo
4140
4141         enddo ! iint
4142       enddo ! i
4143       return
4144       end
4145 C-----------------------------------------------------------------------------
4146       subroutine escp(evdw2,evdw2_14)
4147 C
4148 C This subroutine calculates the excluded-volume interaction energy between
4149 C peptide-group centers and side chains and its gradient in virtual-bond and
4150 C side-chain vectors.
4151 C
4152       implicit real*8 (a-h,o-z)
4153       include 'DIMENSIONS'
4154       include 'COMMON.GEO'
4155       include 'COMMON.VAR'
4156       include 'COMMON.LOCAL'
4157       include 'COMMON.CHAIN'
4158       include 'COMMON.DERIV'
4159       include 'COMMON.INTERACT'
4160       include 'COMMON.FFIELD'
4161       include 'COMMON.IOUNITS'
4162       include 'COMMON.CONTROL'
4163       dimension ggg(3)
4164       evdw2=0.0D0
4165       evdw2_14=0.0d0
4166 cd    print '(a)','Enter ESCP'
4167 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4168       do i=iatscp_s,iatscp_e
4169         iteli=itel(i)
4170         xi=0.5D0*(c(1,i)+c(1,i+1))
4171         yi=0.5D0*(c(2,i)+c(2,i+1))
4172         zi=0.5D0*(c(3,i)+c(3,i+1))
4173
4174         do iint=1,nscp_gr(i)
4175
4176         do j=iscpstart(i,iint),iscpend(i,iint)
4177           itypj=itype(j)
4178 C Uncomment following three lines for SC-p interactions
4179 c         xj=c(1,nres+j)-xi
4180 c         yj=c(2,nres+j)-yi
4181 c         zj=c(3,nres+j)-zi
4182 C Uncomment following three lines for Ca-p interactions
4183           xj=c(1,j)-xi
4184           yj=c(2,j)-yi
4185           zj=c(3,j)-zi
4186           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4187           fac=rrij**expon2
4188           e1=fac*fac*aad(itypj,iteli)
4189           e2=fac*bad(itypj,iteli)
4190           if (iabs(j-i) .le. 2) then
4191             e1=scal14*e1
4192             e2=scal14*e2
4193             evdw2_14=evdw2_14+e1+e2
4194           endif
4195           evdwij=e1+e2
4196           evdw2=evdw2+evdwij
4197           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4198      &        'evdw2',i,j,evdwij
4199 C
4200 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4201 C
4202           fac=-(evdwij+e1)*rrij
4203           ggg(1)=xj*fac
4204           ggg(2)=yj*fac
4205           ggg(3)=zj*fac
4206 cgrad          if (j.lt.i) then
4207 cd          write (iout,*) 'j<i'
4208 C Uncomment following three lines for SC-p interactions
4209 c           do k=1,3
4210 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4211 c           enddo
4212 cgrad          else
4213 cd          write (iout,*) 'j>i'
4214 cgrad            do k=1,3
4215 cgrad              ggg(k)=-ggg(k)
4216 C Uncomment following line for SC-p interactions
4217 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4218 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4219 cgrad            enddo
4220 cgrad          endif
4221 cgrad          do k=1,3
4222 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4223 cgrad          enddo
4224 cgrad          kstart=min0(i+1,j)
4225 cgrad          kend=max0(i-1,j-1)
4226 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4227 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4228 cgrad          do k=kstart,kend
4229 cgrad            do l=1,3
4230 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4231 cgrad            enddo
4232 cgrad          enddo
4233           do k=1,3
4234             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4235             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4236           enddo
4237         enddo
4238
4239         enddo ! iint
4240       enddo ! i
4241       do i=1,nct
4242         do j=1,3
4243           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4244           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4245           gradx_scp(j,i)=expon*gradx_scp(j,i)
4246         enddo
4247       enddo
4248 C******************************************************************************
4249 C
4250 C                              N O T E !!!
4251 C
4252 C To save time the factor EXPON has been extracted from ALL components
4253 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4254 C use!
4255 C
4256 C******************************************************************************
4257       return
4258       end
4259 C--------------------------------------------------------------------------
4260       subroutine edis(ehpb)
4261 C
4262 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4263 C
4264       implicit real*8 (a-h,o-z)
4265       include 'DIMENSIONS'
4266       include 'COMMON.SBRIDGE'
4267       include 'COMMON.CHAIN'
4268       include 'COMMON.DERIV'
4269       include 'COMMON.VAR'
4270       include 'COMMON.INTERACT'
4271       include 'COMMON.IOUNITS'
4272       dimension ggg(3)
4273       ehpb=0.0D0
4274 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4275 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4276       if (link_end.eq.0) return
4277       do i=link_start,link_end
4278 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4279 C CA-CA distance used in regularization of structure.
4280         ii=ihpb(i)
4281         jj=jhpb(i)
4282 C iii and jjj point to the residues for which the distance is assigned.
4283         if (ii.gt.nres) then
4284           iii=ii-nres
4285           jjj=jj-nres
4286         else
4287           iii=ii
4288           jjj=jj
4289         endif
4290 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4291 c     &    dhpb(i),dhpb1(i),forcon(i)
4292 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4293 C    distance and angle dependent SS bond potential.
4294 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4295 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4296         if (.not.dyn_ss .and. i.le.nss) then
4297 C 15/02/13 CC dynamic SSbond - additional check
4298          if (ii.gt.nres
4299      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4300           call ssbond_ene(iii,jjj,eij)
4301           ehpb=ehpb+2*eij
4302          endif
4303 cd          write (iout,*) "eij",eij
4304         else if (ii.gt.nres .and. jj.gt.nres) then
4305 c Restraints from contact prediction
4306           dd=dist(ii,jj)
4307           if (dhpb1(i).gt.0.0d0) then
4308             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4309             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4310 c            write (iout,*) "beta nmr",
4311 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4312           else
4313             dd=dist(ii,jj)
4314             rdis=dd-dhpb(i)
4315 C Get the force constant corresponding to this distance.
4316             waga=forcon(i)
4317 C Calculate the contribution to energy.
4318             ehpb=ehpb+waga*rdis*rdis
4319 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4320 C
4321 C Evaluate gradient.
4322 C
4323             fac=waga*rdis/dd
4324           endif
4325           do j=1,3
4326             ggg(j)=fac*(c(j,jj)-c(j,ii))
4327           enddo
4328           do j=1,3
4329             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4330             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4331           enddo
4332           do k=1,3
4333             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4334             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4335           enddo
4336         else
4337 C Calculate the distance between the two points and its difference from the
4338 C target distance.
4339           dd=dist(ii,jj)
4340           if (dhpb1(i).gt.0.0d0) then
4341             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4342             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4343 c            write (iout,*) "alph nmr",
4344 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4345           else
4346             rdis=dd-dhpb(i)
4347 C Get the force constant corresponding to this distance.
4348             waga=forcon(i)
4349 C Calculate the contribution to energy.
4350             ehpb=ehpb+waga*rdis*rdis
4351 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4352 C
4353 C Evaluate gradient.
4354 C
4355             fac=waga*rdis/dd
4356           endif
4357 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4358 cd   &   ' waga=',waga,' fac=',fac
4359             do j=1,3
4360               ggg(j)=fac*(c(j,jj)-c(j,ii))
4361             enddo
4362 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4363 C If this is a SC-SC distance, we need to calculate the contributions to the
4364 C Cartesian gradient in the SC vectors (ghpbx).
4365           if (iii.lt.ii) then
4366           do j=1,3
4367             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4368             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4369           enddo
4370           endif
4371 cgrad        do j=iii,jjj-1
4372 cgrad          do k=1,3
4373 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4374 cgrad          enddo
4375 cgrad        enddo
4376           do k=1,3
4377             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4378             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4379           enddo
4380         endif
4381       enddo
4382       ehpb=0.5D0*ehpb
4383       return
4384       end
4385 C--------------------------------------------------------------------------
4386       subroutine ssbond_ene(i,j,eij)
4387 C
4388 C Calculate the distance and angle dependent SS-bond potential energy
4389 C using a free-energy function derived based on RHF/6-31G** ab initio
4390 C calculations of diethyl disulfide.
4391 C
4392 C A. Liwo and U. Kozlowska, 11/24/03
4393 C
4394       implicit real*8 (a-h,o-z)
4395       include 'DIMENSIONS'
4396       include 'COMMON.SBRIDGE'
4397       include 'COMMON.CHAIN'
4398       include 'COMMON.DERIV'
4399       include 'COMMON.LOCAL'
4400       include 'COMMON.INTERACT'
4401       include 'COMMON.VAR'
4402       include 'COMMON.IOUNITS'
4403       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4404       itypi=itype(i)
4405       xi=c(1,nres+i)
4406       yi=c(2,nres+i)
4407       zi=c(3,nres+i)
4408       dxi=dc_norm(1,nres+i)
4409       dyi=dc_norm(2,nres+i)
4410       dzi=dc_norm(3,nres+i)
4411 c      dsci_inv=dsc_inv(itypi)
4412       dsci_inv=vbld_inv(nres+i)
4413       itypj=itype(j)
4414 c      dscj_inv=dsc_inv(itypj)
4415       dscj_inv=vbld_inv(nres+j)
4416       xj=c(1,nres+j)-xi
4417       yj=c(2,nres+j)-yi
4418       zj=c(3,nres+j)-zi
4419       dxj=dc_norm(1,nres+j)
4420       dyj=dc_norm(2,nres+j)
4421       dzj=dc_norm(3,nres+j)
4422       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4423       rij=dsqrt(rrij)
4424       erij(1)=xj*rij
4425       erij(2)=yj*rij
4426       erij(3)=zj*rij
4427       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4428       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4429       om12=dxi*dxj+dyi*dyj+dzi*dzj
4430       do k=1,3
4431         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4432         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4433       enddo
4434       rij=1.0d0/rij
4435       deltad=rij-d0cm
4436       deltat1=1.0d0-om1
4437       deltat2=1.0d0+om2
4438       deltat12=om2-om1+2.0d0
4439       cosphi=om12-om1*om2
4440       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4441      &  +akct*deltad*deltat12+ebr
4442      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4443 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4444 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4445 c     &  " deltat12",deltat12," eij",eij
4446       ed=2*akcm*deltad+akct*deltat12
4447       pom1=akct*deltad
4448       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4449       eom1=-2*akth*deltat1-pom1-om2*pom2
4450       eom2= 2*akth*deltat2+pom1-om1*pom2
4451       eom12=pom2
4452       do k=1,3
4453         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4454         ghpbx(k,i)=ghpbx(k,i)-ggk
4455      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4456      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4457         ghpbx(k,j)=ghpbx(k,j)+ggk
4458      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4459      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4460         ghpbc(k,i)=ghpbc(k,i)-ggk
4461         ghpbc(k,j)=ghpbc(k,j)+ggk
4462       enddo
4463 C
4464 C Calculate the components of the gradient in DC and X
4465 C
4466 cgrad      do k=i,j-1
4467 cgrad        do l=1,3
4468 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4469 cgrad        enddo
4470 cgrad      enddo
4471       return
4472       end
4473 C--------------------------------------------------------------------------
4474       subroutine ebond(estr)
4475 c
4476 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4477 c
4478       implicit real*8 (a-h,o-z)
4479       include 'DIMENSIONS'
4480       include 'COMMON.LOCAL'
4481       include 'COMMON.GEO'
4482       include 'COMMON.INTERACT'
4483       include 'COMMON.DERIV'
4484       include 'COMMON.VAR'
4485       include 'COMMON.CHAIN'
4486       include 'COMMON.IOUNITS'
4487       include 'COMMON.NAMES'
4488       include 'COMMON.FFIELD'
4489       include 'COMMON.CONTROL'
4490       include 'COMMON.SETUP'
4491       double precision u(3),ud(3)
4492       estr=0.0d0
4493       do i=ibondp_start,ibondp_end
4494         diff = vbld(i)-vbldp0
4495 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4496         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4497      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4498         estr=estr+diff*diff
4499         do j=1,3
4500           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4501         enddo
4502 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4503       enddo
4504       estr=0.5d0*AKP*estr
4505 c
4506 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4507 c
4508       do i=ibond_start,ibond_end
4509         iti=itype(i)
4510         if (iti.ne.10) then
4511           nbi=nbondterm(iti)
4512           if (nbi.eq.1) then
4513             diff=vbld(i+nres)-vbldsc0(1,iti)
4514 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4515 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4516             if (energy_dec)  write (iout,*)
4517      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4518      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4519             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4520             do j=1,3
4521               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4522             enddo
4523           else
4524             do j=1,nbi
4525               diff=vbld(i+nres)-vbldsc0(j,iti)
4526               ud(j)=aksc(j,iti)*diff
4527               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4528             enddo
4529             uprod=u(1)
4530             do j=2,nbi
4531               uprod=uprod*u(j)
4532             enddo
4533             usum=0.0d0
4534             usumsqder=0.0d0
4535             do j=1,nbi
4536               uprod1=1.0d0
4537               uprod2=1.0d0
4538               do k=1,nbi
4539                 if (k.ne.j) then
4540                   uprod1=uprod1*u(k)
4541                   uprod2=uprod2*u(k)*u(k)
4542                 endif
4543               enddo
4544               usum=usum+uprod1
4545               usumsqder=usumsqder+ud(j)*uprod2
4546             enddo
4547             estr=estr+uprod/usum
4548             do j=1,3
4549              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4550             enddo
4551           endif
4552         endif
4553       enddo
4554       return
4555       end
4556 #ifdef CRYST_THETA
4557 C--------------------------------------------------------------------------
4558       subroutine ebend(etheta)
4559 C
4560 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4561 C angles gamma and its derivatives in consecutive thetas and gammas.
4562 C
4563       implicit real*8 (a-h,o-z)
4564       include 'DIMENSIONS'
4565       include 'COMMON.LOCAL'
4566       include 'COMMON.GEO'
4567       include 'COMMON.INTERACT'
4568       include 'COMMON.DERIV'
4569       include 'COMMON.VAR'
4570       include 'COMMON.CHAIN'
4571       include 'COMMON.IOUNITS'
4572       include 'COMMON.NAMES'
4573       include 'COMMON.FFIELD'
4574       include 'COMMON.CONTROL'
4575       common /calcthet/ term1,term2,termm,diffak,ratak,
4576      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4577      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4578       double precision y(2),z(2)
4579       delta=0.02d0*pi
4580 c      time11=dexp(-2*time)
4581 c      time12=1.0d0
4582       etheta=0.0D0
4583 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4584       do i=ithet_start,ithet_end
4585 C Zero the energy function and its derivative at 0 or pi.
4586         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4587         it=itype(i-1)
4588         if (i.gt.3) then
4589 #ifdef OSF
4590           phii=phi(i)
4591           if (phii.ne.phii) phii=150.0
4592 #else
4593           phii=phi(i)
4594 #endif
4595           y(1)=dcos(phii)
4596           y(2)=dsin(phii)
4597         else
4598           y(1)=0.0D0
4599           y(2)=0.0D0
4600         endif
4601         if (i.lt.nres) then
4602 #ifdef OSF
4603           phii1=phi(i+1)
4604           if (phii1.ne.phii1) phii1=150.0
4605           phii1=pinorm(phii1)
4606           z(1)=cos(phii1)
4607 #else
4608           phii1=phi(i+1)
4609           z(1)=dcos(phii1)
4610 #endif
4611           z(2)=dsin(phii1)
4612         else
4613           z(1)=0.0D0
4614           z(2)=0.0D0
4615         endif
4616 C Calculate the "mean" value of theta from the part of the distribution
4617 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4618 C In following comments this theta will be referred to as t_c.
4619         thet_pred_mean=0.0d0
4620         do k=1,2
4621           athetk=athet(k,it)
4622           bthetk=bthet(k,it)
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)*y(2)+athet(2,it)*y(1))*ss
4629         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4630         if (theta(i).gt.pi-delta) then
4631           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4632      &         E_tc0)
4633           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4634           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4635           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4636      &        E_theta)
4637           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4638      &        E_tc)
4639         else if (theta(i).lt.delta) then
4640           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4641           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4642           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4643      &        E_theta)
4644           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4645           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4646      &        E_tc)
4647         else
4648           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4649      &        E_theta,E_tc)
4650         endif
4651         etheta=etheta+ethetai
4652         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4653      &      'ebend',i,ethetai
4654         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4655         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4656         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4657       enddo
4658 C Ufff.... We've done all this!!!
4659       return
4660       end
4661 C---------------------------------------------------------------------------
4662       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4663      &     E_tc)
4664       implicit real*8 (a-h,o-z)
4665       include 'DIMENSIONS'
4666       include 'COMMON.LOCAL'
4667       include 'COMMON.IOUNITS'
4668       common /calcthet/ term1,term2,termm,diffak,ratak,
4669      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4670      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4671 C Calculate the contributions to both Gaussian lobes.
4672 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4673 C The "polynomial part" of the "standard deviation" of this part of
4674 C the distribution.
4675         sig=polthet(3,it)
4676         do j=2,0,-1
4677           sig=sig*thet_pred_mean+polthet(j,it)
4678         enddo
4679 C Derivative of the "interior part" of the "standard deviation of the"
4680 C gamma-dependent Gaussian lobe in t_c.
4681         sigtc=3*polthet(3,it)
4682         do j=2,1,-1
4683           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4684         enddo
4685         sigtc=sig*sigtc
4686 C Set the parameters of both Gaussian lobes of the distribution.
4687 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4688         fac=sig*sig+sigc0(it)
4689         sigcsq=fac+fac
4690         sigc=1.0D0/sigcsq
4691 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4692         sigsqtc=-4.0D0*sigcsq*sigtc
4693 c       print *,i,sig,sigtc,sigsqtc
4694 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4695         sigtc=-sigtc/(fac*fac)
4696 C Following variable is sigma(t_c)**(-2)
4697         sigcsq=sigcsq*sigcsq
4698         sig0i=sig0(it)
4699         sig0inv=1.0D0/sig0i**2
4700         delthec=thetai-thet_pred_mean
4701         delthe0=thetai-theta0i
4702         term1=-0.5D0*sigcsq*delthec*delthec
4703         term2=-0.5D0*sig0inv*delthe0*delthe0
4704 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4705 C NaNs in taking the logarithm. We extract the largest exponent which is added
4706 C to the energy (this being the log of the distribution) at the end of energy
4707 C term evaluation for this virtual-bond angle.
4708         if (term1.gt.term2) then
4709           termm=term1
4710           term2=dexp(term2-termm)
4711           term1=1.0d0
4712         else
4713           termm=term2
4714           term1=dexp(term1-termm)
4715           term2=1.0d0
4716         endif
4717 C The ratio between the gamma-independent and gamma-dependent lobes of
4718 C the distribution is a Gaussian function of thet_pred_mean too.
4719         diffak=gthet(2,it)-thet_pred_mean
4720         ratak=diffak/gthet(3,it)**2
4721         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4722 C Let's differentiate it in thet_pred_mean NOW.
4723         aktc=ak*ratak
4724 C Now put together the distribution terms to make complete distribution.
4725         termexp=term1+ak*term2
4726         termpre=sigc+ak*sig0i
4727 C Contribution of the bending energy from this theta is just the -log of
4728 C the sum of the contributions from the two lobes and the pre-exponential
4729 C factor. Simple enough, isn't it?
4730         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4731 C NOW the derivatives!!!
4732 C 6/6/97 Take into account the deformation.
4733         E_theta=(delthec*sigcsq*term1
4734      &       +ak*delthe0*sig0inv*term2)/termexp
4735         E_tc=((sigtc+aktc*sig0i)/termpre
4736      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4737      &       aktc*term2)/termexp)
4738       return
4739       end
4740 c-----------------------------------------------------------------------------
4741       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4742       implicit real*8 (a-h,o-z)
4743       include 'DIMENSIONS'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.IOUNITS'
4746       common /calcthet/ term1,term2,termm,diffak,ratak,
4747      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4748      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4749       delthec=thetai-thet_pred_mean
4750       delthe0=thetai-theta0i
4751 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4752       t3 = thetai-thet_pred_mean
4753       t6 = t3**2
4754       t9 = term1
4755       t12 = t3*sigcsq
4756       t14 = t12+t6*sigsqtc
4757       t16 = 1.0d0
4758       t21 = thetai-theta0i
4759       t23 = t21**2
4760       t26 = term2
4761       t27 = t21*t26
4762       t32 = termexp
4763       t40 = t32**2
4764       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4765      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4766      & *(-t12*t9-ak*sig0inv*t27)
4767       return
4768       end
4769 #else
4770 C--------------------------------------------------------------------------
4771       subroutine ebend(etheta)
4772 C
4773 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4774 C angles gamma and its derivatives in consecutive thetas and gammas.
4775 C ab initio-derived potentials from
4776 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4777 C
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.LOCAL'
4781       include 'COMMON.GEO'
4782       include 'COMMON.INTERACT'
4783       include 'COMMON.DERIV'
4784       include 'COMMON.VAR'
4785       include 'COMMON.CHAIN'
4786       include 'COMMON.IOUNITS'
4787       include 'COMMON.NAMES'
4788       include 'COMMON.FFIELD'
4789       include 'COMMON.CONTROL'
4790       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4791      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4792      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4793      & sinph1ph2(maxdouble,maxdouble)
4794       logical lprn /.false./, lprn1 /.false./
4795       etheta=0.0D0
4796       do i=ithet_start,ithet_end
4797         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4798      &(itype(i).eq.ntyp1)) cycle
4799         dethetai=0.0d0
4800         dephii=0.0d0
4801         dephii1=0.0d0
4802         theti2=0.5d0*theta(i)
4803         ityp2=ithetyp(itype(i-1))
4804         do k=1,nntheterm
4805           coskt(k)=dcos(k*theti2)
4806           sinkt(k)=dsin(k*theti2)
4807         enddo
4808 C        if (i.gt.3) then
4809          if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4810 #ifdef OSF
4811           phii=phi(i)
4812           if (phii.ne.phii) phii=150.0
4813 #else
4814           phii=phi(i)
4815 #endif
4816           ityp1=ithetyp(itype(i-2))
4817           do k=1,nsingle
4818             cosph1(k)=dcos(k*phii)
4819             sinph1(k)=dsin(k*phii)
4820           enddo
4821         else
4822           phii=0.0d0
4823           ityp1=ithetyp(itype(i-2))
4824           do k=1,nsingle
4825             cosph1(k)=0.0d0
4826             sinph1(k)=0.0d0
4827           enddo
4828         endif
4829         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4830 #ifdef OSF
4831           phii1=phi(i+1)
4832           if (phii1.ne.phii1) phii1=150.0
4833           phii1=pinorm(phii1)
4834 #else
4835           phii1=phi(i+1)
4836 #endif
4837           ityp3=ithetyp(itype(i))
4838           do k=1,nsingle
4839             cosph2(k)=dcos(k*phii1)
4840             sinph2(k)=dsin(k*phii1)
4841           enddo
4842         else
4843           phii1=0.0d0
4844           ityp3=ithetyp(itype(i))
4845           do k=1,nsingle
4846             cosph2(k)=0.0d0
4847             sinph2(k)=0.0d0
4848           enddo
4849         endif
4850         ethetai=aa0thet(ityp1,ityp2,ityp3)
4851         do k=1,ndouble
4852           do l=1,k-1
4853             ccl=cosph1(l)*cosph2(k-l)
4854             ssl=sinph1(l)*sinph2(k-l)
4855             scl=sinph1(l)*cosph2(k-l)
4856             csl=cosph1(l)*sinph2(k-l)
4857             cosph1ph2(l,k)=ccl-ssl
4858             cosph1ph2(k,l)=ccl+ssl
4859             sinph1ph2(l,k)=scl+csl
4860             sinph1ph2(k,l)=scl-csl
4861           enddo
4862         enddo
4863         if (lprn) then
4864         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4865      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4866         write (iout,*) "coskt and sinkt"
4867         do k=1,nntheterm
4868           write (iout,*) k,coskt(k),sinkt(k)
4869         enddo
4870         endif
4871         do k=1,ntheterm
4872           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4873           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4874      &      *coskt(k)
4875           if (lprn)
4876      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4877      &     " ethetai",ethetai
4878         enddo
4879         if (lprn) then
4880         write (iout,*) "cosph and sinph"
4881         do k=1,nsingle
4882           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4883         enddo
4884         write (iout,*) "cosph1ph2 and sinph2ph2"
4885         do k=2,ndouble
4886           do l=1,k-1
4887             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4888      &         sinph1ph2(l,k),sinph1ph2(k,l)
4889           enddo
4890         enddo
4891         write(iout,*) "ethetai",ethetai
4892         endif
4893         do m=1,ntheterm2
4894           do k=1,nsingle
4895             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4896      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4897      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4898      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4899             ethetai=ethetai+sinkt(m)*aux
4900             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4901             dephii=dephii+k*sinkt(m)*(
4902      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4903      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4904             dephii1=dephii1+k*sinkt(m)*(
4905      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4906      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4907             if (lprn)
4908      &      write (iout,*) "m",m," k",k," bbthet",
4909      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4910      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4911      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4912      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4913           enddo
4914         enddo
4915         if (lprn)
4916      &  write(iout,*) "ethetai",ethetai
4917         do m=1,ntheterm3
4918           do k=2,ndouble
4919             do l=1,k-1
4920               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4921      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4922      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4923      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4924               ethetai=ethetai+sinkt(m)*aux
4925               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4926               dephii=dephii+l*sinkt(m)*(
4927      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4928      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4929      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4930      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4931               dephii1=dephii1+(k-l)*sinkt(m)*(
4932      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4933      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4934      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4935      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4936               if (lprn) then
4937               write (iout,*) "m",m," k",k," l",l," ffthet",
4938      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4939      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4940      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4941      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4942               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4943      &            cosph1ph2(k,l)*sinkt(m),
4944      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4945               endif
4946             enddo
4947           enddo
4948         enddo
4949 10      continue
4950         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4951      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4952      &   phii1*rad2deg,ethetai
4953         etheta=etheta+ethetai
4954         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4955      &      'ebend',i,ethetai
4956         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4957         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4958         gloc(nphi+i-2,icg)=wang*dethetai
4959       enddo
4960       return
4961       end
4962 #endif
4963 #ifdef CRYST_SC
4964 c-----------------------------------------------------------------------------
4965       subroutine esc(escloc)
4966 C Calculate the local energy of a side chain and its derivatives in the
4967 C corresponding virtual-bond valence angles THETA and the spherical angles
4968 C ALPHA and OMEGA.
4969       implicit real*8 (a-h,o-z)
4970       include 'DIMENSIONS'
4971       include 'COMMON.GEO'
4972       include 'COMMON.LOCAL'
4973       include 'COMMON.VAR'
4974       include 'COMMON.INTERACT'
4975       include 'COMMON.DERIV'
4976       include 'COMMON.CHAIN'
4977       include 'COMMON.IOUNITS'
4978       include 'COMMON.NAMES'
4979       include 'COMMON.FFIELD'
4980       include 'COMMON.CONTROL'
4981       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4982      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4983       common /sccalc/ time11,time12,time112,theti,it,nlobit
4984       delta=0.02d0*pi
4985       escloc=0.0D0
4986 c     write (iout,'(a)') 'ESC'
4987       do i=loc_start,loc_end
4988         it=itype(i)
4989         if (it.eq.10) goto 1
4990         nlobit=nlob(it)
4991 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4992 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4993         theti=theta(i+1)-pipol
4994         x(1)=dtan(theti)
4995         x(2)=alph(i)
4996         x(3)=omeg(i)
4997
4998         if (x(2).gt.pi-delta) then
4999           xtemp(1)=x(1)
5000           xtemp(2)=pi-delta
5001           xtemp(3)=x(3)
5002           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5003           xtemp(2)=pi
5004           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5005           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5006      &        escloci,dersc(2))
5007           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5008      &        ddersc0(1),dersc(1))
5009           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5010      &        ddersc0(3),dersc(3))
5011           xtemp(2)=pi-delta
5012           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5013           xtemp(2)=pi
5014           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5015           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5016      &            dersc0(2),esclocbi,dersc02)
5017           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5018      &            dersc12,dersc01)
5019           call splinthet(x(2),0.5d0*delta,ss,ssd)
5020           dersc0(1)=dersc01
5021           dersc0(2)=dersc02
5022           dersc0(3)=0.0d0
5023           do k=1,3
5024             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5025           enddo
5026           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5027 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5028 c    &             esclocbi,ss,ssd
5029           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5030 c         escloci=esclocbi
5031 c         write (iout,*) escloci
5032         else if (x(2).lt.delta) then
5033           xtemp(1)=x(1)
5034           xtemp(2)=delta
5035           xtemp(3)=x(3)
5036           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5037           xtemp(2)=0.0d0
5038           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5039           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5040      &        escloci,dersc(2))
5041           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5042      &        ddersc0(1),dersc(1))
5043           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5044      &        ddersc0(3),dersc(3))
5045           xtemp(2)=delta
5046           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5047           xtemp(2)=0.0d0
5048           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5049           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5050      &            dersc0(2),esclocbi,dersc02)
5051           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5052      &            dersc12,dersc01)
5053           dersc0(1)=dersc01
5054           dersc0(2)=dersc02
5055           dersc0(3)=0.0d0
5056           call splinthet(x(2),0.5d0*delta,ss,ssd)
5057           do k=1,3
5058             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5059           enddo
5060           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5061 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5062 c    &             esclocbi,ss,ssd
5063           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5064 c         write (iout,*) escloci
5065         else
5066           call enesc(x,escloci,dersc,ddummy,.false.)
5067         endif
5068
5069         escloc=escloc+escloci
5070         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5071      &     'escloc',i,escloci
5072 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5073
5074         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5075      &   wscloc*dersc(1)
5076         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5077         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5078     1   continue
5079       enddo
5080       return
5081       end
5082 C---------------------------------------------------------------------------
5083       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5084       implicit real*8 (a-h,o-z)
5085       include 'DIMENSIONS'
5086       include 'COMMON.GEO'
5087       include 'COMMON.LOCAL'
5088       include 'COMMON.IOUNITS'
5089       common /sccalc/ time11,time12,time112,theti,it,nlobit
5090       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5091       double precision contr(maxlob,-1:1)
5092       logical mixed
5093 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5094         escloc_i=0.0D0
5095         do j=1,3
5096           dersc(j)=0.0D0
5097           if (mixed) ddersc(j)=0.0d0
5098         enddo
5099         x3=x(3)
5100
5101 C Because of periodicity of the dependence of the SC energy in omega we have
5102 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5103 C To avoid underflows, first compute & store the exponents.
5104
5105         do iii=-1,1
5106
5107           x(3)=x3+iii*dwapi
5108
5109           do j=1,nlobit
5110             do k=1,3
5111               z(k)=x(k)-censc(k,j,it)
5112             enddo
5113             do k=1,3
5114               Axk=0.0D0
5115               do l=1,3
5116                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5117               enddo
5118               Ax(k,j,iii)=Axk
5119             enddo
5120             expfac=0.0D0
5121             do k=1,3
5122               expfac=expfac+Ax(k,j,iii)*z(k)
5123             enddo
5124             contr(j,iii)=expfac
5125           enddo ! j
5126
5127         enddo ! iii
5128
5129         x(3)=x3
5130 C As in the case of ebend, we want to avoid underflows in exponentiation and
5131 C subsequent NaNs and INFs in energy calculation.
5132 C Find the largest exponent
5133         emin=contr(1,-1)
5134         do iii=-1,1
5135           do j=1,nlobit
5136             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5137           enddo
5138         enddo
5139         emin=0.5D0*emin
5140 cd      print *,'it=',it,' emin=',emin
5141
5142 C Compute the contribution to SC energy and derivatives
5143         do iii=-1,1
5144
5145           do j=1,nlobit
5146 #ifdef OSF
5147             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5148             if(adexp.ne.adexp) adexp=1.0
5149             expfac=dexp(adexp)
5150 #else
5151             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5152 #endif
5153 cd          print *,'j=',j,' expfac=',expfac
5154             escloc_i=escloc_i+expfac
5155             do k=1,3
5156               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5157             enddo
5158             if (mixed) then
5159               do k=1,3,2
5160                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5161      &            +gaussc(k,2,j,it))*expfac
5162               enddo
5163             endif
5164           enddo
5165
5166         enddo ! iii
5167
5168         dersc(1)=dersc(1)/cos(theti)**2
5169         ddersc(1)=ddersc(1)/cos(theti)**2
5170         ddersc(3)=ddersc(3)
5171
5172         escloci=-(dlog(escloc_i)-emin)
5173         do j=1,3
5174           dersc(j)=dersc(j)/escloc_i
5175         enddo
5176         if (mixed) then
5177           do j=1,3,2
5178             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5179           enddo
5180         endif
5181       return
5182       end
5183 C------------------------------------------------------------------------------
5184       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5185       implicit real*8 (a-h,o-z)
5186       include 'DIMENSIONS'
5187       include 'COMMON.GEO'
5188       include 'COMMON.LOCAL'
5189       include 'COMMON.IOUNITS'
5190       common /sccalc/ time11,time12,time112,theti,it,nlobit
5191       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5192       double precision contr(maxlob)
5193       logical mixed
5194
5195       escloc_i=0.0D0
5196
5197       do j=1,3
5198         dersc(j)=0.0D0
5199       enddo
5200
5201       do j=1,nlobit
5202         do k=1,2
5203           z(k)=x(k)-censc(k,j,it)
5204         enddo
5205         z(3)=dwapi
5206         do k=1,3
5207           Axk=0.0D0
5208           do l=1,3
5209             Axk=Axk+gaussc(l,k,j,it)*z(l)
5210           enddo
5211           Ax(k,j)=Axk
5212         enddo
5213         expfac=0.0D0
5214         do k=1,3
5215           expfac=expfac+Ax(k,j)*z(k)
5216         enddo
5217         contr(j)=expfac
5218       enddo ! j
5219
5220 C As in the case of ebend, we want to avoid underflows in exponentiation and
5221 C subsequent NaNs and INFs in energy calculation.
5222 C Find the largest exponent
5223       emin=contr(1)
5224       do j=1,nlobit
5225         if (emin.gt.contr(j)) emin=contr(j)
5226       enddo
5227       emin=0.5D0*emin
5228
5229 C Compute the contribution to SC energy and derivatives
5230
5231       dersc12=0.0d0
5232       do j=1,nlobit
5233         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5234         escloc_i=escloc_i+expfac
5235         do k=1,2
5236           dersc(k)=dersc(k)+Ax(k,j)*expfac
5237         enddo
5238         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5239      &            +gaussc(1,2,j,it))*expfac
5240         dersc(3)=0.0d0
5241       enddo
5242
5243       dersc(1)=dersc(1)/cos(theti)**2
5244       dersc12=dersc12/cos(theti)**2
5245       escloci=-(dlog(escloc_i)-emin)
5246       do j=1,2
5247         dersc(j)=dersc(j)/escloc_i
5248       enddo
5249       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5250       return
5251       end
5252 #else
5253 c----------------------------------------------------------------------------------
5254       subroutine esc(escloc)
5255 C Calculate the local energy of a side chain and its derivatives in the
5256 C corresponding virtual-bond valence angles THETA and the spherical angles
5257 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5258 C added by Urszula Kozlowska. 07/11/2007
5259 C
5260       implicit real*8 (a-h,o-z)
5261       include 'DIMENSIONS'
5262       include 'COMMON.GEO'
5263       include 'COMMON.LOCAL'
5264       include 'COMMON.VAR'
5265       include 'COMMON.SCROT'
5266       include 'COMMON.INTERACT'
5267       include 'COMMON.DERIV'
5268       include 'COMMON.CHAIN'
5269       include 'COMMON.IOUNITS'
5270       include 'COMMON.NAMES'
5271       include 'COMMON.FFIELD'
5272       include 'COMMON.CONTROL'
5273       include 'COMMON.VECTORS'
5274       double precision x_prime(3),y_prime(3),z_prime(3)
5275      &    , sumene,dsc_i,dp2_i,x(65),
5276      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5277      &    de_dxx,de_dyy,de_dzz,de_dt
5278       double precision s1_t,s1_6_t,s2_t,s2_6_t
5279       double precision
5280      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5281      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5282      & dt_dCi(3),dt_dCi1(3)
5283       common /sccalc/ time11,time12,time112,theti,it,nlobit
5284       delta=0.02d0*pi
5285       escloc=0.0D0
5286       do i=loc_start,loc_end
5287         costtab(i+1) =dcos(theta(i+1))
5288         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5289         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5290         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5291         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5292         cosfac=dsqrt(cosfac2)
5293         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5294         sinfac=dsqrt(sinfac2)
5295         it=itype(i)
5296         if (it.eq.10) goto 1
5297 c
5298 C  Compute the axes of tghe local cartesian coordinates system; store in
5299 c   x_prime, y_prime and z_prime
5300 c
5301         do j=1,3
5302           x_prime(j) = 0.00
5303           y_prime(j) = 0.00
5304           z_prime(j) = 0.00
5305         enddo
5306 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5307 C     &   dc_norm(3,i+nres)
5308         do j = 1,3
5309           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5310           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5311         enddo
5312         do j = 1,3
5313           z_prime(j) = -uz(j,i-1)
5314         enddo
5315 c       write (2,*) "i",i
5316 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5317 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5318 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5319 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5320 c      & " xy",scalar(x_prime(1),y_prime(1)),
5321 c      & " xz",scalar(x_prime(1),z_prime(1)),
5322 c      & " yy",scalar(y_prime(1),y_prime(1)),
5323 c      & " yz",scalar(y_prime(1),z_prime(1)),
5324 c      & " zz",scalar(z_prime(1),z_prime(1))
5325 c
5326 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5327 C to local coordinate system. Store in xx, yy, zz.
5328 c
5329         xx=0.0d0
5330         yy=0.0d0
5331         zz=0.0d0
5332         do j = 1,3
5333           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5334           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5335           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5336         enddo
5337
5338         xxtab(i)=xx
5339         yytab(i)=yy
5340         zztab(i)=zz
5341 C
5342 C Compute the energy of the ith side cbain
5343 C
5344 c        write (2,*) "xx",xx," yy",yy," zz",zz
5345         it=itype(i)
5346         do j = 1,65
5347           x(j) = sc_parmin(j,it)
5348         enddo
5349 #ifdef CHECK_COORD
5350 Cc diagnostics - remove later
5351         xx1 = dcos(alph(2))
5352         yy1 = dsin(alph(2))*dcos(omeg(2))
5353         zz1 = -dsin(alph(2))*dsin(omeg(2))
5354         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5355      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5356      &    xx1,yy1,zz1
5357 C,"  --- ", xx_w,yy_w,zz_w
5358 c end diagnostics
5359 #endif
5360         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5361      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5362      &   + x(10)*yy*zz
5363         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5364      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5365      & + x(20)*yy*zz
5366         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5367      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5368      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5369      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5370      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5371      &  +x(40)*xx*yy*zz
5372         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5373      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5374      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5375      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5376      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5377      &  +x(60)*xx*yy*zz
5378         dsc_i   = 0.743d0+x(61)
5379         dp2_i   = 1.9d0+x(62)
5380         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5381      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5382         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5383      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5384         s1=(1+x(63))/(0.1d0 + dscp1)
5385         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5386         s2=(1+x(65))/(0.1d0 + dscp2)
5387         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5388         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5389      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5390 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5391 c     &   sumene4,
5392 c     &   dscp1,dscp2,sumene
5393 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         escloc = escloc + sumene
5395 c        write (2,*) "i",i," escloc",sumene,escloc
5396 #ifdef DEBUG
5397 C
5398 C This section to check the numerical derivatives of the energy of ith side
5399 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5400 C #define DEBUG in the code to turn it on.
5401 C
5402         write (2,*) "sumene               =",sumene
5403         aincr=1.0d-7
5404         xxsave=xx
5405         xx=xx+aincr
5406         write (2,*) xx,yy,zz
5407         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5408         de_dxx_num=(sumenep-sumene)/aincr
5409         xx=xxsave
5410         write (2,*) "xx+ sumene from enesc=",sumenep
5411         yysave=yy
5412         yy=yy+aincr
5413         write (2,*) xx,yy,zz
5414         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5415         de_dyy_num=(sumenep-sumene)/aincr
5416         yy=yysave
5417         write (2,*) "yy+ sumene from enesc=",sumenep
5418         zzsave=zz
5419         zz=zz+aincr
5420         write (2,*) xx,yy,zz
5421         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5422         de_dzz_num=(sumenep-sumene)/aincr
5423         zz=zzsave
5424         write (2,*) "zz+ sumene from enesc=",sumenep
5425         costsave=cost2tab(i+1)
5426         sintsave=sint2tab(i+1)
5427         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5428         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5429         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5430         de_dt_num=(sumenep-sumene)/aincr
5431         write (2,*) " t+ sumene from enesc=",sumenep
5432         cost2tab(i+1)=costsave
5433         sint2tab(i+1)=sintsave
5434 C End of diagnostics section.
5435 #endif
5436 C
5437 C Compute the gradient of esc
5438 C
5439         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5440         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5441         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5442         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5443         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5444         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5445         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5446         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5447         pom1=(sumene3*sint2tab(i+1)+sumene1)
5448      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5449         pom2=(sumene4*cost2tab(i+1)+sumene2)
5450      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5451         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5452         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5453      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5454      &  +x(40)*yy*zz
5455         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5456         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5457      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5458      &  +x(60)*yy*zz
5459         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5460      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5461      &        +(pom1+pom2)*pom_dx
5462 #ifdef DEBUG
5463         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5464 #endif
5465 C
5466         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5467         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5468      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5469      &  +x(40)*xx*zz
5470         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5471         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5472      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5473      &  +x(59)*zz**2 +x(60)*xx*zz
5474         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5475      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5476      &        +(pom1-pom2)*pom_dy
5477 #ifdef DEBUG
5478         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5479 #endif
5480 C
5481         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5482      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5483      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5484      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5485      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5486      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5487      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5488      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5489 #ifdef DEBUG
5490         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5491 #endif
5492 C
5493         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5494      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5495      &  +pom1*pom_dt1+pom2*pom_dt2
5496 #ifdef DEBUG
5497         write(2,*), "de_dt = ", de_dt,de_dt_num
5498 #endif
5499 c
5500 C
5501        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5502        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5503        cosfac2xx=cosfac2*xx
5504        sinfac2yy=sinfac2*yy
5505        do k = 1,3
5506          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5507      &      vbld_inv(i+1)
5508          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5509      &      vbld_inv(i)
5510          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5511          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5512 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5513 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5514 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5515 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5516          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5517          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5518          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5519          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5520          dZZ_Ci1(k)=0.0d0
5521          dZZ_Ci(k)=0.0d0
5522          do j=1,3
5523            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5524            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5525          enddo
5526
5527          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5528          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5529          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5530 c
5531          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5532          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5533        enddo
5534
5535        do k=1,3
5536          dXX_Ctab(k,i)=dXX_Ci(k)
5537          dXX_C1tab(k,i)=dXX_Ci1(k)
5538          dYY_Ctab(k,i)=dYY_Ci(k)
5539          dYY_C1tab(k,i)=dYY_Ci1(k)
5540          dZZ_Ctab(k,i)=dZZ_Ci(k)
5541          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5542          dXX_XYZtab(k,i)=dXX_XYZ(k)
5543          dYY_XYZtab(k,i)=dYY_XYZ(k)
5544          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5545        enddo
5546
5547        do k = 1,3
5548 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5549 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5550 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5551 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5552 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5553 c     &    dt_dci(k)
5554 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5555 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5556          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5557      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5558          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5559      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5560          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5561      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5562        enddo
5563 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5564 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5565
5566 C to check gradient call subroutine check_grad
5567
5568     1 continue
5569       enddo
5570       return
5571       end
5572 c------------------------------------------------------------------------------
5573       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5574       implicit none
5575       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5576      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5577       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5578      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5579      &   + x(10)*yy*zz
5580       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5581      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5582      & + x(20)*yy*zz
5583       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5584      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5585      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5586      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5587      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5588      &  +x(40)*xx*yy*zz
5589       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5590      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5591      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5592      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5593      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5594      &  +x(60)*xx*yy*zz
5595       dsc_i   = 0.743d0+x(61)
5596       dp2_i   = 1.9d0+x(62)
5597       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5598      &          *(xx*cost2+yy*sint2))
5599       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5600      &          *(xx*cost2-yy*sint2))
5601       s1=(1+x(63))/(0.1d0 + dscp1)
5602       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5603       s2=(1+x(65))/(0.1d0 + dscp2)
5604       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5605       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5606      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5607       enesc=sumene
5608       return
5609       end
5610 #endif
5611 c------------------------------------------------------------------------------
5612       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5613 C
5614 C This procedure calculates two-body contact function g(rij) and its derivative:
5615 C
5616 C           eps0ij                                     !       x < -1
5617 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5618 C            0                                         !       x > 1
5619 C
5620 C where x=(rij-r0ij)/delta
5621 C
5622 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5623 C
5624       implicit none
5625       double precision rij,r0ij,eps0ij,fcont,fprimcont
5626       double precision x,x2,x4,delta
5627 c     delta=0.02D0*r0ij
5628 c      delta=0.2D0*r0ij
5629       x=(rij-r0ij)/delta
5630       if (x.lt.-1.0D0) then
5631         fcont=eps0ij
5632         fprimcont=0.0D0
5633       else if (x.le.1.0D0) then
5634         x2=x*x
5635         x4=x2*x2
5636         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5637         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5638       else
5639         fcont=0.0D0
5640         fprimcont=0.0D0
5641       endif
5642       return
5643       end
5644 c------------------------------------------------------------------------------
5645       subroutine splinthet(theti,delta,ss,ssder)
5646       implicit real*8 (a-h,o-z)
5647       include 'DIMENSIONS'
5648       include 'COMMON.VAR'
5649       include 'COMMON.GEO'
5650       thetup=pi-delta
5651       thetlow=delta
5652       if (theti.gt.pipol) then
5653         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5654       else
5655         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5656         ssder=-ssder
5657       endif
5658       return
5659       end
5660 c------------------------------------------------------------------------------
5661       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5662       implicit none
5663       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5664       double precision ksi,ksi2,ksi3,a1,a2,a3
5665       a1=fprim0*delta/(f1-f0)
5666       a2=3.0d0-2.0d0*a1
5667       a3=a1-2.0d0
5668       ksi=(x-x0)/delta
5669       ksi2=ksi*ksi
5670       ksi3=ksi2*ksi
5671       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5672       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5673       return
5674       end
5675 c------------------------------------------------------------------------------
5676       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5677       implicit none
5678       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5679       double precision ksi,ksi2,ksi3,a1,a2,a3
5680       ksi=(x-x0)/delta
5681       ksi2=ksi*ksi
5682       ksi3=ksi2*ksi
5683       a1=fprim0x*delta
5684       a2=3*(f1x-f0x)-2*fprim0x*delta
5685       a3=fprim0x*delta-2*(f1x-f0x)
5686       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5687       return
5688       end
5689 C-----------------------------------------------------------------------------
5690 #ifdef CRYST_TOR
5691 C-----------------------------------------------------------------------------
5692       subroutine etor(etors,edihcnstr)
5693       implicit real*8 (a-h,o-z)
5694       include 'DIMENSIONS'
5695       include 'COMMON.VAR'
5696       include 'COMMON.GEO'
5697       include 'COMMON.LOCAL'
5698       include 'COMMON.TORSION'
5699       include 'COMMON.INTERACT'
5700       include 'COMMON.DERIV'
5701       include 'COMMON.CHAIN'
5702       include 'COMMON.NAMES'
5703       include 'COMMON.IOUNITS'
5704       include 'COMMON.FFIELD'
5705       include 'COMMON.TORCNSTR'
5706       include 'COMMON.CONTROL'
5707       logical lprn
5708 C Set lprn=.true. for debugging
5709       lprn=.false.
5710 c      lprn=.true.
5711       etors=0.0D0
5712       do i=iphi_start,iphi_end
5713       etors_ii=0.0D0
5714         itori=itortyp(itype(i-2))
5715         itori1=itortyp(itype(i-1))
5716         phii=phi(i)
5717         gloci=0.0D0
5718 C Proline-Proline pair is a special case...
5719         if (itori.eq.3 .and. itori1.eq.3) then
5720           if (phii.gt.-dwapi3) then
5721             cosphi=dcos(3*phii)
5722             fac=1.0D0/(1.0D0-cosphi)
5723             etorsi=v1(1,3,3)*fac
5724             etorsi=etorsi+etorsi
5725             etors=etors+etorsi-v1(1,3,3)
5726             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5727             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5728           endif
5729           do j=1,3
5730             v1ij=v1(j+1,itori,itori1)
5731             v2ij=v2(j+1,itori,itori1)
5732             cosphi=dcos(j*phii)
5733             sinphi=dsin(j*phii)
5734             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5735             if (energy_dec) etors_ii=etors_ii+
5736      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5737             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5738           enddo
5739         else
5740           do j=1,nterm_old
5741             v1ij=v1(j,itori,itori1)
5742             v2ij=v2(j,itori,itori1)
5743             cosphi=dcos(j*phii)
5744             sinphi=dsin(j*phii)
5745             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5746             if (energy_dec) etors_ii=etors_ii+
5747      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5748             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5749           enddo
5750         endif
5751         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5752      &        'etor',i,etors_ii
5753         if (lprn)
5754      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5755      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5756      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5757         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5758         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5759       enddo
5760 ! 6/20/98 - dihedral angle constraints
5761       edihcnstr=0.0d0
5762       do i=1,ndih_constr
5763         itori=idih_constr(i)
5764         phii=phi(itori)
5765         difi=phii-phi0(i)
5766         if (difi.gt.drange(i)) then
5767           difi=difi-drange(i)
5768           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5769           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5770         else if (difi.lt.-drange(i)) then
5771           difi=difi+drange(i)
5772           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5773           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5774         endif
5775 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5776 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5777       enddo
5778 !      write (iout,*) 'edihcnstr',edihcnstr
5779       return
5780       end
5781 c------------------------------------------------------------------------------
5782       subroutine etor_d(etors_d)
5783       etors_d=0.0d0
5784       return
5785       end
5786 c----------------------------------------------------------------------------
5787 #else
5788       subroutine etor(etors,edihcnstr)
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.VAR'
5792       include 'COMMON.GEO'
5793       include 'COMMON.LOCAL'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.INTERACT'
5796       include 'COMMON.DERIV'
5797       include 'COMMON.CHAIN'
5798       include 'COMMON.NAMES'
5799       include 'COMMON.IOUNITS'
5800       include 'COMMON.FFIELD'
5801       include 'COMMON.TORCNSTR'
5802       include 'COMMON.CONTROL'
5803       logical lprn
5804 C Set lprn=.true. for debugging
5805       lprn=.false.
5806 c     lprn=.true.
5807       etors=0.0D0
5808       do i=iphi_start,iphi_end
5809       etors_ii=0.0D0
5810         itori=itortyp(itype(i-2))
5811         itori1=itortyp(itype(i-1))
5812         phii=phi(i)
5813         gloci=0.0D0
5814 C Regular cosine and sine terms
5815         do j=1,nterm(itori,itori1)
5816           v1ij=v1(j,itori,itori1)
5817           v2ij=v2(j,itori,itori1)
5818           cosphi=dcos(j*phii)
5819           sinphi=dsin(j*phii)
5820           etors=etors+v1ij*cosphi+v2ij*sinphi
5821           if (energy_dec) etors_ii=etors_ii+
5822      &                v1ij*cosphi+v2ij*sinphi
5823           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5824         enddo
5825 C Lorentz terms
5826 C                         v1
5827 C  E = SUM ----------------------------------- - v1
5828 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5829 C
5830         cosphi=dcos(0.5d0*phii)
5831         sinphi=dsin(0.5d0*phii)
5832         do j=1,nlor(itori,itori1)
5833           vl1ij=vlor1(j,itori,itori1)
5834           vl2ij=vlor2(j,itori,itori1)
5835           vl3ij=vlor3(j,itori,itori1)
5836           pom=vl2ij*cosphi+vl3ij*sinphi
5837           pom1=1.0d0/(pom*pom+1.0d0)
5838           etors=etors+vl1ij*pom1
5839           if (energy_dec) etors_ii=etors_ii+
5840      &                vl1ij*pom1
5841           pom=-pom*pom1*pom1
5842           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5843         enddo
5844 C Subtract the constant term
5845         etors=etors-v0(itori,itori1)
5846           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5847      &         'etor',i,etors_ii-v0(itori,itori1)
5848         if (lprn)
5849      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5850      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5851      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5852         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5853 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5854       enddo
5855 ! 6/20/98 - dihedral angle constraints
5856       edihcnstr=0.0d0
5857 c      do i=1,ndih_constr
5858       do i=idihconstr_start,idihconstr_end
5859         itori=idih_constr(i)
5860         phii=phi(itori)
5861         difi=pinorm(phii-phi0(i))
5862         if (difi.gt.drange(i)) then
5863           difi=difi-drange(i)
5864           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5865           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5866         else if (difi.lt.-drange(i)) then
5867           difi=difi+drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else
5871           difi=0.0
5872         endif
5873 c        write (iout,*) "gloci", gloc(i-3,icg)
5874 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5875 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5876 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5877       enddo
5878 cd       write (iout,*) 'edihcnstr',edihcnstr
5879       return
5880       end
5881 c----------------------------------------------------------------------------
5882       subroutine etor_d(etors_d)
5883 C 6/23/01 Compute double torsional energy
5884       implicit real*8 (a-h,o-z)
5885       include 'DIMENSIONS'
5886       include 'COMMON.VAR'
5887       include 'COMMON.GEO'
5888       include 'COMMON.LOCAL'
5889       include 'COMMON.TORSION'
5890       include 'COMMON.INTERACT'
5891       include 'COMMON.DERIV'
5892       include 'COMMON.CHAIN'
5893       include 'COMMON.NAMES'
5894       include 'COMMON.IOUNITS'
5895       include 'COMMON.FFIELD'
5896       include 'COMMON.TORCNSTR'
5897       include 'COMMON.CONTROL'
5898       logical lprn
5899 C Set lprn=.true. for debugging
5900       lprn=.false.
5901 c     lprn=.true.
5902       etors_d=0.0D0
5903       do i=iphid_start,iphid_end
5904         etors_d_ii=0.0D0
5905         itori=itortyp(itype(i-2))
5906         itori1=itortyp(itype(i-1))
5907         itori2=itortyp(itype(i))
5908         phii=phi(i)
5909         phii1=phi(i+1)
5910         gloci1=0.0D0
5911         gloci2=0.0D0
5912         do j=1,ntermd_1(itori,itori1,itori2)
5913           v1cij=v1c(1,j,itori,itori1,itori2)
5914           v1sij=v1s(1,j,itori,itori1,itori2)
5915           v2cij=v1c(2,j,itori,itori1,itori2)
5916           v2sij=v1s(2,j,itori,itori1,itori2)
5917           cosphi1=dcos(j*phii)
5918           sinphi1=dsin(j*phii)
5919           cosphi2=dcos(j*phii1)
5920           sinphi2=dsin(j*phii1)
5921           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5922      &     v2cij*cosphi2+v2sij*sinphi2
5923           if (energy_dec) etors_d_ii=etors_d_ii+
5924      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5925           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5926           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5927         enddo
5928         do k=2,ntermd_2(itori,itori1,itori2)
5929           do l=1,k-1
5930             v1cdij = v2c(k,l,itori,itori1,itori2)
5931             v2cdij = v2c(l,k,itori,itori1,itori2)
5932             v1sdij = v2s(k,l,itori,itori1,itori2)
5933             v2sdij = v2s(l,k,itori,itori1,itori2)
5934             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5935             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5936             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5937             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5938             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5939      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5940             if (energy_dec) etors_d_ii=etors_d_ii+
5941      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5942      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5943             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5944      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5945             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5946      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5947           enddo
5948         enddo
5949         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5950      &        'etor_d',i,etors_d_ii
5951         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5952         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5953 c        write (iout,*) "gloci", gloc(i-3,icg)
5954       enddo
5955       return
5956       end
5957 #endif
5958 c------------------------------------------------------------------------------
5959       subroutine eback_sc_corr(esccor)
5960 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5961 c        conformational states; temporarily implemented as differences
5962 c        between UNRES torsional potentials (dependent on three types of
5963 c        residues) and the torsional potentials dependent on all 20 types
5964 c        of residues computed from AM1  energy surfaces of terminally-blocked
5965 c        amino-acid residues.
5966       implicit real*8 (a-h,o-z)
5967       include 'DIMENSIONS'
5968       include 'COMMON.VAR'
5969       include 'COMMON.GEO'
5970       include 'COMMON.LOCAL'
5971       include 'COMMON.TORSION'
5972       include 'COMMON.SCCOR'
5973       include 'COMMON.INTERACT'
5974       include 'COMMON.DERIV'
5975       include 'COMMON.CHAIN'
5976       include 'COMMON.NAMES'
5977       include 'COMMON.IOUNITS'
5978       include 'COMMON.FFIELD'
5979       include 'COMMON.CONTROL'
5980       logical lprn
5981 C Set lprn=.true. for debugging
5982       lprn=.false.
5983 c      lprn=.true.
5984 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5985       esccor=0.0D0
5986       do i=itau_start,itau_end
5987 C        do i=42,42
5988         esccor_ii=0.0D0
5989         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5990         isccori=isccortyp(itype(i-2))
5991         isccori1=isccortyp(itype(i-1))
5992         phii=phi(i)
5993
5994 cccc  Added 9 May 2012
5995 cc Tauangle is torsional engle depending on the value of first digit
5996 c(see comment below)
5997 cc Omicron is flat angle depending on the value of first digit
5998 c(see comment below)
5999 C        print *,i,tauangle(1,i)
6000
6001 c        do intertyp=1,3 !intertyp
6002         do intertyp=2,2 !intertyp
6003 cc Added 09 May 2012 (Adasko)
6004 cc  Intertyp means interaction type of backbone mainchain correlation:
6005 c   1 = SC...Ca...Ca...Ca
6006 c   2 = Ca...Ca...Ca...SC
6007 c   3 = SC...Ca...Ca...SCi
6008         gloci=0.0D0
6009         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6010      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6011      &      (itype(i-1).eq.21)))
6012      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6013      &     .or.(itype(i-2).eq.21)))
6014      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6015      &      (itype(i-1).eq.21)))) cycle
6016         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6017         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6018      & cycle
6019         do j=1,nterm_sccor(isccori,isccori1)
6020           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6021           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6022           cosphi=dcos(j*tauangle(intertyp,i))
6023           sinphi=dsin(j*tauangle(intertyp,i))
6024           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6025           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6026         enddo
6027 C        print *,i,tauangle(1,i),gloci
6028         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6029 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6030 c     &gloc_sc(intertyp,i-3,icg)
6031         if (lprn)
6032      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6033      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6034      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6035      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6036         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6037        enddo !intertyp
6038       enddo
6039 c        do i=1,nres
6040 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
6041 c     &   gloc_sc(3,i,icg)
6042 c        enddo
6043       return
6044       end
6045 c----------------------------------------------------------------------------
6046       subroutine multibody(ecorr)
6047 C This subroutine calculates multi-body contributions to energy following
6048 C the idea of Skolnick et al. If side chains I and J make a contact and
6049 C at the same time side chains I+1 and J+1 make a contact, an extra
6050 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6051       implicit real*8 (a-h,o-z)
6052       include 'DIMENSIONS'
6053       include 'COMMON.IOUNITS'
6054       include 'COMMON.DERIV'
6055       include 'COMMON.INTERACT'
6056       include 'COMMON.CONTACTS'
6057       double precision gx(3),gx1(3)
6058       logical lprn
6059
6060 C Set lprn=.true. for debugging
6061       lprn=.false.
6062
6063       if (lprn) then
6064         write (iout,'(a)') 'Contact function values:'
6065         do i=nnt,nct-2
6066           write (iout,'(i2,20(1x,i2,f10.5))')
6067      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6068         enddo
6069       endif
6070       ecorr=0.0D0
6071       do i=nnt,nct
6072         do j=1,3
6073           gradcorr(j,i)=0.0D0
6074           gradxorr(j,i)=0.0D0
6075         enddo
6076       enddo
6077       do i=nnt,nct-2
6078
6079         DO ISHIFT = 3,4
6080
6081         i1=i+ishift
6082         num_conti=num_cont(i)
6083         num_conti1=num_cont(i1)
6084         do jj=1,num_conti
6085           j=jcont(jj,i)
6086           do kk=1,num_conti1
6087             j1=jcont(kk,i1)
6088             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6089 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6090 cd   &                   ' ishift=',ishift
6091 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6092 C The system gains extra energy.
6093               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6094             endif   ! j1==j+-ishift
6095           enddo     ! kk
6096         enddo       ! jj
6097
6098         ENDDO ! ISHIFT
6099
6100       enddo         ! i
6101       return
6102       end
6103 c------------------------------------------------------------------------------
6104       double precision function esccorr(i,j,k,l,jj,kk)
6105       implicit real*8 (a-h,o-z)
6106       include 'DIMENSIONS'
6107       include 'COMMON.IOUNITS'
6108       include 'COMMON.DERIV'
6109       include 'COMMON.INTERACT'
6110       include 'COMMON.CONTACTS'
6111       double precision gx(3),gx1(3)
6112       logical lprn
6113       lprn=.false.
6114       eij=facont(jj,i)
6115       ekl=facont(kk,k)
6116 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6117 C Calculate the multi-body contribution to energy.
6118 C Calculate multi-body contributions to the gradient.
6119 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6120 cd   & k,l,(gacont(m,kk,k),m=1,3)
6121       do m=1,3
6122         gx(m) =ekl*gacont(m,jj,i)
6123         gx1(m)=eij*gacont(m,kk,k)
6124         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6125         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6126         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6127         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6128       enddo
6129       do m=i,j-1
6130         do ll=1,3
6131           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6132         enddo
6133       enddo
6134       do m=k,l-1
6135         do ll=1,3
6136           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6137         enddo
6138       enddo
6139       esccorr=-eij*ekl
6140       return
6141       end
6142 c------------------------------------------------------------------------------
6143       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6144 C This subroutine calculates multi-body contributions to hydrogen-bonding
6145       implicit real*8 (a-h,o-z)
6146       include 'DIMENSIONS'
6147       include 'COMMON.IOUNITS'
6148 #ifdef MPI
6149       include "mpif.h"
6150       parameter (max_cont=maxconts)
6151       parameter (max_dim=26)
6152       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6153       double precision zapas(max_dim,maxconts,max_fg_procs),
6154      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6155       common /przechowalnia/ zapas
6156       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6157      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6158 #endif
6159       include 'COMMON.SETUP'
6160       include 'COMMON.FFIELD'
6161       include 'COMMON.DERIV'
6162       include 'COMMON.INTERACT'
6163       include 'COMMON.CONTACTS'
6164       include 'COMMON.CONTROL'
6165       include 'COMMON.LOCAL'
6166       double precision gx(3),gx1(3),time00
6167       logical lprn,ldone
6168
6169 C Set lprn=.true. for debugging
6170       lprn=.false.
6171 #ifdef MPI
6172       n_corr=0
6173       n_corr1=0
6174       if (nfgtasks.le.1) goto 30
6175       if (lprn) then
6176         write (iout,'(a)') 'Contact function values before RECEIVE:'
6177         do i=nnt,nct-2
6178           write (iout,'(2i3,50(1x,i2,f5.2))')
6179      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6180      &    j=1,num_cont_hb(i))
6181         enddo
6182       endif
6183       call flush(iout)
6184       do i=1,ntask_cont_from
6185         ncont_recv(i)=0
6186       enddo
6187       do i=1,ntask_cont_to
6188         ncont_sent(i)=0
6189       enddo
6190 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6191 c     & ntask_cont_to
6192 C Make the list of contacts to send to send to other procesors
6193 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6194 c      call flush(iout)
6195       do i=iturn3_start,iturn3_end
6196 c        write (iout,*) "make contact list turn3",i," num_cont",
6197 c     &    num_cont_hb(i)
6198         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6199       enddo
6200       do i=iturn4_start,iturn4_end
6201 c        write (iout,*) "make contact list turn4",i," num_cont",
6202 c     &   num_cont_hb(i)
6203         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6204       enddo
6205       do ii=1,nat_sent
6206         i=iat_sent(ii)
6207 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6208 c     &    num_cont_hb(i)
6209         do j=1,num_cont_hb(i)
6210         do k=1,4
6211           jjc=jcont_hb(j,i)
6212           iproc=iint_sent_local(k,jjc,ii)
6213 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6214           if (iproc.gt.0) then
6215             ncont_sent(iproc)=ncont_sent(iproc)+1
6216             nn=ncont_sent(iproc)
6217             zapas(1,nn,iproc)=i
6218             zapas(2,nn,iproc)=jjc
6219             zapas(3,nn,iproc)=facont_hb(j,i)
6220             zapas(4,nn,iproc)=ees0p(j,i)
6221             zapas(5,nn,iproc)=ees0m(j,i)
6222             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6223             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6224             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6225             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6226             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6227             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6228             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6229             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6230             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6231             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6232             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6233             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6234             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6235             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6236             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6237             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6238             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6239             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6240             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6241             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6242             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6243           endif
6244         enddo
6245         enddo
6246       enddo
6247       if (lprn) then
6248       write (iout,*)
6249      &  "Numbers of contacts to be sent to other processors",
6250      &  (ncont_sent(i),i=1,ntask_cont_to)
6251       write (iout,*) "Contacts sent"
6252       do ii=1,ntask_cont_to
6253         nn=ncont_sent(ii)
6254         iproc=itask_cont_to(ii)
6255         write (iout,*) nn," contacts to processor",iproc,
6256      &   " of CONT_TO_COMM group"
6257         do i=1,nn
6258           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6259         enddo
6260       enddo
6261       call flush(iout)
6262       endif
6263       CorrelType=477
6264       CorrelID=fg_rank+1
6265       CorrelType1=478
6266       CorrelID1=nfgtasks+fg_rank+1
6267       ireq=0
6268 C Receive the numbers of needed contacts from other processors
6269       do ii=1,ntask_cont_from
6270         iproc=itask_cont_from(ii)
6271         ireq=ireq+1
6272         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6273      &    FG_COMM,req(ireq),IERR)
6274       enddo
6275 c      write (iout,*) "IRECV ended"
6276 c      call flush(iout)
6277 C Send the number of contacts needed by other processors
6278       do ii=1,ntask_cont_to
6279         iproc=itask_cont_to(ii)
6280         ireq=ireq+1
6281         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6282      &    FG_COMM,req(ireq),IERR)
6283       enddo
6284 c      write (iout,*) "ISEND ended"
6285 c      write (iout,*) "number of requests (nn)",ireq
6286       call flush(iout)
6287       if (ireq.gt.0)
6288      &  call MPI_Waitall(ireq,req,status_array,ierr)
6289 c      write (iout,*)
6290 c     &  "Numbers of contacts to be received from other processors",
6291 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6292 c      call flush(iout)
6293 C Receive contacts
6294       ireq=0
6295       do ii=1,ntask_cont_from
6296         iproc=itask_cont_from(ii)
6297         nn=ncont_recv(ii)
6298 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6299 c     &   " of CONT_TO_COMM group"
6300         call flush(iout)
6301         if (nn.gt.0) then
6302           ireq=ireq+1
6303           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6304      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6305 c          write (iout,*) "ireq,req",ireq,req(ireq)
6306         endif
6307       enddo
6308 C Send the contacts to processors that need them
6309       do ii=1,ntask_cont_to
6310         iproc=itask_cont_to(ii)
6311         nn=ncont_sent(ii)
6312 c        write (iout,*) nn," contacts to processor",iproc,
6313 c     &   " of CONT_TO_COMM group"
6314         if (nn.gt.0) then
6315           ireq=ireq+1
6316           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6317      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6318 c          write (iout,*) "ireq,req",ireq,req(ireq)
6319 c          do i=1,nn
6320 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6321 c          enddo
6322         endif
6323       enddo
6324 c      write (iout,*) "number of requests (contacts)",ireq
6325 c      write (iout,*) "req",(req(i),i=1,4)
6326 c      call flush(iout)
6327       if (ireq.gt.0)
6328      & call MPI_Waitall(ireq,req,status_array,ierr)
6329       do iii=1,ntask_cont_from
6330         iproc=itask_cont_from(iii)
6331         nn=ncont_recv(iii)
6332         if (lprn) then
6333         write (iout,*) "Received",nn," contacts from processor",iproc,
6334      &   " of CONT_FROM_COMM group"
6335         call flush(iout)
6336         do i=1,nn
6337           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6338         enddo
6339         call flush(iout)
6340         endif
6341         do i=1,nn
6342           ii=zapas_recv(1,i,iii)
6343 c Flag the received contacts to prevent double-counting
6344           jj=-zapas_recv(2,i,iii)
6345 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6346 c          call flush(iout)
6347           nnn=num_cont_hb(ii)+1
6348           num_cont_hb(ii)=nnn
6349           jcont_hb(nnn,ii)=jj
6350           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6351           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6352           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6353           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6354           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6355           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6356           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6357           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6358           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6359           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6360           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6361           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6362           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6363           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6364           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6365           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6366           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6367           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6368           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6369           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6370           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6371           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6372           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6373           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6374         enddo
6375       enddo
6376       call flush(iout)
6377       if (lprn) then
6378         write (iout,'(a)') 'Contact function values after receive:'
6379         do i=nnt,nct-2
6380           write (iout,'(2i3,50(1x,i3,f5.2))')
6381      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6382      &    j=1,num_cont_hb(i))
6383         enddo
6384         call flush(iout)
6385       endif
6386    30 continue
6387 #endif
6388       if (lprn) then
6389         write (iout,'(a)') 'Contact function values:'
6390         do i=nnt,nct-2
6391           write (iout,'(2i3,50(1x,i3,f5.2))')
6392      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6393      &    j=1,num_cont_hb(i))
6394         enddo
6395       endif
6396       ecorr=0.0D0
6397 C Remove the loop below after debugging !!!
6398       do i=nnt,nct
6399         do j=1,3
6400           gradcorr(j,i)=0.0D0
6401           gradxorr(j,i)=0.0D0
6402         enddo
6403       enddo
6404 C Calculate the local-electrostatic correlation terms
6405       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6406         i1=i+1
6407         num_conti=num_cont_hb(i)
6408         num_conti1=num_cont_hb(i+1)
6409         do jj=1,num_conti
6410           j=jcont_hb(jj,i)
6411           jp=iabs(j)
6412           do kk=1,num_conti1
6413             j1=jcont_hb(kk,i1)
6414             jp1=iabs(j1)
6415 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6416 c     &         ' jj=',jj,' kk=',kk
6417             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6418      &          .or. j.lt.0 .and. j1.gt.0) .and.
6419      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6420 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6421 C The system gains extra energy.
6422               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6423               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6424      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6425               n_corr=n_corr+1
6426             else if (j1.eq.j) then
6427 C Contacts I-J and I-(J+1) occur simultaneously.
6428 C The system loses extra energy.
6429 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6430             endif
6431           enddo ! kk
6432           do kk=1,num_conti
6433             j1=jcont_hb(kk,i)
6434 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6435 c    &         ' jj=',jj,' kk=',kk
6436             if (j1.eq.j+1) then
6437 C Contacts I-J and (I+1)-J occur simultaneously.
6438 C The system loses extra energy.
6439 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6440             endif ! j1==j+1
6441           enddo ! kk
6442         enddo ! jj
6443       enddo ! i
6444       return
6445       end
6446 c------------------------------------------------------------------------------
6447       subroutine add_hb_contact(ii,jj,itask)
6448       implicit real*8 (a-h,o-z)
6449       include "DIMENSIONS"
6450       include "COMMON.IOUNITS"
6451       integer max_cont
6452       integer max_dim
6453       parameter (max_cont=maxconts)
6454       parameter (max_dim=26)
6455       include "COMMON.CONTACTS"
6456       double precision zapas(max_dim,maxconts,max_fg_procs),
6457      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6458       common /przechowalnia/ zapas
6459       integer i,j,ii,jj,iproc,itask(4),nn
6460 c      write (iout,*) "itask",itask
6461       do i=1,2
6462         iproc=itask(i)
6463         if (iproc.gt.0) then
6464           do j=1,num_cont_hb(ii)
6465             jjc=jcont_hb(j,ii)
6466 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6467             if (jjc.eq.jj) then
6468               ncont_sent(iproc)=ncont_sent(iproc)+1
6469               nn=ncont_sent(iproc)
6470               zapas(1,nn,iproc)=ii
6471               zapas(2,nn,iproc)=jjc
6472               zapas(3,nn,iproc)=facont_hb(j,ii)
6473               zapas(4,nn,iproc)=ees0p(j,ii)
6474               zapas(5,nn,iproc)=ees0m(j,ii)
6475               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6476               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6477               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6478               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6479               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6480               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6481               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6482               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6483               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6484               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6485               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6486               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6487               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6488               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6489               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6490               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6491               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6492               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6493               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6494               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6495               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6496               exit
6497             endif
6498           enddo
6499         endif
6500       enddo
6501       return
6502       end
6503 c------------------------------------------------------------------------------
6504       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6505      &  n_corr1)
6506 C This subroutine calculates multi-body contributions to hydrogen-bonding
6507       implicit real*8 (a-h,o-z)
6508       include 'DIMENSIONS'
6509       include 'COMMON.IOUNITS'
6510 #ifdef MPI
6511       include "mpif.h"
6512       parameter (max_cont=maxconts)
6513       parameter (max_dim=70)
6514       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6515       double precision zapas(max_dim,maxconts,max_fg_procs),
6516      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6517       common /przechowalnia/ zapas
6518       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6519      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6520 #endif
6521       include 'COMMON.SETUP'
6522       include 'COMMON.FFIELD'
6523       include 'COMMON.DERIV'
6524       include 'COMMON.LOCAL'
6525       include 'COMMON.INTERACT'
6526       include 'COMMON.CONTACTS'
6527       include 'COMMON.CHAIN'
6528       include 'COMMON.CONTROL'
6529       double precision gx(3),gx1(3)
6530       integer num_cont_hb_old(maxres)
6531       logical lprn,ldone
6532       double precision eello4,eello5,eelo6,eello_turn6
6533       external eello4,eello5,eello6,eello_turn6
6534 C Set lprn=.true. for debugging
6535       lprn=.false.
6536       eturn6=0.0d0
6537 #ifdef MPI
6538       do i=1,nres
6539         num_cont_hb_old(i)=num_cont_hb(i)
6540       enddo
6541       n_corr=0
6542       n_corr1=0
6543       if (nfgtasks.le.1) goto 30
6544       if (lprn) then
6545         write (iout,'(a)') 'Contact function values before RECEIVE:'
6546         do i=nnt,nct-2
6547           write (iout,'(2i3,50(1x,i2,f5.2))')
6548      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6549      &    j=1,num_cont_hb(i))
6550         enddo
6551       endif
6552       call flush(iout)
6553       do i=1,ntask_cont_from
6554         ncont_recv(i)=0
6555       enddo
6556       do i=1,ntask_cont_to
6557         ncont_sent(i)=0
6558       enddo
6559 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6560 c     & ntask_cont_to
6561 C Make the list of contacts to send to send to other procesors
6562       do i=iturn3_start,iturn3_end
6563 c        write (iout,*) "make contact list turn3",i," num_cont",
6564 c     &    num_cont_hb(i)
6565         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6566       enddo
6567       do i=iturn4_start,iturn4_end
6568 c        write (iout,*) "make contact list turn4",i," num_cont",
6569 c     &   num_cont_hb(i)
6570         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6571       enddo
6572       do ii=1,nat_sent
6573         i=iat_sent(ii)
6574 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6575 c     &    num_cont_hb(i)
6576         do j=1,num_cont_hb(i)
6577         do k=1,4
6578           jjc=jcont_hb(j,i)
6579           iproc=iint_sent_local(k,jjc,ii)
6580 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6581           if (iproc.ne.0) then
6582             ncont_sent(iproc)=ncont_sent(iproc)+1
6583             nn=ncont_sent(iproc)
6584             zapas(1,nn,iproc)=i
6585             zapas(2,nn,iproc)=jjc
6586             zapas(3,nn,iproc)=d_cont(j,i)
6587             ind=3
6588             do kk=1,3
6589               ind=ind+1
6590               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6591             enddo
6592             do kk=1,2
6593               do ll=1,2
6594                 ind=ind+1
6595                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6596               enddo
6597             enddo
6598             do jj=1,5
6599               do kk=1,3
6600                 do ll=1,2
6601                   do mm=1,2
6602                     ind=ind+1
6603                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6604                   enddo
6605                 enddo
6606               enddo
6607             enddo
6608           endif
6609         enddo
6610         enddo
6611       enddo
6612       if (lprn) then
6613       write (iout,*)
6614      &  "Numbers of contacts to be sent to other processors",
6615      &  (ncont_sent(i),i=1,ntask_cont_to)
6616       write (iout,*) "Contacts sent"
6617       do ii=1,ntask_cont_to
6618         nn=ncont_sent(ii)
6619         iproc=itask_cont_to(ii)
6620         write (iout,*) nn," contacts to processor",iproc,
6621      &   " of CONT_TO_COMM group"
6622         do i=1,nn
6623           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6624         enddo
6625       enddo
6626       call flush(iout)
6627       endif
6628       CorrelType=477
6629       CorrelID=fg_rank+1
6630       CorrelType1=478
6631       CorrelID1=nfgtasks+fg_rank+1
6632       ireq=0
6633 C Receive the numbers of needed contacts from other processors
6634       do ii=1,ntask_cont_from
6635         iproc=itask_cont_from(ii)
6636         ireq=ireq+1
6637         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6638      &    FG_COMM,req(ireq),IERR)
6639       enddo
6640 c      write (iout,*) "IRECV ended"
6641 c      call flush(iout)
6642 C Send the number of contacts needed by other processors
6643       do ii=1,ntask_cont_to
6644         iproc=itask_cont_to(ii)
6645         ireq=ireq+1
6646         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6647      &    FG_COMM,req(ireq),IERR)
6648       enddo
6649 c      write (iout,*) "ISEND ended"
6650 c      write (iout,*) "number of requests (nn)",ireq
6651       call flush(iout)
6652       if (ireq.gt.0)
6653      &  call MPI_Waitall(ireq,req,status_array,ierr)
6654 c      write (iout,*)
6655 c     &  "Numbers of contacts to be received from other processors",
6656 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6657 c      call flush(iout)
6658 C Receive contacts
6659       ireq=0
6660       do ii=1,ntask_cont_from
6661         iproc=itask_cont_from(ii)
6662         nn=ncont_recv(ii)
6663 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6664 c     &   " of CONT_TO_COMM group"
6665         call flush(iout)
6666         if (nn.gt.0) then
6667           ireq=ireq+1
6668           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6669      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6670 c          write (iout,*) "ireq,req",ireq,req(ireq)
6671         endif
6672       enddo
6673 C Send the contacts to processors that need them
6674       do ii=1,ntask_cont_to
6675         iproc=itask_cont_to(ii)
6676         nn=ncont_sent(ii)
6677 c        write (iout,*) nn," contacts to processor",iproc,
6678 c     &   " of CONT_TO_COMM group"
6679         if (nn.gt.0) then
6680           ireq=ireq+1
6681           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6682      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6683 c          write (iout,*) "ireq,req",ireq,req(ireq)
6684 c          do i=1,nn
6685 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6686 c          enddo
6687         endif
6688       enddo
6689 c      write (iout,*) "number of requests (contacts)",ireq
6690 c      write (iout,*) "req",(req(i),i=1,4)
6691 c      call flush(iout)
6692       if (ireq.gt.0)
6693      & call MPI_Waitall(ireq,req,status_array,ierr)
6694       do iii=1,ntask_cont_from
6695         iproc=itask_cont_from(iii)
6696         nn=ncont_recv(iii)
6697         if (lprn) then
6698         write (iout,*) "Received",nn," contacts from processor",iproc,
6699      &   " of CONT_FROM_COMM group"
6700         call flush(iout)
6701         do i=1,nn
6702           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6703         enddo
6704         call flush(iout)
6705         endif
6706         do i=1,nn
6707           ii=zapas_recv(1,i,iii)
6708 c Flag the received contacts to prevent double-counting
6709           jj=-zapas_recv(2,i,iii)
6710 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6711 c          call flush(iout)
6712           nnn=num_cont_hb(ii)+1
6713           num_cont_hb(ii)=nnn
6714           jcont_hb(nnn,ii)=jj
6715           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6716           ind=3
6717           do kk=1,3
6718             ind=ind+1
6719             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6720           enddo
6721           do kk=1,2
6722             do ll=1,2
6723               ind=ind+1
6724               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6725             enddo
6726           enddo
6727           do jj=1,5
6728             do kk=1,3
6729               do ll=1,2
6730                 do mm=1,2
6731                   ind=ind+1
6732                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6733                 enddo
6734               enddo
6735             enddo
6736           enddo
6737         enddo
6738       enddo
6739       call flush(iout)
6740       if (lprn) then
6741         write (iout,'(a)') 'Contact function values after receive:'
6742         do i=nnt,nct-2
6743           write (iout,'(2i3,50(1x,i3,5f6.3))')
6744      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6745      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6746         enddo
6747         call flush(iout)
6748       endif
6749    30 continue
6750 #endif
6751       if (lprn) then
6752         write (iout,'(a)') 'Contact function values:'
6753         do i=nnt,nct-2
6754           write (iout,'(2i3,50(1x,i2,5f6.3))')
6755      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6756      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6757         enddo
6758       endif
6759       ecorr=0.0D0
6760       ecorr5=0.0d0
6761       ecorr6=0.0d0
6762 C Remove the loop below after debugging !!!
6763       do i=nnt,nct
6764         do j=1,3
6765           gradcorr(j,i)=0.0D0
6766           gradxorr(j,i)=0.0D0
6767         enddo
6768       enddo
6769 C Calculate the dipole-dipole interaction energies
6770       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6771       do i=iatel_s,iatel_e+1
6772         num_conti=num_cont_hb(i)
6773         do jj=1,num_conti
6774           j=jcont_hb(jj,i)
6775 #ifdef MOMENT
6776           call dipole(i,j,jj)
6777 #endif
6778         enddo
6779       enddo
6780       endif
6781 C Calculate the local-electrostatic correlation terms
6782 c                write (iout,*) "gradcorr5 in eello5 before loop"
6783 c                do iii=1,nres
6784 c                  write (iout,'(i5,3f10.5)')
6785 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6786 c                enddo
6787       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6788 c        write (iout,*) "corr loop i",i
6789         i1=i+1
6790         num_conti=num_cont_hb(i)
6791         num_conti1=num_cont_hb(i+1)
6792         do jj=1,num_conti
6793           j=jcont_hb(jj,i)
6794           jp=iabs(j)
6795           do kk=1,num_conti1
6796             j1=jcont_hb(kk,i1)
6797             jp1=iabs(j1)
6798 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6799 c     &         ' jj=',jj,' kk=',kk
6800 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6801             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6802      &          .or. j.lt.0 .and. j1.gt.0) .and.
6803      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6804 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6805 C The system gains extra energy.
6806               n_corr=n_corr+1
6807               sqd1=dsqrt(d_cont(jj,i))
6808               sqd2=dsqrt(d_cont(kk,i1))
6809               sred_geom = sqd1*sqd2
6810               IF (sred_geom.lt.cutoff_corr) THEN
6811                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6812      &            ekont,fprimcont)
6813 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6814 cd     &         ' jj=',jj,' kk=',kk
6815                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6816                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6817                 do l=1,3
6818                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6819                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6820                 enddo
6821                 n_corr1=n_corr1+1
6822 cd               write (iout,*) 'sred_geom=',sred_geom,
6823 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6824 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6825 cd               write (iout,*) "g_contij",g_contij
6826 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6827 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6828                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6829                 if (wcorr4.gt.0.0d0)
6830      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6831                   if (energy_dec.and.wcorr4.gt.0.0d0)
6832      1                 write (iout,'(a6,4i5,0pf7.3)')
6833      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6834 c                write (iout,*) "gradcorr5 before eello5"
6835 c                do iii=1,nres
6836 c                  write (iout,'(i5,3f10.5)')
6837 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6838 c                enddo
6839                 if (wcorr5.gt.0.0d0)
6840      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6841 c                write (iout,*) "gradcorr5 after eello5"
6842 c                do iii=1,nres
6843 c                  write (iout,'(i5,3f10.5)')
6844 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6845 c                enddo
6846                   if (energy_dec.and.wcorr5.gt.0.0d0)
6847      1                 write (iout,'(a6,4i5,0pf7.3)')
6848      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6849 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6850 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6851                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6852      &               .or. wturn6.eq.0.0d0))then
6853 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6854                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6855                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6856      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6857 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6858 cd     &            'ecorr6=',ecorr6
6859 cd                write (iout,'(4e15.5)') sred_geom,
6860 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6861 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6862 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6863                 else if (wturn6.gt.0.0d0
6864      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6865 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6866                   eturn6=eturn6+eello_turn6(i,jj,kk)
6867                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6868      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6869 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6870                 endif
6871               ENDIF
6872 1111          continue
6873             endif
6874           enddo ! kk
6875         enddo ! jj
6876       enddo ! i
6877       do i=1,nres
6878         num_cont_hb(i)=num_cont_hb_old(i)
6879       enddo
6880 c                write (iout,*) "gradcorr5 in eello5"
6881 c                do iii=1,nres
6882 c                  write (iout,'(i5,3f10.5)')
6883 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6884 c                enddo
6885       return
6886       end
6887 c------------------------------------------------------------------------------
6888       subroutine add_hb_contact_eello(ii,jj,itask)
6889       implicit real*8 (a-h,o-z)
6890       include "DIMENSIONS"
6891       include "COMMON.IOUNITS"
6892       integer max_cont
6893       integer max_dim
6894       parameter (max_cont=maxconts)
6895       parameter (max_dim=70)
6896       include "COMMON.CONTACTS"
6897       double precision zapas(max_dim,maxconts,max_fg_procs),
6898      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6899       common /przechowalnia/ zapas
6900       integer i,j,ii,jj,iproc,itask(4),nn
6901 c      write (iout,*) "itask",itask
6902       do i=1,2
6903         iproc=itask(i)
6904         if (iproc.gt.0) then
6905           do j=1,num_cont_hb(ii)
6906             jjc=jcont_hb(j,ii)
6907 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6908             if (jjc.eq.jj) then
6909               ncont_sent(iproc)=ncont_sent(iproc)+1
6910               nn=ncont_sent(iproc)
6911               zapas(1,nn,iproc)=ii
6912               zapas(2,nn,iproc)=jjc
6913               zapas(3,nn,iproc)=d_cont(j,ii)
6914               ind=3
6915               do kk=1,3
6916                 ind=ind+1
6917                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6918               enddo
6919               do kk=1,2
6920                 do ll=1,2
6921                   ind=ind+1
6922                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6923                 enddo
6924               enddo
6925               do jj=1,5
6926                 do kk=1,3
6927                   do ll=1,2
6928                     do mm=1,2
6929                       ind=ind+1
6930                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6931                     enddo
6932                   enddo
6933                 enddo
6934               enddo
6935               exit
6936             endif
6937           enddo
6938         endif
6939       enddo
6940       return
6941       end
6942 c------------------------------------------------------------------------------
6943       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6944       implicit real*8 (a-h,o-z)
6945       include 'DIMENSIONS'
6946       include 'COMMON.IOUNITS'
6947       include 'COMMON.DERIV'
6948       include 'COMMON.INTERACT'
6949       include 'COMMON.CONTACTS'
6950       double precision gx(3),gx1(3)
6951       logical lprn
6952       lprn=.false.
6953       eij=facont_hb(jj,i)
6954       ekl=facont_hb(kk,k)
6955       ees0pij=ees0p(jj,i)
6956       ees0pkl=ees0p(kk,k)
6957       ees0mij=ees0m(jj,i)
6958       ees0mkl=ees0m(kk,k)
6959       ekont=eij*ekl
6960       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6961 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6962 C Following 4 lines for diagnostics.
6963 cd    ees0pkl=0.0D0
6964 cd    ees0pij=1.0D0
6965 cd    ees0mkl=0.0D0
6966 cd    ees0mij=1.0D0
6967 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6968 c     & 'Contacts ',i,j,
6969 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6970 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6971 c     & 'gradcorr_long'
6972 C Calculate the multi-body contribution to energy.
6973 c      ecorr=ecorr+ekont*ees
6974 C Calculate multi-body contributions to the gradient.
6975       coeffpees0pij=coeffp*ees0pij
6976       coeffmees0mij=coeffm*ees0mij
6977       coeffpees0pkl=coeffp*ees0pkl
6978       coeffmees0mkl=coeffm*ees0mkl
6979       do ll=1,3
6980 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6981         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6982      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6983      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6984         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6985      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6986      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6987 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6988         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6989      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6990      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6991         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6992      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6993      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6994         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6995      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6996      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6997         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6998         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6999         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7000      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7001      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7002         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7003         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7004 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7005       enddo
7006 c      write (iout,*)
7007 cgrad      do m=i+1,j-1
7008 cgrad        do ll=1,3
7009 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7010 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7011 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7012 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7013 cgrad        enddo
7014 cgrad      enddo
7015 cgrad      do m=k+1,l-1
7016 cgrad        do ll=1,3
7017 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7018 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7019 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7020 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7021 cgrad        enddo
7022 cgrad      enddo
7023 c      write (iout,*) "ehbcorr",ekont*ees
7024       ehbcorr=ekont*ees
7025       return
7026       end
7027 #ifdef MOMENT
7028 C---------------------------------------------------------------------------
7029       subroutine dipole(i,j,jj)
7030       implicit real*8 (a-h,o-z)
7031       include 'DIMENSIONS'
7032       include 'COMMON.IOUNITS'
7033       include 'COMMON.CHAIN'
7034       include 'COMMON.FFIELD'
7035       include 'COMMON.DERIV'
7036       include 'COMMON.INTERACT'
7037       include 'COMMON.CONTACTS'
7038       include 'COMMON.TORSION'
7039       include 'COMMON.VAR'
7040       include 'COMMON.GEO'
7041       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7042      &  auxmat(2,2)
7043       iti1 = itortyp(itype(i+1))
7044       if (j.lt.nres-1) then
7045         itj1 = itortyp(itype(j+1))
7046       else
7047         itj1=ntortyp+1
7048       endif
7049       do iii=1,2
7050         dipi(iii,1)=Ub2(iii,i)
7051         dipderi(iii)=Ub2der(iii,i)
7052         dipi(iii,2)=b1(iii,iti1)
7053         dipj(iii,1)=Ub2(iii,j)
7054         dipderj(iii)=Ub2der(iii,j)
7055         dipj(iii,2)=b1(iii,itj1)
7056       enddo
7057       kkk=0
7058       do iii=1,2
7059         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7060         do jjj=1,2
7061           kkk=kkk+1
7062           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7063         enddo
7064       enddo
7065       do kkk=1,5
7066         do lll=1,3
7067           mmm=0
7068           do iii=1,2
7069             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7070      &        auxvec(1))
7071             do jjj=1,2
7072               mmm=mmm+1
7073               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7074             enddo
7075           enddo
7076         enddo
7077       enddo
7078       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7079       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7080       do iii=1,2
7081         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7082       enddo
7083       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7084       do iii=1,2
7085         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7086       enddo
7087       return
7088       end
7089 #endif
7090 C---------------------------------------------------------------------------
7091       subroutine calc_eello(i,j,k,l,jj,kk)
7092 C
7093 C This subroutine computes matrices and vectors needed to calculate
7094 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7095 C
7096       implicit real*8 (a-h,o-z)
7097       include 'DIMENSIONS'
7098       include 'COMMON.IOUNITS'
7099       include 'COMMON.CHAIN'
7100       include 'COMMON.DERIV'
7101       include 'COMMON.INTERACT'
7102       include 'COMMON.CONTACTS'
7103       include 'COMMON.TORSION'
7104       include 'COMMON.VAR'
7105       include 'COMMON.GEO'
7106       include 'COMMON.FFIELD'
7107       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7108      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7109       logical lprn
7110       common /kutas/ lprn
7111 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7112 cd     & ' jj=',jj,' kk=',kk
7113 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7114 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7115 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7116       do iii=1,2
7117         do jjj=1,2
7118           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7119           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7120         enddo
7121       enddo
7122       call transpose2(aa1(1,1),aa1t(1,1))
7123       call transpose2(aa2(1,1),aa2t(1,1))
7124       do kkk=1,5
7125         do lll=1,3
7126           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7127      &      aa1tder(1,1,lll,kkk))
7128           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7129      &      aa2tder(1,1,lll,kkk))
7130         enddo
7131       enddo
7132       if (l.eq.j+1) then
7133 C parallel orientation of the two CA-CA-CA frames.
7134         if (i.gt.1) then
7135           iti=itortyp(itype(i))
7136         else
7137           iti=ntortyp+1
7138         endif
7139         itk1=itortyp(itype(k+1))
7140         itj=itortyp(itype(j))
7141         if (l.lt.nres-1) then
7142           itl1=itortyp(itype(l+1))
7143         else
7144           itl1=ntortyp+1
7145         endif
7146 C A1 kernel(j+1) A2T
7147 cd        do iii=1,2
7148 cd          write (iout,'(3f10.5,5x,3f10.5)')
7149 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7150 cd        enddo
7151         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7152      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7153      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7154 C Following matrices are needed only for 6-th order cumulants
7155         IF (wcorr6.gt.0.0d0) THEN
7156         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7157      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7158      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7159         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7160      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7161      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7162      &   ADtEAderx(1,1,1,1,1,1))
7163         lprn=.false.
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7165      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7166      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7167      &   ADtEA1derx(1,1,1,1,1,1))
7168         ENDIF
7169 C End 6-th order cumulants
7170 cd        lprn=.false.
7171 cd        if (lprn) then
7172 cd        write (2,*) 'In calc_eello6'
7173 cd        do iii=1,2
7174 cd          write (2,*) 'iii=',iii
7175 cd          do kkk=1,5
7176 cd            write (2,*) 'kkk=',kkk
7177 cd            do jjj=1,2
7178 cd              write (2,'(3(2f10.5),5x)')
7179 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7180 cd            enddo
7181 cd          enddo
7182 cd        enddo
7183 cd        endif
7184         call transpose2(EUgder(1,1,k),auxmat(1,1))
7185         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7186         call transpose2(EUg(1,1,k),auxmat(1,1))
7187         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7188         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7189         do iii=1,2
7190           do kkk=1,5
7191             do lll=1,3
7192               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7193      &          EAEAderx(1,1,lll,kkk,iii,1))
7194             enddo
7195           enddo
7196         enddo
7197 C A1T kernel(i+1) A2
7198         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7199      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7200      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7201 C Following matrices are needed only for 6-th order cumulants
7202         IF (wcorr6.gt.0.0d0) THEN
7203         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7204      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7205      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7206         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7207      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7208      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7209      &   ADtEAderx(1,1,1,1,1,2))
7210         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7211      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7212      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7213      &   ADtEA1derx(1,1,1,1,1,2))
7214         ENDIF
7215 C End 6-th order cumulants
7216         call transpose2(EUgder(1,1,l),auxmat(1,1))
7217         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7218         call transpose2(EUg(1,1,l),auxmat(1,1))
7219         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7220         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7221         do iii=1,2
7222           do kkk=1,5
7223             do lll=1,3
7224               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7225      &          EAEAderx(1,1,lll,kkk,iii,2))
7226             enddo
7227           enddo
7228         enddo
7229 C AEAb1 and AEAb2
7230 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7231 C They are needed only when the fifth- or the sixth-order cumulants are
7232 C indluded.
7233         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7234         call transpose2(AEA(1,1,1),auxmat(1,1))
7235         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7236         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7237         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7238         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7239         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7240         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7241         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7242         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7243         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7244         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7245         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7246         call transpose2(AEA(1,1,2),auxmat(1,1))
7247         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7248         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7249         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7250         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7251         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7252         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7253         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7254         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7255         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7256         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7257         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7258 C Calculate the Cartesian derivatives of the vectors.
7259         do iii=1,2
7260           do kkk=1,5
7261             do lll=1,3
7262               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7263               call matvec2(auxmat(1,1),b1(1,iti),
7264      &          AEAb1derx(1,lll,kkk,iii,1,1))
7265               call matvec2(auxmat(1,1),Ub2(1,i),
7266      &          AEAb2derx(1,lll,kkk,iii,1,1))
7267               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7268      &          AEAb1derx(1,lll,kkk,iii,2,1))
7269               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7270      &          AEAb2derx(1,lll,kkk,iii,2,1))
7271               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7272               call matvec2(auxmat(1,1),b1(1,itj),
7273      &          AEAb1derx(1,lll,kkk,iii,1,2))
7274               call matvec2(auxmat(1,1),Ub2(1,j),
7275      &          AEAb2derx(1,lll,kkk,iii,1,2))
7276               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7277      &          AEAb1derx(1,lll,kkk,iii,2,2))
7278               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7279      &          AEAb2derx(1,lll,kkk,iii,2,2))
7280             enddo
7281           enddo
7282         enddo
7283         ENDIF
7284 C End vectors
7285       else
7286 C Antiparallel orientation of the two CA-CA-CA frames.
7287         if (i.gt.1) then
7288           iti=itortyp(itype(i))
7289         else
7290           iti=ntortyp+1
7291         endif
7292         itk1=itortyp(itype(k+1))
7293         itl=itortyp(itype(l))
7294         itj=itortyp(itype(j))
7295         if (j.lt.nres-1) then
7296           itj1=itortyp(itype(j+1))
7297         else
7298           itj1=ntortyp+1
7299         endif
7300 C A2 kernel(j-1)T A1T
7301         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7302      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7303      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7304 C Following matrices are needed only for 6-th order cumulants
7305         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7306      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7308      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7309      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7310         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7311      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7312      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7313      &   ADtEAderx(1,1,1,1,1,1))
7314         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7315      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7316      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7317      &   ADtEA1derx(1,1,1,1,1,1))
7318         ENDIF
7319 C End 6-th order cumulants
7320         call transpose2(EUgder(1,1,k),auxmat(1,1))
7321         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7322         call transpose2(EUg(1,1,k),auxmat(1,1))
7323         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7324         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7325         do iii=1,2
7326           do kkk=1,5
7327             do lll=1,3
7328               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7329      &          EAEAderx(1,1,lll,kkk,iii,1))
7330             enddo
7331           enddo
7332         enddo
7333 C A2T kernel(i+1)T A1
7334         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7335      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7336      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7337 C Following matrices are needed only for 6-th order cumulants
7338         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7339      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7340         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7341      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7342      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7343         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7344      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7345      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7346      &   ADtEAderx(1,1,1,1,1,2))
7347         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7348      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7349      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7350      &   ADtEA1derx(1,1,1,1,1,2))
7351         ENDIF
7352 C End 6-th order cumulants
7353         call transpose2(EUgder(1,1,j),auxmat(1,1))
7354         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7355         call transpose2(EUg(1,1,j),auxmat(1,1))
7356         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7357         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7358         do iii=1,2
7359           do kkk=1,5
7360             do lll=1,3
7361               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7362      &          EAEAderx(1,1,lll,kkk,iii,2))
7363             enddo
7364           enddo
7365         enddo
7366 C AEAb1 and AEAb2
7367 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7368 C They are needed only when the fifth- or the sixth-order cumulants are
7369 C indluded.
7370         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7371      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7372         call transpose2(AEA(1,1,1),auxmat(1,1))
7373         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7374         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7375         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7376         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7377         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7378         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7379         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7380         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7381         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7382         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7383         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7384         call transpose2(AEA(1,1,2),auxmat(1,1))
7385         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7386         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7387         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7388         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7389         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7390         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7391         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7392         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7393         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7394         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7395         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7396 C Calculate the Cartesian derivatives of the vectors.
7397         do iii=1,2
7398           do kkk=1,5
7399             do lll=1,3
7400               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7401               call matvec2(auxmat(1,1),b1(1,iti),
7402      &          AEAb1derx(1,lll,kkk,iii,1,1))
7403               call matvec2(auxmat(1,1),Ub2(1,i),
7404      &          AEAb2derx(1,lll,kkk,iii,1,1))
7405               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7406      &          AEAb1derx(1,lll,kkk,iii,2,1))
7407               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7408      &          AEAb2derx(1,lll,kkk,iii,2,1))
7409               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7410               call matvec2(auxmat(1,1),b1(1,itl),
7411      &          AEAb1derx(1,lll,kkk,iii,1,2))
7412               call matvec2(auxmat(1,1),Ub2(1,l),
7413      &          AEAb2derx(1,lll,kkk,iii,1,2))
7414               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7415      &          AEAb1derx(1,lll,kkk,iii,2,2))
7416               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7417      &          AEAb2derx(1,lll,kkk,iii,2,2))
7418             enddo
7419           enddo
7420         enddo
7421         ENDIF
7422 C End vectors
7423       endif
7424       return
7425       end
7426 C---------------------------------------------------------------------------
7427       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7428      &  KK,KKderg,AKA,AKAderg,AKAderx)
7429       implicit none
7430       integer nderg
7431       logical transp
7432       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7433      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7434      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7435       integer iii,kkk,lll
7436       integer jjj,mmm
7437       logical lprn
7438       common /kutas/ lprn
7439       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7440       do iii=1,nderg
7441         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7442      &    AKAderg(1,1,iii))
7443       enddo
7444 cd      if (lprn) write (2,*) 'In kernel'
7445       do kkk=1,5
7446 cd        if (lprn) write (2,*) 'kkk=',kkk
7447         do lll=1,3
7448           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7449      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7450 cd          if (lprn) then
7451 cd            write (2,*) 'lll=',lll
7452 cd            write (2,*) 'iii=1'
7453 cd            do jjj=1,2
7454 cd              write (2,'(3(2f10.5),5x)')
7455 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7456 cd            enddo
7457 cd          endif
7458           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7459      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7460 cd          if (lprn) then
7461 cd            write (2,*) 'lll=',lll
7462 cd            write (2,*) 'iii=2'
7463 cd            do jjj=1,2
7464 cd              write (2,'(3(2f10.5),5x)')
7465 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7466 cd            enddo
7467 cd          endif
7468         enddo
7469       enddo
7470       return
7471       end
7472 C---------------------------------------------------------------------------
7473       double precision function eello4(i,j,k,l,jj,kk)
7474       implicit real*8 (a-h,o-z)
7475       include 'DIMENSIONS'
7476       include 'COMMON.IOUNITS'
7477       include 'COMMON.CHAIN'
7478       include 'COMMON.DERIV'
7479       include 'COMMON.INTERACT'
7480       include 'COMMON.CONTACTS'
7481       include 'COMMON.TORSION'
7482       include 'COMMON.VAR'
7483       include 'COMMON.GEO'
7484       double precision pizda(2,2),ggg1(3),ggg2(3)
7485 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7486 cd        eello4=0.0d0
7487 cd        return
7488 cd      endif
7489 cd      print *,'eello4:',i,j,k,l,jj,kk
7490 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7491 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7492 cold      eij=facont_hb(jj,i)
7493 cold      ekl=facont_hb(kk,k)
7494 cold      ekont=eij*ekl
7495       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7496 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7497       gcorr_loc(k-1)=gcorr_loc(k-1)
7498      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7499       if (l.eq.j+1) then
7500         gcorr_loc(l-1)=gcorr_loc(l-1)
7501      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7502       else
7503         gcorr_loc(j-1)=gcorr_loc(j-1)
7504      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7505       endif
7506       do iii=1,2
7507         do kkk=1,5
7508           do lll=1,3
7509             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7510      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7511 cd            derx(lll,kkk,iii)=0.0d0
7512           enddo
7513         enddo
7514       enddo
7515 cd      gcorr_loc(l-1)=0.0d0
7516 cd      gcorr_loc(j-1)=0.0d0
7517 cd      gcorr_loc(k-1)=0.0d0
7518 cd      eel4=1.0d0
7519 cd      write (iout,*)'Contacts have occurred for peptide groups',
7520 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7521 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7522       if (j.lt.nres-1) then
7523         j1=j+1
7524         j2=j-1
7525       else
7526         j1=j-1
7527         j2=j-2
7528       endif
7529       if (l.lt.nres-1) then
7530         l1=l+1
7531         l2=l-1
7532       else
7533         l1=l-1
7534         l2=l-2
7535       endif
7536       do ll=1,3
7537 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7538 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7539         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7540         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7541 cgrad        ghalf=0.5d0*ggg1(ll)
7542         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7543         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7544         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7545         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7546         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7547         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7548 cgrad        ghalf=0.5d0*ggg2(ll)
7549         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7550         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7551         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7552         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7553         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7554         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7555       enddo
7556 cgrad      do m=i+1,j-1
7557 cgrad        do ll=1,3
7558 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7559 cgrad        enddo
7560 cgrad      enddo
7561 cgrad      do m=k+1,l-1
7562 cgrad        do ll=1,3
7563 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7564 cgrad        enddo
7565 cgrad      enddo
7566 cgrad      do m=i+2,j2
7567 cgrad        do ll=1,3
7568 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7569 cgrad        enddo
7570 cgrad      enddo
7571 cgrad      do m=k+2,l2
7572 cgrad        do ll=1,3
7573 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7574 cgrad        enddo
7575 cgrad      enddo
7576 cd      do iii=1,nres-3
7577 cd        write (2,*) iii,gcorr_loc(iii)
7578 cd      enddo
7579       eello4=ekont*eel4
7580 cd      write (2,*) 'ekont',ekont
7581 cd      write (iout,*) 'eello4',ekont*eel4
7582       return
7583       end
7584 C---------------------------------------------------------------------------
7585       double precision function eello5(i,j,k,l,jj,kk)
7586       implicit real*8 (a-h,o-z)
7587       include 'DIMENSIONS'
7588       include 'COMMON.IOUNITS'
7589       include 'COMMON.CHAIN'
7590       include 'COMMON.DERIV'
7591       include 'COMMON.INTERACT'
7592       include 'COMMON.CONTACTS'
7593       include 'COMMON.TORSION'
7594       include 'COMMON.VAR'
7595       include 'COMMON.GEO'
7596       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7597       double precision ggg1(3),ggg2(3)
7598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7599 C                                                                              C
7600 C                            Parallel chains                                   C
7601 C                                                                              C
7602 C          o             o                   o             o                   C
7603 C         /l\           / \             \   / \           / \   /              C
7604 C        /   \         /   \             \ /   \         /   \ /               C
7605 C       j| o |l1       | o |              o| o |         | o |o                C
7606 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7607 C      \i/   \         /   \ /             /   \         /   \                 C
7608 C       o    k1             o                                                  C
7609 C         (I)          (II)                (III)          (IV)                 C
7610 C                                                                              C
7611 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7612 C                                                                              C
7613 C                            Antiparallel chains                               C
7614 C                                                                              C
7615 C          o             o                   o             o                   C
7616 C         /j\           / \             \   / \           / \   /              C
7617 C        /   \         /   \             \ /   \         /   \ /               C
7618 C      j1| o |l        | o |              o| o |         | o |o                C
7619 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7620 C      \i/   \         /   \ /             /   \         /   \                 C
7621 C       o     k1            o                                                  C
7622 C         (I)          (II)                (III)          (IV)                 C
7623 C                                                                              C
7624 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7625 C                                                                              C
7626 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7627 C                                                                              C
7628 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7629 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7630 cd        eello5=0.0d0
7631 cd        return
7632 cd      endif
7633 cd      write (iout,*)
7634 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7635 cd     &   ' and',k,l
7636       itk=itortyp(itype(k))
7637       itl=itortyp(itype(l))
7638       itj=itortyp(itype(j))
7639       eello5_1=0.0d0
7640       eello5_2=0.0d0
7641       eello5_3=0.0d0
7642       eello5_4=0.0d0
7643 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7644 cd     &   eel5_3_num,eel5_4_num)
7645       do iii=1,2
7646         do kkk=1,5
7647           do lll=1,3
7648             derx(lll,kkk,iii)=0.0d0
7649           enddo
7650         enddo
7651       enddo
7652 cd      eij=facont_hb(jj,i)
7653 cd      ekl=facont_hb(kk,k)
7654 cd      ekont=eij*ekl
7655 cd      write (iout,*)'Contacts have occurred for peptide groups',
7656 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7657 cd      goto 1111
7658 C Contribution from the graph I.
7659 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7660 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7661       call transpose2(EUg(1,1,k),auxmat(1,1))
7662       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7663       vv(1)=pizda(1,1)-pizda(2,2)
7664       vv(2)=pizda(1,2)+pizda(2,1)
7665       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7666      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7667 C Explicit gradient in virtual-dihedral angles.
7668       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7669      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7670      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7671       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7672       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7673       vv(1)=pizda(1,1)-pizda(2,2)
7674       vv(2)=pizda(1,2)+pizda(2,1)
7675       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7676      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7677      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7678       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7679       vv(1)=pizda(1,1)-pizda(2,2)
7680       vv(2)=pizda(1,2)+pizda(2,1)
7681       if (l.eq.j+1) then
7682         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7683      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7684      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7685       else
7686         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7687      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7688      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7689       endif
7690 C Cartesian gradient
7691       do iii=1,2
7692         do kkk=1,5
7693           do lll=1,3
7694             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7695      &        pizda(1,1))
7696             vv(1)=pizda(1,1)-pizda(2,2)
7697             vv(2)=pizda(1,2)+pizda(2,1)
7698             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7699      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7700      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7701           enddo
7702         enddo
7703       enddo
7704 c      goto 1112
7705 c1111  continue
7706 C Contribution from graph II
7707       call transpose2(EE(1,1,itk),auxmat(1,1))
7708       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7709       vv(1)=pizda(1,1)+pizda(2,2)
7710       vv(2)=pizda(2,1)-pizda(1,2)
7711       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7712      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7713 C Explicit gradient in virtual-dihedral angles.
7714       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7715      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7716       call matmat2(auxmat(1,1),AEAderg(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       if (l.eq.j+1) then
7720         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7721      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7722      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7723       else
7724         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7725      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7726      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7727       endif
7728 C Cartesian gradient
7729       do iii=1,2
7730         do kkk=1,5
7731           do lll=1,3
7732             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7733      &        pizda(1,1))
7734             vv(1)=pizda(1,1)+pizda(2,2)
7735             vv(2)=pizda(2,1)-pizda(1,2)
7736             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7737      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7738      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7739           enddo
7740         enddo
7741       enddo
7742 cd      goto 1112
7743 cd1111  continue
7744       if (l.eq.j+1) then
7745 cd        goto 1110
7746 C Parallel orientation
7747 C Contribution from graph III
7748         call transpose2(EUg(1,1,l),auxmat(1,1))
7749         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7750         vv(1)=pizda(1,1)-pizda(2,2)
7751         vv(2)=pizda(1,2)+pizda(2,1)
7752         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7753      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7754 C Explicit gradient in virtual-dihedral angles.
7755         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7756      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7757      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7758         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7759         vv(1)=pizda(1,1)-pizda(2,2)
7760         vv(2)=pizda(1,2)+pizda(2,1)
7761         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7762      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7763      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7764         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7765         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7766         vv(1)=pizda(1,1)-pizda(2,2)
7767         vv(2)=pizda(1,2)+pizda(2,1)
7768         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7769      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7770      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7771 C Cartesian gradient
7772         do iii=1,2
7773           do kkk=1,5
7774             do lll=1,3
7775               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7776      &          pizda(1,1))
7777               vv(1)=pizda(1,1)-pizda(2,2)
7778               vv(2)=pizda(1,2)+pizda(2,1)
7779               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7780      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7781      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7782             enddo
7783           enddo
7784         enddo
7785 cd        goto 1112
7786 C Contribution from graph IV
7787 cd1110    continue
7788         call transpose2(EE(1,1,itl),auxmat(1,1))
7789         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7790         vv(1)=pizda(1,1)+pizda(2,2)
7791         vv(2)=pizda(2,1)-pizda(1,2)
7792         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7793      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7794 C Explicit gradient in virtual-dihedral angles.
7795         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7796      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7797         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7801      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7802      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7803 C Cartesian gradient
7804         do iii=1,2
7805           do kkk=1,5
7806             do lll=1,3
7807               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7808      &          pizda(1,1))
7809               vv(1)=pizda(1,1)+pizda(2,2)
7810               vv(2)=pizda(2,1)-pizda(1,2)
7811               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7812      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7813      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7814             enddo
7815           enddo
7816         enddo
7817       else
7818 C Antiparallel orientation
7819 C Contribution from graph III
7820 c        goto 1110
7821         call transpose2(EUg(1,1,j),auxmat(1,1))
7822         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7823         vv(1)=pizda(1,1)-pizda(2,2)
7824         vv(2)=pizda(1,2)+pizda(2,1)
7825         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7826      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7827 C Explicit gradient in virtual-dihedral angles.
7828         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7829      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7830      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7831         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7832         vv(1)=pizda(1,1)-pizda(2,2)
7833         vv(2)=pizda(1,2)+pizda(2,1)
7834         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7835      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7836      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7837         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7838         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7839         vv(1)=pizda(1,1)-pizda(2,2)
7840         vv(2)=pizda(1,2)+pizda(2,1)
7841         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7842      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7843      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7844 C Cartesian gradient
7845         do iii=1,2
7846           do kkk=1,5
7847             do lll=1,3
7848               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7849      &          pizda(1,1))
7850               vv(1)=pizda(1,1)-pizda(2,2)
7851               vv(2)=pizda(1,2)+pizda(2,1)
7852               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7853      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7854      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7855             enddo
7856           enddo
7857         enddo
7858 cd        goto 1112
7859 C Contribution from graph IV
7860 1110    continue
7861         call transpose2(EE(1,1,itj),auxmat(1,1))
7862         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7863         vv(1)=pizda(1,1)+pizda(2,2)
7864         vv(2)=pizda(2,1)-pizda(1,2)
7865         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7866      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7867 C Explicit gradient in virtual-dihedral angles.
7868         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7869      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7870         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7874      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7875      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7876 C Cartesian gradient
7877         do iii=1,2
7878           do kkk=1,5
7879             do lll=1,3
7880               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7881      &          pizda(1,1))
7882               vv(1)=pizda(1,1)+pizda(2,2)
7883               vv(2)=pizda(2,1)-pizda(1,2)
7884               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7885      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7886      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7887             enddo
7888           enddo
7889         enddo
7890       endif
7891 1112  continue
7892       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7893 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7894 cd        write (2,*) 'ijkl',i,j,k,l
7895 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7896 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7897 cd      endif
7898 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7899 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7900 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7901 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7902       if (j.lt.nres-1) then
7903         j1=j+1
7904         j2=j-1
7905       else
7906         j1=j-1
7907         j2=j-2
7908       endif
7909       if (l.lt.nres-1) then
7910         l1=l+1
7911         l2=l-1
7912       else
7913         l1=l-1
7914         l2=l-2
7915       endif
7916 cd      eij=1.0d0
7917 cd      ekl=1.0d0
7918 cd      ekont=1.0d0
7919 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7920 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7921 C        summed up outside the subrouine as for the other subroutines
7922 C        handling long-range interactions. The old code is commented out
7923 C        with "cgrad" to keep track of changes.
7924       do ll=1,3
7925 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7926 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7927         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7928         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7929 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7930 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7931 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7932 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7933 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7934 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7935 c     &   gradcorr5ij,
7936 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7937 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7938 cgrad        ghalf=0.5d0*ggg1(ll)
7939 cd        ghalf=0.0d0
7940         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7941         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7942         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7943         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7944         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7945         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7946 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7947 cgrad        ghalf=0.5d0*ggg2(ll)
7948 cd        ghalf=0.0d0
7949         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7950         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7951         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7952         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7953         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7954         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7955       enddo
7956 cd      goto 1112
7957 cgrad      do m=i+1,j-1
7958 cgrad        do ll=1,3
7959 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7960 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7961 cgrad        enddo
7962 cgrad      enddo
7963 cgrad      do m=k+1,l-1
7964 cgrad        do ll=1,3
7965 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7966 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7967 cgrad        enddo
7968 cgrad      enddo
7969 c1112  continue
7970 cgrad      do m=i+2,j2
7971 cgrad        do ll=1,3
7972 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7973 cgrad        enddo
7974 cgrad      enddo
7975 cgrad      do m=k+2,l2
7976 cgrad        do ll=1,3
7977 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7978 cgrad        enddo
7979 cgrad      enddo
7980 cd      do iii=1,nres-3
7981 cd        write (2,*) iii,g_corr5_loc(iii)
7982 cd      enddo
7983       eello5=ekont*eel5
7984 cd      write (2,*) 'ekont',ekont
7985 cd      write (iout,*) 'eello5',ekont*eel5
7986       return
7987       end
7988 c--------------------------------------------------------------------------
7989       double precision function eello6(i,j,k,l,jj,kk)
7990       implicit real*8 (a-h,o-z)
7991       include 'DIMENSIONS'
7992       include 'COMMON.IOUNITS'
7993       include 'COMMON.CHAIN'
7994       include 'COMMON.DERIV'
7995       include 'COMMON.INTERACT'
7996       include 'COMMON.CONTACTS'
7997       include 'COMMON.TORSION'
7998       include 'COMMON.VAR'
7999       include 'COMMON.GEO'
8000       include 'COMMON.FFIELD'
8001       double precision ggg1(3),ggg2(3)
8002 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8003 cd        eello6=0.0d0
8004 cd        return
8005 cd      endif
8006 cd      write (iout,*)
8007 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8008 cd     &   ' and',k,l
8009       eello6_1=0.0d0
8010       eello6_2=0.0d0
8011       eello6_3=0.0d0
8012       eello6_4=0.0d0
8013       eello6_5=0.0d0
8014       eello6_6=0.0d0
8015 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8016 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8017       do iii=1,2
8018         do kkk=1,5
8019           do lll=1,3
8020             derx(lll,kkk,iii)=0.0d0
8021           enddo
8022         enddo
8023       enddo
8024 cd      eij=facont_hb(jj,i)
8025 cd      ekl=facont_hb(kk,k)
8026 cd      ekont=eij*ekl
8027 cd      eij=1.0d0
8028 cd      ekl=1.0d0
8029 cd      ekont=1.0d0
8030       if (l.eq.j+1) then
8031         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8032         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8033         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8034         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8035         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8036         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8037       else
8038         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8039         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8040         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8041         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8042         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8043           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8044         else
8045           eello6_5=0.0d0
8046         endif
8047         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8048       endif
8049 C If turn contributions are considered, they will be handled separately.
8050       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8051 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8052 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8053 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8054 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8055 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8056 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8057 cd      goto 1112
8058       if (j.lt.nres-1) then
8059         j1=j+1
8060         j2=j-1
8061       else
8062         j1=j-1
8063         j2=j-2
8064       endif
8065       if (l.lt.nres-1) then
8066         l1=l+1
8067         l2=l-1
8068       else
8069         l1=l-1
8070         l2=l-2
8071       endif
8072       do ll=1,3
8073 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8074 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8075 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8076 cgrad        ghalf=0.5d0*ggg1(ll)
8077 cd        ghalf=0.0d0
8078         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8079         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8080         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8081         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8082         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8083         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8084         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8085         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8086 cgrad        ghalf=0.5d0*ggg2(ll)
8087 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8088 cd        ghalf=0.0d0
8089         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8090         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8091         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8092         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8093         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8094         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8095       enddo
8096 cd      goto 1112
8097 cgrad      do m=i+1,j-1
8098 cgrad        do ll=1,3
8099 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8100 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8101 cgrad        enddo
8102 cgrad      enddo
8103 cgrad      do m=k+1,l-1
8104 cgrad        do ll=1,3
8105 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8106 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8107 cgrad        enddo
8108 cgrad      enddo
8109 cgrad1112  continue
8110 cgrad      do m=i+2,j2
8111 cgrad        do ll=1,3
8112 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8113 cgrad        enddo
8114 cgrad      enddo
8115 cgrad      do m=k+2,l2
8116 cgrad        do ll=1,3
8117 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8118 cgrad        enddo
8119 cgrad      enddo
8120 cd      do iii=1,nres-3
8121 cd        write (2,*) iii,g_corr6_loc(iii)
8122 cd      enddo
8123       eello6=ekont*eel6
8124 cd      write (2,*) 'ekont',ekont
8125 cd      write (iout,*) 'eello6',ekont*eel6
8126       return
8127       end
8128 c--------------------------------------------------------------------------
8129       double precision function eello6_graph1(i,j,k,l,imat,swap)
8130       implicit real*8 (a-h,o-z)
8131       include 'DIMENSIONS'
8132       include 'COMMON.IOUNITS'
8133       include 'COMMON.CHAIN'
8134       include 'COMMON.DERIV'
8135       include 'COMMON.INTERACT'
8136       include 'COMMON.CONTACTS'
8137       include 'COMMON.TORSION'
8138       include 'COMMON.VAR'
8139       include 'COMMON.GEO'
8140       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8141       logical swap
8142       logical lprn
8143       common /kutas/ lprn
8144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8145 C
8146 C      Parallel       Antiparallel
8147 C
8148 C          o             o
8149 C         /l\           /j\
8150 C        /   \         /   \
8151 C       /| o |         | o |\
8152 C     \ j|/k\|  /   \  |/k\|l /
8153 C      \ /   \ /     \ /   \ /
8154 C       o     o       o     o
8155 C       i             i
8156 C
8157 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8158       itk=itortyp(itype(k))
8159       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8160       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8161       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8162       call transpose2(EUgC(1,1,k),auxmat(1,1))
8163       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8164       vv1(1)=pizda1(1,1)-pizda1(2,2)
8165       vv1(2)=pizda1(1,2)+pizda1(2,1)
8166       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8167       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8168       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8169       s5=scalar2(vv(1),Dtobr2(1,i))
8170 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8171       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8172       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8173      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8174      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8175      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8176      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8177      & +scalar2(vv(1),Dtobr2der(1,i)))
8178       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8179       vv1(1)=pizda1(1,1)-pizda1(2,2)
8180       vv1(2)=pizda1(1,2)+pizda1(2,1)
8181       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8182       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8183       if (l.eq.j+1) then
8184         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8185      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8186      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8187      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8188      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8189       else
8190         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8191      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8192      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8193      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8194      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8195       endif
8196       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8197       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8198       vv1(1)=pizda1(1,1)-pizda1(2,2)
8199       vv1(2)=pizda1(1,2)+pizda1(2,1)
8200       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8201      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8202      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8203      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8204       do iii=1,2
8205         if (swap) then
8206           ind=3-iii
8207         else
8208           ind=iii
8209         endif
8210         do kkk=1,5
8211           do lll=1,3
8212             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8213             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8214             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8215             call transpose2(EUgC(1,1,k),auxmat(1,1))
8216             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8217      &        pizda1(1,1))
8218             vv1(1)=pizda1(1,1)-pizda1(2,2)
8219             vv1(2)=pizda1(1,2)+pizda1(2,1)
8220             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8221             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8222      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8223             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8224      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8225             s5=scalar2(vv(1),Dtobr2(1,i))
8226             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8227           enddo
8228         enddo
8229       enddo
8230       return
8231       end
8232 c----------------------------------------------------------------------------
8233       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8234       implicit real*8 (a-h,o-z)
8235       include 'DIMENSIONS'
8236       include 'COMMON.IOUNITS'
8237       include 'COMMON.CHAIN'
8238       include 'COMMON.DERIV'
8239       include 'COMMON.INTERACT'
8240       include 'COMMON.CONTACTS'
8241       include 'COMMON.TORSION'
8242       include 'COMMON.VAR'
8243       include 'COMMON.GEO'
8244       logical swap
8245       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8246      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8247       logical lprn
8248       common /kutas/ lprn
8249 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8250 C                                                                              C
8251 C      Parallel       Antiparallel                                             C
8252 C                                                                              C
8253 C          o             o                                                     C
8254 C     \   /l\           /j\   /                                                C
8255 C      \ /   \         /   \ /                                                 C
8256 C       o| o |         | o |o                                                  C
8257 C     \ j|/k\|      \  |/k\|l                                                  C
8258 C      \ /   \       \ /   \                                                   C
8259 C       o             o                                                        C
8260 C       i             i                                                        C
8261 C                                                                              C
8262 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8263 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8264 C AL 7/4/01 s1 would occur in the sixth-order moment,
8265 C           but not in a cluster cumulant
8266 #ifdef MOMENT
8267       s1=dip(1,jj,i)*dip(1,kk,k)
8268 #endif
8269       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8270       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8271       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8272       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8273       call transpose2(EUg(1,1,k),auxmat(1,1))
8274       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8275       vv(1)=pizda(1,1)-pizda(2,2)
8276       vv(2)=pizda(1,2)+pizda(2,1)
8277       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8278 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8279 #ifdef MOMENT
8280       eello6_graph2=-(s1+s2+s3+s4)
8281 #else
8282       eello6_graph2=-(s2+s3+s4)
8283 #endif
8284 c      eello6_graph2=-s3
8285 C Derivatives in gamma(i-1)
8286       if (i.gt.1) then
8287 #ifdef MOMENT
8288         s1=dipderg(1,jj,i)*dip(1,kk,k)
8289 #endif
8290         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8291         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8292         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8293         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8294 #ifdef MOMENT
8295         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8296 #else
8297         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8298 #endif
8299 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8300       endif
8301 C Derivatives in gamma(k-1)
8302 #ifdef MOMENT
8303       s1=dip(1,jj,i)*dipderg(1,kk,k)
8304 #endif
8305       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8306       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8307       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8308       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8309       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8310       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8311       vv(1)=pizda(1,1)-pizda(2,2)
8312       vv(2)=pizda(1,2)+pizda(2,1)
8313       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8314 #ifdef MOMENT
8315       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8316 #else
8317       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8318 #endif
8319 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8320 C Derivatives in gamma(j-1) or gamma(l-1)
8321       if (j.gt.1) then
8322 #ifdef MOMENT
8323         s1=dipderg(3,jj,i)*dip(1,kk,k)
8324 #endif
8325         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8326         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8327         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8328         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8329         vv(1)=pizda(1,1)-pizda(2,2)
8330         vv(2)=pizda(1,2)+pizda(2,1)
8331         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8332 #ifdef MOMENT
8333         if (swap) then
8334           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8335         else
8336           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8337         endif
8338 #endif
8339         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8340 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8341       endif
8342 C Derivatives in gamma(l-1) or gamma(j-1)
8343       if (l.gt.1) then
8344 #ifdef MOMENT
8345         s1=dip(1,jj,i)*dipderg(3,kk,k)
8346 #endif
8347         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8348         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8349         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8350         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8351         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8352         vv(1)=pizda(1,1)-pizda(2,2)
8353         vv(2)=pizda(1,2)+pizda(2,1)
8354         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8355 #ifdef MOMENT
8356         if (swap) then
8357           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8358         else
8359           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8360         endif
8361 #endif
8362         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8363 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8364       endif
8365 C Cartesian derivatives.
8366       if (lprn) then
8367         write (2,*) 'In eello6_graph2'
8368         do iii=1,2
8369           write (2,*) 'iii=',iii
8370           do kkk=1,5
8371             write (2,*) 'kkk=',kkk
8372             do jjj=1,2
8373               write (2,'(3(2f10.5),5x)')
8374      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8375             enddo
8376           enddo
8377         enddo
8378       endif
8379       do iii=1,2
8380         do kkk=1,5
8381           do lll=1,3
8382 #ifdef MOMENT
8383             if (iii.eq.1) then
8384               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8385             else
8386               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8387             endif
8388 #endif
8389             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8390      &        auxvec(1))
8391             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8392             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8393      &        auxvec(1))
8394             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8395             call transpose2(EUg(1,1,k),auxmat(1,1))
8396             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8397      &        pizda(1,1))
8398             vv(1)=pizda(1,1)-pizda(2,2)
8399             vv(2)=pizda(1,2)+pizda(2,1)
8400             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8401 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8402 #ifdef MOMENT
8403             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8404 #else
8405             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8406 #endif
8407             if (swap) then
8408               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8409             else
8410               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8411             endif
8412           enddo
8413         enddo
8414       enddo
8415       return
8416       end
8417 c----------------------------------------------------------------------------
8418       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8419       implicit real*8 (a-h,o-z)
8420       include 'DIMENSIONS'
8421       include 'COMMON.IOUNITS'
8422       include 'COMMON.CHAIN'
8423       include 'COMMON.DERIV'
8424       include 'COMMON.INTERACT'
8425       include 'COMMON.CONTACTS'
8426       include 'COMMON.TORSION'
8427       include 'COMMON.VAR'
8428       include 'COMMON.GEO'
8429       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8430       logical swap
8431 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8432 C                                                                              C
8433 C      Parallel       Antiparallel                                             C
8434 C                                                                              C
8435 C          o             o                                                     C
8436 C         /l\   /   \   /j\                                                    C
8437 C        /   \ /     \ /   \                                                   C
8438 C       /| o |o       o| o |\                                                  C
8439 C       j|/k\|  /      |/k\|l /                                                C
8440 C        /   \ /       /   \ /                                                 C
8441 C       /     o       /     o                                                  C
8442 C       i             i                                                        C
8443 C                                                                              C
8444 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8445 C
8446 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8447 C           energy moment and not to the cluster cumulant.
8448       iti=itortyp(itype(i))
8449       if (j.lt.nres-1) then
8450         itj1=itortyp(itype(j+1))
8451       else
8452         itj1=ntortyp+1
8453       endif
8454       itk=itortyp(itype(k))
8455       itk1=itortyp(itype(k+1))
8456       if (l.lt.nres-1) then
8457         itl1=itortyp(itype(l+1))
8458       else
8459         itl1=ntortyp+1
8460       endif
8461 #ifdef MOMENT
8462       s1=dip(4,jj,i)*dip(4,kk,k)
8463 #endif
8464       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8465       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8466       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8467       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8468       call transpose2(EE(1,1,itk),auxmat(1,1))
8469       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8470       vv(1)=pizda(1,1)+pizda(2,2)
8471       vv(2)=pizda(2,1)-pizda(1,2)
8472       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8473 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8474 cd     & "sum",-(s2+s3+s4)
8475 #ifdef MOMENT
8476       eello6_graph3=-(s1+s2+s3+s4)
8477 #else
8478       eello6_graph3=-(s2+s3+s4)
8479 #endif
8480 c      eello6_graph3=-s4
8481 C Derivatives in gamma(k-1)
8482       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8483       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8484       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8485       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8486 C Derivatives in gamma(l-1)
8487       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8488       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8489       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8490       vv(1)=pizda(1,1)+pizda(2,2)
8491       vv(2)=pizda(2,1)-pizda(1,2)
8492       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8493       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8494 C Cartesian derivatives.
8495       do iii=1,2
8496         do kkk=1,5
8497           do lll=1,3
8498 #ifdef MOMENT
8499             if (iii.eq.1) then
8500               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8501             else
8502               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8503             endif
8504 #endif
8505             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8506      &        auxvec(1))
8507             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8508             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8509      &        auxvec(1))
8510             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8511             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8512      &        pizda(1,1))
8513             vv(1)=pizda(1,1)+pizda(2,2)
8514             vv(2)=pizda(2,1)-pizda(1,2)
8515             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8516 #ifdef MOMENT
8517             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8518 #else
8519             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8520 #endif
8521             if (swap) then
8522               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8523             else
8524               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8525             endif
8526 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8527           enddo
8528         enddo
8529       enddo
8530       return
8531       end
8532 c----------------------------------------------------------------------------
8533       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8534       implicit real*8 (a-h,o-z)
8535       include 'DIMENSIONS'
8536       include 'COMMON.IOUNITS'
8537       include 'COMMON.CHAIN'
8538       include 'COMMON.DERIV'
8539       include 'COMMON.INTERACT'
8540       include 'COMMON.CONTACTS'
8541       include 'COMMON.TORSION'
8542       include 'COMMON.VAR'
8543       include 'COMMON.GEO'
8544       include 'COMMON.FFIELD'
8545       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8546      & auxvec1(2),auxmat1(2,2)
8547       logical swap
8548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8549 C                                                                              C
8550 C      Parallel       Antiparallel                                             C
8551 C                                                                              C
8552 C          o             o                                                     C
8553 C         /l\   /   \   /j\                                                    C
8554 C        /   \ /     \ /   \                                                   C
8555 C       /| o |o       o| o |\                                                  C
8556 C     \ j|/k\|      \  |/k\|l                                                  C
8557 C      \ /   \       \ /   \                                                   C
8558 C       o     \       o     \                                                  C
8559 C       i             i                                                        C
8560 C                                                                              C
8561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8562 C
8563 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8564 C           energy moment and not to the cluster cumulant.
8565 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8566       iti=itortyp(itype(i))
8567       itj=itortyp(itype(j))
8568       if (j.lt.nres-1) then
8569         itj1=itortyp(itype(j+1))
8570       else
8571         itj1=ntortyp+1
8572       endif
8573       itk=itortyp(itype(k))
8574       if (k.lt.nres-1) then
8575         itk1=itortyp(itype(k+1))
8576       else
8577         itk1=ntortyp+1
8578       endif
8579       itl=itortyp(itype(l))
8580       if (l.lt.nres-1) then
8581         itl1=itortyp(itype(l+1))
8582       else
8583         itl1=ntortyp+1
8584       endif
8585 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8586 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8587 cd     & ' itl',itl,' itl1',itl1
8588 #ifdef MOMENT
8589       if (imat.eq.1) then
8590         s1=dip(3,jj,i)*dip(3,kk,k)
8591       else
8592         s1=dip(2,jj,j)*dip(2,kk,l)
8593       endif
8594 #endif
8595       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8596       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8597       if (j.eq.l+1) then
8598         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8599         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8600       else
8601         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8602         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8603       endif
8604       call transpose2(EUg(1,1,k),auxmat(1,1))
8605       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8606       vv(1)=pizda(1,1)-pizda(2,2)
8607       vv(2)=pizda(2,1)+pizda(1,2)
8608       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8609 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8610 #ifdef MOMENT
8611       eello6_graph4=-(s1+s2+s3+s4)
8612 #else
8613       eello6_graph4=-(s2+s3+s4)
8614 #endif
8615 C Derivatives in gamma(i-1)
8616       if (i.gt.1) then
8617 #ifdef MOMENT
8618         if (imat.eq.1) then
8619           s1=dipderg(2,jj,i)*dip(3,kk,k)
8620         else
8621           s1=dipderg(4,jj,j)*dip(2,kk,l)
8622         endif
8623 #endif
8624         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8625         if (j.eq.l+1) then
8626           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8627           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8628         else
8629           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8630           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8631         endif
8632         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8633         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8634 cd          write (2,*) 'turn6 derivatives'
8635 #ifdef MOMENT
8636           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8637 #else
8638           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8639 #endif
8640         else
8641 #ifdef MOMENT
8642           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8643 #else
8644           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8645 #endif
8646         endif
8647       endif
8648 C Derivatives in gamma(k-1)
8649 #ifdef MOMENT
8650       if (imat.eq.1) then
8651         s1=dip(3,jj,i)*dipderg(2,kk,k)
8652       else
8653         s1=dip(2,jj,j)*dipderg(4,kk,l)
8654       endif
8655 #endif
8656       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8657       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8658       if (j.eq.l+1) then
8659         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8660         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8661       else
8662         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8663         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8664       endif
8665       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8666       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8667       vv(1)=pizda(1,1)-pizda(2,2)
8668       vv(2)=pizda(2,1)+pizda(1,2)
8669       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8670       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8671 #ifdef MOMENT
8672         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8673 #else
8674         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8675 #endif
8676       else
8677 #ifdef MOMENT
8678         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8679 #else
8680         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8681 #endif
8682       endif
8683 C Derivatives in gamma(j-1) or gamma(l-1)
8684       if (l.eq.j+1 .and. l.gt.1) then
8685         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8686         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8687         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8688         vv(1)=pizda(1,1)-pizda(2,2)
8689         vv(2)=pizda(2,1)+pizda(1,2)
8690         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8691         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8692       else if (j.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         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8700           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8701         else
8702           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8703         endif
8704       endif
8705 C Cartesian derivatives.
8706       do iii=1,2
8707         do kkk=1,5
8708           do lll=1,3
8709 #ifdef MOMENT
8710             if (iii.eq.1) then
8711               if (imat.eq.1) then
8712                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8713               else
8714                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8715               endif
8716             else
8717               if (imat.eq.1) then
8718                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8719               else
8720                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8721               endif
8722             endif
8723 #endif
8724             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8725      &        auxvec(1))
8726             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8727             if (j.eq.l+1) then
8728               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8729      &          b1(1,itj1),auxvec(1))
8730               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8731             else
8732               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8733      &          b1(1,itl1),auxvec(1))
8734               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8735             endif
8736             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8737      &        pizda(1,1))
8738             vv(1)=pizda(1,1)-pizda(2,2)
8739             vv(2)=pizda(2,1)+pizda(1,2)
8740             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8741             if (swap) then
8742               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8743 #ifdef MOMENT
8744                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8745      &             -(s1+s2+s4)
8746 #else
8747                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8748      &             -(s2+s4)
8749 #endif
8750                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8751               else
8752 #ifdef MOMENT
8753                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8754 #else
8755                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8756 #endif
8757                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8758               endif
8759             else
8760 #ifdef MOMENT
8761               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8762 #else
8763               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8764 #endif
8765               if (l.eq.j+1) then
8766                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8767               else
8768                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8769               endif
8770             endif
8771           enddo
8772         enddo
8773       enddo
8774       return
8775       end
8776 c----------------------------------------------------------------------------
8777       double precision function eello_turn6(i,jj,kk)
8778       implicit real*8 (a-h,o-z)
8779       include 'DIMENSIONS'
8780       include 'COMMON.IOUNITS'
8781       include 'COMMON.CHAIN'
8782       include 'COMMON.DERIV'
8783       include 'COMMON.INTERACT'
8784       include 'COMMON.CONTACTS'
8785       include 'COMMON.TORSION'
8786       include 'COMMON.VAR'
8787       include 'COMMON.GEO'
8788       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8789      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8790      &  ggg1(3),ggg2(3)
8791       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8792      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8793 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8794 C           the respective energy moment and not to the cluster cumulant.
8795       s1=0.0d0
8796       s8=0.0d0
8797       s13=0.0d0
8798 c
8799       eello_turn6=0.0d0
8800       j=i+4
8801       k=i+1
8802       l=i+3
8803       iti=itortyp(itype(i))
8804       itk=itortyp(itype(k))
8805       itk1=itortyp(itype(k+1))
8806       itl=itortyp(itype(l))
8807       itj=itortyp(itype(j))
8808 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8809 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8810 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8811 cd        eello6=0.0d0
8812 cd        return
8813 cd      endif
8814 cd      write (iout,*)
8815 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8816 cd     &   ' and',k,l
8817 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8818       do iii=1,2
8819         do kkk=1,5
8820           do lll=1,3
8821             derx_turn(lll,kkk,iii)=0.0d0
8822           enddo
8823         enddo
8824       enddo
8825 cd      eij=1.0d0
8826 cd      ekl=1.0d0
8827 cd      ekont=1.0d0
8828       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8829 cd      eello6_5=0.0d0
8830 cd      write (2,*) 'eello6_5',eello6_5
8831 #ifdef MOMENT
8832       call transpose2(AEA(1,1,1),auxmat(1,1))
8833       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8834       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8835       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8836 #endif
8837       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8838       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8839       s2 = scalar2(b1(1,itk),vtemp1(1))
8840 #ifdef MOMENT
8841       call transpose2(AEA(1,1,2),atemp(1,1))
8842       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8843       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8844       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8845 #endif
8846       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8847       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8848       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8849 #ifdef MOMENT
8850       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8851       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8852       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8853       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8854       ss13 = scalar2(b1(1,itk),vtemp4(1))
8855       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8856 #endif
8857 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8858 c      s1=0.0d0
8859 c      s2=0.0d0
8860 c      s8=0.0d0
8861 c      s12=0.0d0
8862 c      s13=0.0d0
8863       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8864 C Derivatives in gamma(i+2)
8865       s1d =0.0d0
8866       s8d =0.0d0
8867 #ifdef MOMENT
8868       call transpose2(AEA(1,1,1),auxmatd(1,1))
8869       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8870       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8871       call transpose2(AEAderg(1,1,2),atempd(1,1))
8872       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8873       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8874 #endif
8875       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8876       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8877       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8878 c      s1d=0.0d0
8879 c      s2d=0.0d0
8880 c      s8d=0.0d0
8881 c      s12d=0.0d0
8882 c      s13d=0.0d0
8883       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8884 C Derivatives in gamma(i+3)
8885 #ifdef MOMENT
8886       call transpose2(AEA(1,1,1),auxmatd(1,1))
8887       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8888       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8889       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8890 #endif
8891       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8892       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8893       s2d = scalar2(b1(1,itk),vtemp1d(1))
8894 #ifdef MOMENT
8895       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8896       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8897 #endif
8898       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8899 #ifdef MOMENT
8900       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8901       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8902       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8903 #endif
8904 c      s1d=0.0d0
8905 c      s2d=0.0d0
8906 c      s8d=0.0d0
8907 c      s12d=0.0d0
8908 c      s13d=0.0d0
8909 #ifdef MOMENT
8910       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8911      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8912 #else
8913       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8914      &               -0.5d0*ekont*(s2d+s12d)
8915 #endif
8916 C Derivatives in gamma(i+4)
8917       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8918       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8919       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8920 #ifdef MOMENT
8921       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8922       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8923       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8924 #endif
8925 c      s1d=0.0d0
8926 c      s2d=0.0d0
8927 c      s8d=0.0d0
8928 C      s12d=0.0d0
8929 c      s13d=0.0d0
8930 #ifdef MOMENT
8931       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8932 #else
8933       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8934 #endif
8935 C Derivatives in gamma(i+5)
8936 #ifdef MOMENT
8937       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8938       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8939       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8940 #endif
8941       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8942       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8943       s2d = scalar2(b1(1,itk),vtemp1d(1))
8944 #ifdef MOMENT
8945       call transpose2(AEA(1,1,2),atempd(1,1))
8946       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8947       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8948 #endif
8949       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8950       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8951 #ifdef MOMENT
8952       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8953       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8954       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8955 #endif
8956 c      s1d=0.0d0
8957 c      s2d=0.0d0
8958 c      s8d=0.0d0
8959 c      s12d=0.0d0
8960 c      s13d=0.0d0
8961 #ifdef MOMENT
8962       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8963      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8964 #else
8965       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8966      &               -0.5d0*ekont*(s2d+s12d)
8967 #endif
8968 C Cartesian derivatives
8969       do iii=1,2
8970         do kkk=1,5
8971           do lll=1,3
8972 #ifdef MOMENT
8973             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8974             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8975             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8976 #endif
8977             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8978             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8979      &          vtemp1d(1))
8980             s2d = scalar2(b1(1,itk),vtemp1d(1))
8981 #ifdef MOMENT
8982             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8983             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8984             s8d = -(atempd(1,1)+atempd(2,2))*
8985      &           scalar2(cc(1,1,itl),vtemp2(1))
8986 #endif
8987             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8988      &           auxmatd(1,1))
8989             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8990             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8991 c      s1d=0.0d0
8992 c      s2d=0.0d0
8993 c      s8d=0.0d0
8994 c      s12d=0.0d0
8995 c      s13d=0.0d0
8996 #ifdef MOMENT
8997             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8998      &        - 0.5d0*(s1d+s2d)
8999 #else
9000             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9001      &        - 0.5d0*s2d
9002 #endif
9003 #ifdef MOMENT
9004             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9005      &        - 0.5d0*(s8d+s12d)
9006 #else
9007             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9008      &        - 0.5d0*s12d
9009 #endif
9010           enddo
9011         enddo
9012       enddo
9013 #ifdef MOMENT
9014       do kkk=1,5
9015         do lll=1,3
9016           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9017      &      achuj_tempd(1,1))
9018           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9019           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9020           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9021           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9022           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9023      &      vtemp4d(1))
9024           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9025           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9026           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9027         enddo
9028       enddo
9029 #endif
9030 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9031 cd     &  16*eel_turn6_num
9032 cd      goto 1112
9033       if (j.lt.nres-1) then
9034         j1=j+1
9035         j2=j-1
9036       else
9037         j1=j-1
9038         j2=j-2
9039       endif
9040       if (l.lt.nres-1) then
9041         l1=l+1
9042         l2=l-1
9043       else
9044         l1=l-1
9045         l2=l-2
9046       endif
9047       do ll=1,3
9048 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9049 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9050 cgrad        ghalf=0.5d0*ggg1(ll)
9051 cd        ghalf=0.0d0
9052         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9053         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9054         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9055      &    +ekont*derx_turn(ll,2,1)
9056         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9057         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9058      &    +ekont*derx_turn(ll,4,1)
9059         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9060         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9061         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9062 cgrad        ghalf=0.5d0*ggg2(ll)
9063 cd        ghalf=0.0d0
9064         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9065      &    +ekont*derx_turn(ll,2,2)
9066         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9067         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9068      &    +ekont*derx_turn(ll,4,2)
9069         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9070         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9071         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9072       enddo
9073 cd      goto 1112
9074 cgrad      do m=i+1,j-1
9075 cgrad        do ll=1,3
9076 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9077 cgrad        enddo
9078 cgrad      enddo
9079 cgrad      do m=k+1,l-1
9080 cgrad        do ll=1,3
9081 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9082 cgrad        enddo
9083 cgrad      enddo
9084 cgrad1112  continue
9085 cgrad      do m=i+2,j2
9086 cgrad        do ll=1,3
9087 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9088 cgrad        enddo
9089 cgrad      enddo
9090 cgrad      do m=k+2,l2
9091 cgrad        do ll=1,3
9092 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9093 cgrad        enddo
9094 cgrad      enddo
9095 cd      do iii=1,nres-3
9096 cd        write (2,*) iii,g_corr6_loc(iii)
9097 cd      enddo
9098       eello_turn6=ekont*eel_turn6
9099 cd      write (2,*) 'ekont',ekont
9100 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9101       return
9102       end
9103
9104 C-----------------------------------------------------------------------------
9105       double precision function scalar(u,v)
9106 !DIR$ INLINEALWAYS scalar
9107 #ifndef OSF
9108 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9109 #endif
9110       implicit none
9111       double precision u(3),v(3)
9112 cd      double precision sc
9113 cd      integer i
9114 cd      sc=0.0d0
9115 cd      do i=1,3
9116 cd        sc=sc+u(i)*v(i)
9117 cd      enddo
9118 cd      scalar=sc
9119
9120       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9121       return
9122       end
9123 crc-------------------------------------------------
9124       SUBROUTINE MATVEC2(A1,V1,V2)
9125 !DIR$ INLINEALWAYS MATVEC2
9126 #ifndef OSF
9127 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9128 #endif
9129       implicit real*8 (a-h,o-z)
9130       include 'DIMENSIONS'
9131       DIMENSION A1(2,2),V1(2),V2(2)
9132 c      DO 1 I=1,2
9133 c        VI=0.0
9134 c        DO 3 K=1,2
9135 c    3     VI=VI+A1(I,K)*V1(K)
9136 c        Vaux(I)=VI
9137 c    1 CONTINUE
9138
9139       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9140       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9141
9142       v2(1)=vaux1
9143       v2(2)=vaux2
9144       END
9145 C---------------------------------------
9146       SUBROUTINE MATMAT2(A1,A2,A3)
9147 #ifndef OSF
9148 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9149 #endif
9150       implicit real*8 (a-h,o-z)
9151       include 'DIMENSIONS'
9152       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9153 c      DIMENSION AI3(2,2)
9154 c        DO  J=1,2
9155 c          A3IJ=0.0
9156 c          DO K=1,2
9157 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9158 c          enddo
9159 c          A3(I,J)=A3IJ
9160 c       enddo
9161 c      enddo
9162
9163       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9164       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9165       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9166       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9167
9168       A3(1,1)=AI3_11
9169       A3(2,1)=AI3_21
9170       A3(1,2)=AI3_12
9171       A3(2,2)=AI3_22
9172       END
9173
9174 c-------------------------------------------------------------------------
9175       double precision function scalar2(u,v)
9176 !DIR$ INLINEALWAYS scalar2
9177       implicit none
9178       double precision u(2),v(2)
9179       double precision sc
9180       integer i
9181       scalar2=u(1)*v(1)+u(2)*v(2)
9182       return
9183       end
9184
9185 C-----------------------------------------------------------------------------
9186
9187       subroutine transpose2(a,at)
9188 !DIR$ INLINEALWAYS transpose2
9189 #ifndef OSF
9190 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9191 #endif
9192       implicit none
9193       double precision a(2,2),at(2,2)
9194       at(1,1)=a(1,1)
9195       at(1,2)=a(2,1)
9196       at(2,1)=a(1,2)
9197       at(2,2)=a(2,2)
9198       return
9199       end
9200 c--------------------------------------------------------------------------
9201       subroutine transpose(n,a,at)
9202       implicit none
9203       integer n,i,j
9204       double precision a(n,n),at(n,n)
9205       do i=1,n
9206         do j=1,n
9207           at(j,i)=a(i,j)
9208         enddo
9209       enddo
9210       return
9211       end
9212 C---------------------------------------------------------------------------
9213       subroutine prodmat3(a1,a2,kk,transp,prod)
9214 !DIR$ INLINEALWAYS prodmat3
9215 #ifndef OSF
9216 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9217 #endif
9218       implicit none
9219       integer i,j
9220       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9221       logical transp
9222 crc      double precision auxmat(2,2),prod_(2,2)
9223
9224       if (transp) then
9225 crc        call transpose2(kk(1,1),auxmat(1,1))
9226 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9227 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9228
9229            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9230      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9231            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9232      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9233            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9234      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9235            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9236      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9237
9238       else
9239 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9240 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9241
9242            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9243      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9244            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9245      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9246            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9247      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9248            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9249      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9250
9251       endif
9252 c      call transpose2(a2(1,1),a2t(1,1))
9253
9254 crc      print *,transp
9255 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9256 crc      print *,((prod(i,j),i=1,2),j=1,2)
9257
9258       return
9259       end
9260