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 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.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 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+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 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777 #define DEBUG
 778 #ifdef DEBUG
 779       write (iout,*) "gloc_sc before reduce"
 780       do i=1,nres
 781        do j=1,3
 782         write (iout,*) i,j,gloc_sc(j,i,icg)
 783        enddo
 784       enddo
 785 #endif
 786 #undef DEBUG
 787         do i=1,nres
 788          do j=1,3
 789           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 790          enddo
 791         enddo
 792         time00=MPI_Wtime()
 793         call MPI_Barrier(FG_COMM,IERR)
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 795         time00=MPI_Wtime()
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         time_reduce=time_reduce+MPI_Wtime()-time00
 805 #define DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc_sc after reduce"
 808       do i=1,nres
 809        do j=1,3
 810         write (iout,*) i,j,gloc_sc(j,i,icg)
 811        enddo
 812       enddo
 813 #endif
 814 #undef DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc after reduce"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       endif
 822 #endif
 823       if (gnorm_check) then
 824 c
 825 c Compute the maximum elements of the gradient
 826 c
 827       gvdwc_max=0.0d0
 828       gvdwc_scp_max=0.0d0
 829       gelc_max=0.0d0
 830       gvdwpp_max=0.0d0
 831       gradb_max=0.0d0
 832       ghpbc_max=0.0d0
 833       gradcorr_max=0.0d0
 834       gel_loc_max=0.0d0
 835       gcorr3_turn_max=0.0d0
 836       gcorr4_turn_max=0.0d0
 837       gradcorr5_max=0.0d0
 838       gradcorr6_max=0.0d0
 839       gcorr6_turn_max=0.0d0
 840       gsccorc_max=0.0d0
 841       gscloc_max=0.0d0
 842       gvdwx_max=0.0d0
 843       gradx_scp_max=0.0d0
 844       ghpbx_max=0.0d0
 845       gradxorr_max=0.0d0
 846       gsccorx_max=0.0d0
 847       gsclocx_max=0.0d0
 848       do i=1,nct
 849         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 850         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 851 #ifdef TSCSC
 852         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 853         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 854 #endif
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893 #ifdef TSCSC
 894         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 895         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 896 #endif
 897         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 898         if (gradx_scp_norm.gt.gradx_scp_max)
 899      &    gradx_scp_max=gradx_scp_norm
 900         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 901         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 902         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 903         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 904         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 905         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 906         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 907         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 908       enddo
 909       if (gradout) then
 910 #ifdef AIX
 911         open(istat,file=statname,position="append")
 912 #else
 913         open(istat,file=statname,access="append")
 914 #endif
 915         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 916      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 917      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 918      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 919      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 920      &     gsccorx_max,gsclocx_max
 921         close(istat)
 922         if (gvdwc_max.gt.1.0d4) then
 923           write (iout,*) "gvdwc gvdwx gradb gradbx"
 924           do i=nnt,nct
 925             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 926      &        gradb(j,i),gradbx(j,i),j=1,3)
 927           enddo
 928           call pdbout(0.0d0,'cipiszcze',iout)
 929           call flush(iout)
 930         endif
 931       endif
 932       endif
 933 #ifdef DEBUG
 934       write (iout,*) "gradc gradx gloc"
 935       do i=1,nres
 936         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 937      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 938       enddo
 939 #endif
 940 #ifdef TIMING
 941 #ifdef MPI
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #else
 944       time_sumgradient=time_sumgradient+tcpu()-time01
 945 #endif
 946 #endif
 947       return
 948       end
 949 c-------------------------------------------------------------------------------
 950       subroutine rescale_weights(t_bath)
 951       implicit real*8 (a-h,o-z)
 952       include 'DIMENSIONS'
 953       include 'COMMON.IOUNITS'
 954       include 'COMMON.FFIELD'
 955       include 'COMMON.SBRIDGE'
 956       double precision kfac /2.4d0/
 957       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 958 c      facT=temp0/t_bath
 959 c      facT=2*temp0/(t_bath+temp0)
 960       if (rescale_mode.eq.0) then
 961         facT=1.0d0
 962         facT2=1.0d0
 963         facT3=1.0d0
 964         facT4=1.0d0
 965         facT5=1.0d0
 966       else if (rescale_mode.eq.1) then
 967         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 968         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 969         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 970         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 971         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 972       else if (rescale_mode.eq.2) then
 973         x=t_bath/temp0
 974         x2=x*x
 975         x3=x2*x
 976         x4=x3*x
 977         x5=x4*x
 978         facT=licznik/dlog(dexp(x)+dexp(-x))
 979         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 980         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 981         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 982         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 983       else
 984         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 985         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 986 #ifdef MPI
 987        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 988 #endif
 989        stop 555
 990       endif
 991       welec=weights(3)*fact
 992       wcorr=weights(4)*fact3
 993       wcorr5=weights(5)*fact4
 994       wcorr6=weights(6)*fact5
 995       wel_loc=weights(7)*fact2
 996       wturn3=weights(8)*fact2
 997       wturn4=weights(9)*fact3
 998       wturn6=weights(10)*fact5
 999       wtor=weights(13)*fact
1000       wtor_d=weights(14)*fact2
1001       wsccor=weights(21)*fact
1002 #ifdef TSCSC
1003 c      wsct=t_bath/temp0
1004       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1005 #endif
1006       return
1007       end
1008 C------------------------------------------------------------------------
1009       subroutine enerprint(energia)
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       include 'COMMON.IOUNITS'
1013       include 'COMMON.FFIELD'
1014       include 'COMMON.SBRIDGE'
1015       include 'COMMON.MD'
1016       double precision energia(0:n_ene)
1017       etot=energia(0)
1018 #ifdef TSCSC
1019       evdw=energia(22)+wsct*energia(23)
1020 #else
1021       evdw=energia(1)
1022 #endif
1023       evdw2=energia(2)
1024 #ifdef SCP14
1025       evdw2=energia(2)+energia(18)
1026 #else
1027       evdw2=energia(2)
1028 #endif
1029       ees=energia(3)
1030 #ifdef SPLITELE
1031       evdw1=energia(16)
1032 #endif
1033       ecorr=energia(4)
1034       ecorr5=energia(5)
1035       ecorr6=energia(6)
1036       eel_loc=energia(7)
1037       eello_turn3=energia(8)
1038       eello_turn4=energia(9)
1039       eello_turn6=energia(10)
1040       ebe=energia(11)
1041       escloc=energia(12)
1042       etors=energia(13)
1043       etors_d=energia(14)
1044       ehpb=energia(15)
1045       edihcnstr=energia(19)
1046       estr=energia(17)
1047       Uconst=energia(20)
1048       esccor=energia(21)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1051      &  estr,wbond,ebe,wang,
1052      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1053      &  ecorr,wcorr,
1054      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1055      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1056      &  edihcnstr,ebr*nss,
1057      &  Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1063      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1064      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1065      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1066      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1067      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1068      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1069      & ' (SS bridges & dist. cnstr.)'/
1070      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1074      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1075      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1076      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1077      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1078      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1079      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1080      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1081      & 'ETOT=  ',1pE16.6,' (total)')
1082 #else
1083       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1084      &  estr,wbond,ebe,wang,
1085      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1086      &  ecorr,wcorr,
1087      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1088      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1089      &  ebr*nss,Uconst,etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1095      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1096      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1097      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1098      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1099      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1100      & ' (SS bridges & dist. cnstr.)'/
1101      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1105      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1106      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1107      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1108      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1109      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1110      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1111      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1112      & 'ETOT=  ',1pE16.6,' (total)')
1113 #endif
1114       return
1115       end
1116 C-----------------------------------------------------------------------
1117       subroutine elj(evdw,evdw_p,evdw_m)
1118 C
1119 C This subroutine calculates the interaction energy of nonbonded side chains
1120 C assuming the LJ potential of interaction.
1121 C
1122       implicit real*8 (a-h,o-z)
1123       include 'DIMENSIONS'
1124       parameter (accur=1.0d-10)
1125       include 'COMMON.GEO'
1126       include 'COMMON.VAR'
1127       include 'COMMON.LOCAL'
1128       include 'COMMON.CHAIN'
1129       include 'COMMON.DERIV'
1130       include 'COMMON.INTERACT'
1131       include 'COMMON.TORSION'
1132       include 'COMMON.SBRIDGE'
1133       include 'COMMON.NAMES'
1134       include 'COMMON.IOUNITS'
1135       include 'COMMON.CONTACTS'
1136       dimension gg(3)
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1138       evdw=0.0D0
1139       do i=iatsc_s,iatsc_e
1140         itypi=iabs(itype(i))
1141         itypi1=iabs(itype(i+1))
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=iabs(itype(j))
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=iabs(itype(i))
1318         itypi1=iabs(itype(i+1))
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=iabs(itype(j))
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         itypi1=iabs(itype(i+1))
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=itype(j)
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=iabs(itype(i))
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=iabs(itype(j))
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=iabs(itype(i))
1730         itypi1=iabs(itype(i+1))
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=iabs(itype(j))
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=iabs(itype(i))
2050         itypi1=iabs(itype(i+1))
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=iabs(itype(j))
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(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             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(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              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=iabs(itype(j))
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=iabs(itype(j))
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4270 c     &    dhpb(i),dhpb1(i),forcon(i)
4271 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4272 C    distance and angle dependent SS bond potential.
4273         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4274      &)).eq.1) then
4275           call ssbond_ene(iii,jjj,eij)
4276           ehpb=ehpb+2*eij
4277 cd          write (iout,*) "eij",eij
4278         else if (ii.gt.nres .and. jj.gt.nres) then
4279 c Restraints from contact prediction
4280           dd=dist(ii,jj)
4281           if (dhpb1(i).gt.0.0d0) then
4282             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4283             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4284 c            write (iout,*) "beta nmr",
4285 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4286           else
4287             dd=dist(ii,jj)
4288             rdis=dd-dhpb(i)
4289 C Get the force constant corresponding to this distance.
4290             waga=forcon(i)
4291 C Calculate the contribution to energy.
4292             ehpb=ehpb+waga*rdis*rdis
4293 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4294 C
4295 C Evaluate gradient.
4296 C
4297             fac=waga*rdis/dd
4298           endif
4299           do j=1,3
4300             ggg(j)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           do j=1,3
4303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4305           enddo
4306           do k=1,3
4307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4309           enddo
4310         else
4311 C Calculate the distance between the two points and its difference from the
4312 C target distance.
4313           dd=dist(ii,jj)
4314           if (dhpb1(i).gt.0.0d0) then
4315             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4317 c            write (iout,*) "alph nmr",
4318 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4319           else
4320             rdis=dd-dhpb(i)
4321 C Get the force constant corresponding to this distance.
4322             waga=forcon(i)
4323 C Calculate the contribution to energy.
4324             ehpb=ehpb+waga*rdis*rdis
4325 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4326 C
4327 C Evaluate gradient.
4328 C
4329             fac=waga*rdis/dd
4330           endif
4331 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4332 cd   &   ' waga=',waga,' fac=',fac
4333             do j=1,3
4334               ggg(j)=fac*(c(j,jj)-c(j,ii))
4335             enddo
4336 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4337 C If this is a SC-SC distance, we need to calculate the contributions to the
4338 C Cartesian gradient in the SC vectors (ghpbx).
4339           if (iii.lt.ii) then
4340           do j=1,3
4341             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4342             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4343           enddo
4344           endif
4345 cgrad        do j=iii,jjj-1
4346 cgrad          do k=1,3
4347 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4348 cgrad          enddo
4349 cgrad        enddo
4350           do k=1,3
4351             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4352             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4353           enddo
4354         endif
4355       enddo
4356       ehpb=0.5D0*ehpb
4357       return
4358       end
4359 C--------------------------------------------------------------------------
4360       subroutine ssbond_ene(i,j,eij)
4361 C
4362 C Calculate the distance and angle dependent SS-bond potential energy
4363 C using a free-energy function derived based on RHF/6-31G** ab initio
4364 C calculations of diethyl disulfide.
4365 C
4366 C A. Liwo and U. Kozlowska, 11/24/03
4367 C
4368       implicit real*8 (a-h,o-z)
4369       include 'DIMENSIONS'
4370       include 'COMMON.SBRIDGE'
4371       include 'COMMON.CHAIN'
4372       include 'COMMON.DERIV'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.VAR'
4376       include 'COMMON.IOUNITS'
4377       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4378       itypi=iabs(itype(i))
4379       xi=c(1,nres+i)
4380       yi=c(2,nres+i)
4381       zi=c(3,nres+i)
4382       dxi=dc_norm(1,nres+i)
4383       dyi=dc_norm(2,nres+i)
4384       dzi=dc_norm(3,nres+i)
4385 c      dsci_inv=dsc_inv(itypi)
4386       dsci_inv=vbld_inv(nres+i)
4387       itypj=iabs(itype(j))
4388 c      dscj_inv=dsc_inv(itypj)
4389       dscj_inv=vbld_inv(nres+j)
4390       xj=c(1,nres+j)-xi
4391       yj=c(2,nres+j)-yi
4392       zj=c(3,nres+j)-zi
4393       dxj=dc_norm(1,nres+j)
4394       dyj=dc_norm(2,nres+j)
4395       dzj=dc_norm(3,nres+j)
4396       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4397       rij=dsqrt(rrij)
4398       erij(1)=xj*rij
4399       erij(2)=yj*rij
4400       erij(3)=zj*rij
4401       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4402       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4403       om12=dxi*dxj+dyi*dyj+dzi*dzj
4404       do k=1,3
4405         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4406         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4407       enddo
4408       rij=1.0d0/rij
4409       deltad=rij-d0cm
4410       deltat1=1.0d0-om1
4411       deltat2=1.0d0+om2
4412       deltat12=om2-om1+2.0d0
4413       cosphi=om12-om1*om2
4414       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4415      &  +akct*deltad*deltat12
4416      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4417 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4418 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4419 c     &  " deltat12",deltat12," eij",eij
4420       ed=2*akcm*deltad+akct*deltat12
4421       pom1=akct*deltad
4422       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4423       eom1=-2*akth*deltat1-pom1-om2*pom2
4424       eom2= 2*akth*deltat2+pom1-om1*pom2
4425       eom12=pom2
4426       do k=1,3
4427         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4428         ghpbx(k,i)=ghpbx(k,i)-ggk
4429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4431         ghpbx(k,j)=ghpbx(k,j)+ggk
4432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4434         ghpbc(k,i)=ghpbc(k,i)-ggk
4435         ghpbc(k,j)=ghpbc(k,j)+ggk
4436       enddo
4437 C
4438 C Calculate the components of the gradient in DC and X
4439 C
4440 cgrad      do k=i,j-1
4441 cgrad        do l=1,3
4442 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4443 cgrad        enddo
4444 cgrad      enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ebond(estr)
4449 c
4450 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4451 c
4452       implicit real*8 (a-h,o-z)
4453       include 'DIMENSIONS'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.GEO'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.DERIV'
4458       include 'COMMON.VAR'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.IOUNITS'
4461       include 'COMMON.NAMES'
4462       include 'COMMON.FFIELD'
4463       include 'COMMON.CONTROL'
4464       include 'COMMON.SETUP'
4465       double precision u(3),ud(3)
4466       estr=0.0d0
4467       do i=ibondp_start,ibondp_end
4468         diff = vbld(i)-vbldp0
4469 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4470         estr=estr+diff*diff
4471         do j=1,3
4472           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4473         enddo
4474 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4475       enddo
4476       estr=0.5d0*AKP*estr
4477 c
4478 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4479 c
4480       do i=ibond_start,ibond_end
4481         iti=iabs(itype(i))
4482         if (iti.ne.10) then
4483           nbi=nbondterm(iti)
4484           if (nbi.eq.1) then
4485             diff=vbld(i+nres)-vbldsc0(1,iti)
4486 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4487 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4488             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4489             do j=1,3
4490               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           else
4493             do j=1,nbi
4494               diff=vbld(i+nres)-vbldsc0(j,iti)
4495               ud(j)=aksc(j,iti)*diff
4496               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4497             enddo
4498             uprod=u(1)
4499             do j=2,nbi
4500               uprod=uprod*u(j)
4501             enddo
4502             usum=0.0d0
4503             usumsqder=0.0d0
4504             do j=1,nbi
4505               uprod1=1.0d0
4506               uprod2=1.0d0
4507               do k=1,nbi
4508                 if (k.ne.j) then
4509                   uprod1=uprod1*u(k)
4510                   uprod2=uprod2*u(k)*u(k)
4511                 endif
4512               enddo
4513               usum=usum+uprod1
4514               usumsqder=usumsqder+ud(j)*uprod2
4515             enddo
4516             estr=estr+uprod/usum
4517             do j=1,3
4518              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4519             enddo
4520           endif
4521         endif
4522       enddo
4523       return
4524       end
4525 #ifdef CRYST_THETA
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C
4532       implicit real*8 (a-h,o-z)
4533       include 'DIMENSIONS'
4534       include 'COMMON.LOCAL'
4535       include 'COMMON.GEO'
4536       include 'COMMON.INTERACT'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.VAR'
4539       include 'COMMON.CHAIN'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.NAMES'
4542       include 'COMMON.FFIELD'
4543       include 'COMMON.CONTROL'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547       double precision y(2),z(2)
4548       delta=0.02d0*pi
4549 c      time11=dexp(-2*time)
4550 c      time12=1.0d0
4551       etheta=0.0D0
4552 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4553       do i=ithet_start,ithet_end
4554 C Zero the energy function and its derivative at 0 or pi.
4555         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4556         it=iabs(itype(i-1))
4557         if (i.gt.3) then
4558 #ifdef OSF
4559           phii=phi(i)
4560           if (phii.ne.phii) phii=150.0
4561 #else
4562           phii=phi(i)
4563 #endif
4564           y(1)=dcos(phii)
4565           y(2)=dsin(phii)
4566         else
4567           y(1)=0.0D0
4568           y(2)=0.0D0
4569         endif
4570         if (i.lt.nres) then
4571 #ifdef OSF
4572           phii1=phi(i+1)
4573           if (phii1.ne.phii1) phii1=150.0
4574           phii1=pinorm(phii1)
4575           z(1)=cos(phii1)
4576 #else
4577           phii1=phi(i+1)
4578           z(1)=dcos(phii1)
4579 #endif
4580           z(2)=dsin(phii1)
4581         else
4582           z(1)=0.0D0
4583           z(2)=0.0D0
4584         endif
4585 C Calculate the "mean" value of theta from the part of the distribution
4586 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4587 C In following comments this theta will be referred to as t_c.
4588         thet_pred_mean=0.0d0
4589         do k=1,2
4590           athetk=athet(k,it)
4591           bthetk=bthet(k,it)
4592           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4593         enddo
4594         dthett=thet_pred_mean*ssd
4595         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4596 C Derivatives of the "mean" values in gamma1 and gamma2.
4597         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4598         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4599         if (theta(i).gt.pi-delta) then
4600           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4601      &         E_tc0)
4602           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4603           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4604           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4605      &        E_theta)
4606           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4607      &        E_tc)
4608         else if (theta(i).lt.delta) then
4609           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4610           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4611           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4612      &        E_theta)
4613           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4614           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4615      &        E_tc)
4616         else
4617           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4618      &        E_theta,E_tc)
4619         endif
4620         etheta=etheta+ethetai
4621         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4622      &      'ebend',i,ethetai
4623         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4624         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4625         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4626       enddo
4627 C Ufff.... We've done all this!!!
4628       return
4629       end
4630 C---------------------------------------------------------------------------
4631       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4632      &     E_tc)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640 C Calculate the contributions to both Gaussian lobes.
4641 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4642 C The "polynomial part" of the "standard deviation" of this part of
4643 C the distribution.
4644         sig=polthet(3,it)
4645         do j=2,0,-1
4646           sig=sig*thet_pred_mean+polthet(j,it)
4647         enddo
4648 C Derivative of the "interior part" of the "standard deviation of the"
4649 C gamma-dependent Gaussian lobe in t_c.
4650         sigtc=3*polthet(3,it)
4651         do j=2,1,-1
4652           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4653         enddo
4654         sigtc=sig*sigtc
4655 C Set the parameters of both Gaussian lobes of the distribution.
4656 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4657         fac=sig*sig+sigc0(it)
4658         sigcsq=fac+fac
4659         sigc=1.0D0/sigcsq
4660 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4661         sigsqtc=-4.0D0*sigcsq*sigtc
4662 c       print *,i,sig,sigtc,sigsqtc
4663 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4664         sigtc=-sigtc/(fac*fac)
4665 C Following variable is sigma(t_c)**(-2)
4666         sigcsq=sigcsq*sigcsq
4667         sig0i=sig0(it)
4668         sig0inv=1.0D0/sig0i**2
4669         delthec=thetai-thet_pred_mean
4670         delthe0=thetai-theta0i
4671         term1=-0.5D0*sigcsq*delthec*delthec
4672         term2=-0.5D0*sig0inv*delthe0*delthe0
4673 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4674 C NaNs in taking the logarithm. We extract the largest exponent which is added
4675 C to the energy (this being the log of the distribution) at the end of energy
4676 C term evaluation for this virtual-bond angle.
4677         if (term1.gt.term2) then
4678           termm=term1
4679           term2=dexp(term2-termm)
4680           term1=1.0d0
4681         else
4682           termm=term2
4683           term1=dexp(term1-termm)
4684           term2=1.0d0
4685         endif
4686 C The ratio between the gamma-independent and gamma-dependent lobes of
4687 C the distribution is a Gaussian function of thet_pred_mean too.
4688         diffak=gthet(2,it)-thet_pred_mean
4689         ratak=diffak/gthet(3,it)**2
4690         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4691 C Let's differentiate it in thet_pred_mean NOW.
4692         aktc=ak*ratak
4693 C Now put together the distribution terms to make complete distribution.
4694         termexp=term1+ak*term2
4695         termpre=sigc+ak*sig0i
4696 C Contribution of the bending energy from this theta is just the -log of
4697 C the sum of the contributions from the two lobes and the pre-exponential
4698 C factor. Simple enough, isn't it?
4699         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4700 C NOW the derivatives!!!
4701 C 6/6/97 Take into account the deformation.
4702         E_theta=(delthec*sigcsq*term1
4703      &       +ak*delthe0*sig0inv*term2)/termexp
4704         E_tc=((sigtc+aktc*sig0i)/termpre
4705      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4706      &       aktc*term2)/termexp)
4707       return
4708       end
4709 c-----------------------------------------------------------------------------
4710       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.LOCAL'
4714       include 'COMMON.IOUNITS'
4715       common /calcthet/ term1,term2,termm,diffak,ratak,
4716      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4717      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4718       delthec=thetai-thet_pred_mean
4719       delthe0=thetai-theta0i
4720 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4721       t3 = thetai-thet_pred_mean
4722       t6 = t3**2
4723       t9 = term1
4724       t12 = t3*sigcsq
4725       t14 = t12+t6*sigsqtc
4726       t16 = 1.0d0
4727       t21 = thetai-theta0i
4728       t23 = t21**2
4729       t26 = term2
4730       t27 = t21*t26
4731       t32 = termexp
4732       t40 = t32**2
4733       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4734      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4735      & *(-t12*t9-ak*sig0inv*t27)
4736       return
4737       end
4738 #else
4739 C--------------------------------------------------------------------------
4740       subroutine ebend(etheta)
4741 C
4742 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4743 C angles gamma and its derivatives in consecutive thetas and gammas.
4744 C ab initio-derived potentials from
4745 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4746 C
4747       implicit real*8 (a-h,o-z)
4748       include 'DIMENSIONS'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.GEO'
4751       include 'COMMON.INTERACT'
4752       include 'COMMON.DERIV'
4753       include 'COMMON.VAR'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.IOUNITS'
4756       include 'COMMON.NAMES'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4760      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4761      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4762      & sinph1ph2(maxdouble,maxdouble)
4763       logical lprn /.false./, lprn1 /.false./
4764       etheta=0.0D0
4765       do i=ithet_start,ithet_end
4766         dethetai=0.0d0
4767         dephii=0.0d0
4768         dephii1=0.0d0
4769         theti2=0.5d0*theta(i)
4770         ityp2=ithetyp(iabs(itype(i-1)))
4771         do k=1,nntheterm
4772           coskt(k)=dcos(k*theti2)
4773           sinkt(k)=dsin(k*theti2)
4774         enddo
4775         if (i.gt.3) then
4776 #ifdef OSF
4777           phii=phi(i)
4778           if (phii.ne.phii) phii=150.0
4779 #else
4780           phii=phi(i)
4781 #endif
4782           ityp1=ithetyp(iabs(itype(i-2)))
4783           do k=1,nsingle
4784             cosph1(k)=dcos(k*phii)
4785             sinph1(k)=dsin(k*phii)
4786           enddo
4787         else
4788           phii=0.0d0
4789           ityp1=nthetyp+1
4790           do k=1,nsingle
4791             cosph1(k)=0.0d0
4792             sinph1(k)=0.0d0
4793           enddo
4794         endif
4795         if (i.lt.nres) then
4796 #ifdef OSF
4797           phii1=phi(i+1)
4798           if (phii1.ne.phii1) phii1=150.0
4799           phii1=pinorm(phii1)
4800 #else
4801           phii1=phi(i+1)
4802 #endif
4803           ityp3=ithetyp(iabs(itype(i)))
4804           do k=1,nsingle
4805             cosph2(k)=dcos(k*phii1)
4806             sinph2(k)=dsin(k*phii1)
4807           enddo
4808         else
4809           phii1=0.0d0
4810           ityp3=nthetyp+1
4811           do k=1,nsingle
4812             cosph2(k)=0.0d0
4813             sinph2(k)=0.0d0
4814           enddo
4815         endif
4816         ethetai=aa0thet(ityp1,ityp2,ityp3)
4817         do k=1,ndouble
4818           do l=1,k-1
4819             ccl=cosph1(l)*cosph2(k-l)
4820             ssl=sinph1(l)*sinph2(k-l)
4821             scl=sinph1(l)*cosph2(k-l)
4822             csl=cosph1(l)*sinph2(k-l)
4823             cosph1ph2(l,k)=ccl-ssl
4824             cosph1ph2(k,l)=ccl+ssl
4825             sinph1ph2(l,k)=scl+csl
4826             sinph1ph2(k,l)=scl-csl
4827           enddo
4828         enddo
4829         if (lprn) then
4830         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4831      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4832         write (iout,*) "coskt and sinkt"
4833         do k=1,nntheterm
4834           write (iout,*) k,coskt(k),sinkt(k)
4835         enddo
4836         endif
4837         do k=1,ntheterm
4838           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4839           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4840      &      *coskt(k)
4841           if (lprn)
4842      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4843      &     " ethetai",ethetai
4844         enddo
4845         if (lprn) then
4846         write (iout,*) "cosph and sinph"
4847         do k=1,nsingle
4848           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4849         enddo
4850         write (iout,*) "cosph1ph2 and sinph2ph2"
4851         do k=2,ndouble
4852           do l=1,k-1
4853             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4854      &         sinph1ph2(l,k),sinph1ph2(k,l)
4855           enddo
4856         enddo
4857         write(iout,*) "ethetai",ethetai
4858         endif
4859         do m=1,ntheterm2
4860           do k=1,nsingle
4861             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4862      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4863      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4864      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4865             ethetai=ethetai+sinkt(m)*aux
4866             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4867             dephii=dephii+k*sinkt(m)*(
4868      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4869      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4870             dephii1=dephii1+k*sinkt(m)*(
4871      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4872      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4873             if (lprn)
4874      &      write (iout,*) "m",m," k",k," bbthet",
4875      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4876      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4877      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4878      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4879           enddo
4880         enddo
4881         if (lprn)
4882      &  write(iout,*) "ethetai",ethetai
4883         do m=1,ntheterm3
4884           do k=2,ndouble
4885             do l=1,k-1
4886               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4887      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4888      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4889      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4890               ethetai=ethetai+sinkt(m)*aux
4891               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4892               dephii=dephii+l*sinkt(m)*(
4893      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4894      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4895      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4896      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4897               dephii1=dephii1+(k-l)*sinkt(m)*(
4898      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4899      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4900      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4901      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4902               if (lprn) then
4903               write (iout,*) "m",m," k",k," l",l," ffthet",
4904      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4905      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4906      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4907      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4908               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4909      &            cosph1ph2(k,l)*sinkt(m),
4910      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4911               endif
4912             enddo
4913           enddo
4914         enddo
4915 10      continue
4916         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4917      &   i,theta(i)*rad2deg,phii*rad2deg,
4918      &   phii1*rad2deg,ethetai
4919         etheta=etheta+ethetai
4920         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4921         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4922         gloc(nphi+i-2,icg)=wang*dethetai
4923       enddo
4924       return
4925       end
4926 #endif
4927 #ifdef CRYST_SC
4928 c-----------------------------------------------------------------------------
4929       subroutine esc(escloc)
4930 C Calculate the local energy of a side chain and its derivatives in the
4931 C corresponding virtual-bond valence angles THETA and the spherical angles
4932 C ALPHA and OMEGA.
4933       implicit real*8 (a-h,o-z)
4934       include 'DIMENSIONS'
4935       include 'COMMON.GEO'
4936       include 'COMMON.LOCAL'
4937       include 'COMMON.VAR'
4938       include 'COMMON.INTERACT'
4939       include 'COMMON.DERIV'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.IOUNITS'
4942       include 'COMMON.NAMES'
4943       include 'COMMON.FFIELD'
4944       include 'COMMON.CONTROL'
4945       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4946      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4947       common /sccalc/ time11,time12,time112,theti,it,nlobit
4948       delta=0.02d0*pi
4949       escloc=0.0D0
4950 c     write (iout,'(a)') 'ESC'
4951       do i=loc_start,loc_end
4952         it=itype(i)
4953         if (it.eq.10) goto 1
4954         nlobit=nlob(iabs(it))
4955 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4956 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4957         theti=theta(i+1)-pipol
4958         x(1)=dtan(theti)
4959         x(2)=alph(i)
4960         x(3)=omeg(i)
4961
4962         if (x(2).gt.pi-delta) then
4963           xtemp(1)=x(1)
4964           xtemp(2)=pi-delta
4965           xtemp(3)=x(3)
4966           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4967           xtemp(2)=pi
4968           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4969           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4970      &        escloci,dersc(2))
4971           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4972      &        ddersc0(1),dersc(1))
4973           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4974      &        ddersc0(3),dersc(3))
4975           xtemp(2)=pi-delta
4976           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4977           xtemp(2)=pi
4978           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4979           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4980      &            dersc0(2),esclocbi,dersc02)
4981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4982      &            dersc12,dersc01)
4983           call splinthet(x(2),0.5d0*delta,ss,ssd)
4984           dersc0(1)=dersc01
4985           dersc0(2)=dersc02
4986           dersc0(3)=0.0d0
4987           do k=1,3
4988             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4989           enddo
4990           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4991 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4992 c    &             esclocbi,ss,ssd
4993           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4994 c         escloci=esclocbi
4995 c         write (iout,*) escloci
4996         else if (x(2).lt.delta) then
4997           xtemp(1)=x(1)
4998           xtemp(2)=delta
4999           xtemp(3)=x(3)
5000           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5001           xtemp(2)=0.0d0
5002           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5003           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5004      &        escloci,dersc(2))
5005           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5006      &        ddersc0(1),dersc(1))
5007           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5008      &        ddersc0(3),dersc(3))
5009           xtemp(2)=delta
5010           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5011           xtemp(2)=0.0d0
5012           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5013           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5014      &            dersc0(2),esclocbi,dersc02)
5015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5016      &            dersc12,dersc01)
5017           dersc0(1)=dersc01
5018           dersc0(2)=dersc02
5019           dersc0(3)=0.0d0
5020           call splinthet(x(2),0.5d0*delta,ss,ssd)
5021           do k=1,3
5022             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5023           enddo
5024           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5025 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5026 c    &             esclocbi,ss,ssd
5027           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5028 c         write (iout,*) escloci
5029         else
5030           call enesc(x,escloci,dersc,ddummy,.false.)
5031         endif
5032
5033         escloc=escloc+escloci
5034         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5035      &     'escloc',i,escloci
5036 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5037
5038         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5039      &   wscloc*dersc(1)
5040         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5041         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5042     1   continue
5043       enddo
5044       return
5045       end
5046 C---------------------------------------------------------------------------
5047       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5048       implicit real*8 (a-h,o-z)
5049       include 'DIMENSIONS'
5050       include 'COMMON.GEO'
5051       include 'COMMON.LOCAL'
5052       include 'COMMON.IOUNITS'
5053       common /sccalc/ time11,time12,time112,theti,it,nlobit
5054       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5055       double precision contr(maxlob,-1:1)
5056       logical mixed
5057 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5058         escloc_i=0.0D0
5059         do j=1,3
5060           dersc(j)=0.0D0
5061           if (mixed) ddersc(j)=0.0d0
5062         enddo
5063         x3=x(3)
5064
5065 C Because of periodicity of the dependence of the SC energy in omega we have
5066 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5067 C To avoid underflows, first compute & store the exponents.
5068
5069         do iii=-1,1
5070
5071           x(3)=x3+iii*dwapi
5072
5073           do j=1,nlobit
5074             do k=1,3
5075               z(k)=x(k)-censc(k,j,it)
5076             enddo
5077             do k=1,3
5078               Axk=0.0D0
5079               do l=1,3
5080                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5081               enddo
5082               Ax(k,j,iii)=Axk
5083             enddo
5084             expfac=0.0D0
5085             do k=1,3
5086               expfac=expfac+Ax(k,j,iii)*z(k)
5087             enddo
5088             contr(j,iii)=expfac
5089           enddo ! j
5090
5091         enddo ! iii
5092
5093         x(3)=x3
5094 C As in the case of ebend, we want to avoid underflows in exponentiation and
5095 C subsequent NaNs and INFs in energy calculation.
5096 C Find the largest exponent
5097         emin=contr(1,-1)
5098         do iii=-1,1
5099           do j=1,nlobit
5100             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5101           enddo
5102         enddo
5103         emin=0.5D0*emin
5104 cd      print *,'it=',it,' emin=',emin
5105
5106 C Compute the contribution to SC energy and derivatives
5107         do iii=-1,1
5108
5109           do j=1,nlobit
5110 #ifdef OSF
5111             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5112             if(adexp.ne.adexp) adexp=1.0
5113             expfac=dexp(adexp)
5114 #else
5115             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5116 #endif
5117 cd          print *,'j=',j,' expfac=',expfac
5118             escloc_i=escloc_i+expfac
5119             do k=1,3
5120               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5121             enddo
5122             if (mixed) then
5123               do k=1,3,2
5124                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5125      &            +gaussc(k,2,j,it))*expfac
5126               enddo
5127             endif
5128           enddo
5129
5130         enddo ! iii
5131
5132         dersc(1)=dersc(1)/cos(theti)**2
5133         ddersc(1)=ddersc(1)/cos(theti)**2
5134         ddersc(3)=ddersc(3)
5135
5136         escloci=-(dlog(escloc_i)-emin)
5137         do j=1,3
5138           dersc(j)=dersc(j)/escloc_i
5139         enddo
5140         if (mixed) then
5141           do j=1,3,2
5142             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5143           enddo
5144         endif
5145       return
5146       end
5147 C------------------------------------------------------------------------------
5148       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5149       implicit real*8 (a-h,o-z)
5150       include 'DIMENSIONS'
5151       include 'COMMON.GEO'
5152       include 'COMMON.LOCAL'
5153       include 'COMMON.IOUNITS'
5154       common /sccalc/ time11,time12,time112,theti,it,nlobit
5155       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5156       double precision contr(maxlob)
5157       logical mixed
5158
5159       escloc_i=0.0D0
5160
5161       do j=1,3
5162         dersc(j)=0.0D0
5163       enddo
5164
5165       do j=1,nlobit
5166         do k=1,2
5167           z(k)=x(k)-censc(k,j,it)
5168         enddo
5169         z(3)=dwapi
5170         do k=1,3
5171           Axk=0.0D0
5172           do l=1,3
5173             Axk=Axk+gaussc(l,k,j,it)*z(l)
5174           enddo
5175           Ax(k,j)=Axk
5176         enddo
5177         expfac=0.0D0
5178         do k=1,3
5179           expfac=expfac+Ax(k,j)*z(k)
5180         enddo
5181         contr(j)=expfac
5182       enddo ! j
5183
5184 C As in the case of ebend, we want to avoid underflows in exponentiation and
5185 C subsequent NaNs and INFs in energy calculation.
5186 C Find the largest exponent
5187       emin=contr(1)
5188       do j=1,nlobit
5189         if (emin.gt.contr(j)) emin=contr(j)
5190       enddo
5191       emin=0.5D0*emin
5192
5193 C Compute the contribution to SC energy and derivatives
5194
5195       dersc12=0.0d0
5196       do j=1,nlobit
5197         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5198         escloc_i=escloc_i+expfac
5199         do k=1,2
5200           dersc(k)=dersc(k)+Ax(k,j)*expfac
5201         enddo
5202         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5203      &            +gaussc(1,2,j,it))*expfac
5204         dersc(3)=0.0d0
5205       enddo
5206
5207       dersc(1)=dersc(1)/cos(theti)**2
5208       dersc12=dersc12/cos(theti)**2
5209       escloci=-(dlog(escloc_i)-emin)
5210       do j=1,2
5211         dersc(j)=dersc(j)/escloc_i
5212       enddo
5213       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5214       return
5215       end
5216 #else
5217 c----------------------------------------------------------------------------------
5218       subroutine esc(escloc)
5219 C Calculate the local energy of a side chain and its derivatives in the
5220 C corresponding virtual-bond valence angles THETA and the spherical angles
5221 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5222 C added by Urszula Kozlowska. 07/11/2007
5223 C
5224       implicit real*8 (a-h,o-z)
5225       include 'DIMENSIONS'
5226       include 'COMMON.GEO'
5227       include 'COMMON.LOCAL'
5228       include 'COMMON.VAR'
5229       include 'COMMON.SCROT'
5230       include 'COMMON.INTERACT'
5231       include 'COMMON.DERIV'
5232       include 'COMMON.CHAIN'
5233       include 'COMMON.IOUNITS'
5234       include 'COMMON.NAMES'
5235       include 'COMMON.FFIELD'
5236       include 'COMMON.CONTROL'
5237       include 'COMMON.VECTORS'
5238       double precision x_prime(3),y_prime(3),z_prime(3)
5239      &    , sumene,dsc_i,dp2_i,x(65),
5240      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5241      &    de_dxx,de_dyy,de_dzz,de_dt
5242       double precision s1_t,s1_6_t,s2_t,s2_6_t
5243       double precision
5244      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5245      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5246      & dt_dCi(3),dt_dCi1(3)
5247       common /sccalc/ time11,time12,time112,theti,it,nlobit
5248       delta=0.02d0*pi
5249       escloc=0.0D0
5250       do i=loc_start,loc_end
5251         costtab(i+1) =dcos(theta(i+1))
5252         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5253         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5254         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5255         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5256         cosfac=dsqrt(cosfac2)
5257         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5258         sinfac=dsqrt(sinfac2)
5259         it=itype(i)
5260         if (it.eq.10) goto 1
5261 c
5262 C  Compute the axes of tghe local cartesian coordinates system; store in
5263 c   x_prime, y_prime and z_prime
5264 c
5265         do j=1,3
5266           x_prime(j) = 0.00
5267           y_prime(j) = 0.00
5268           z_prime(j) = 0.00
5269         enddo
5270 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5271 C     &   dc_norm(3,i+nres)
5272         do j = 1,3
5273           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5274           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5275         enddo
5276         do j = 1,3
5277           z_prime(j) = -uz(j,i-1)
5278         enddo
5279 c       write (2,*) "i",i
5280 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5281 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5282 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5283 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5284 c      & " xy",scalar(x_prime(1),y_prime(1)),
5285 c      & " xz",scalar(x_prime(1),z_prime(1)),
5286 c      & " yy",scalar(y_prime(1),y_prime(1)),
5287 c      & " yz",scalar(y_prime(1),z_prime(1)),
5288 c      & " zz",scalar(z_prime(1),z_prime(1))
5289 c
5290 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5291 C to local coordinate system. Store in xx, yy, zz.
5292 c
5293         xx=0.0d0
5294         yy=0.0d0
5295         zz=0.0d0
5296         do j = 1,3
5297           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5298           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5299           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5300         enddo
5301
5302         xxtab(i)=xx
5303         yytab(i)=yy
5304         zztab(i)=zz
5305 C
5306 C Compute the energy of the ith side cbain
5307 C
5308 c        write (2,*) "xx",xx," yy",yy," zz",zz
5309         it=itype(i)
5310         do j = 1,65
5311           x(j) = sc_parmin(j,it)
5312         enddo
5313 #ifdef CHECK_COORD
5314 Cc diagnostics - remove later
5315         xx1 = dcos(alph(2))
5316         yy1 = dsin(alph(2))*dcos(omeg(2))
5317         zz1 = -dsin(alph(2))*dsin(omeg(2))
5318         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5319      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5320      &    xx1,yy1,zz1
5321 C,"  --- ", xx_w,yy_w,zz_w
5322 c end diagnostics
5323 #endif
5324         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5325      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5326      &   + x(10)*yy*zz
5327         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5328      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5329      & + x(20)*yy*zz
5330         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5331      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5332      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5333      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5334      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5335      &  +x(40)*xx*yy*zz
5336         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5337      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5338      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5339      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5340      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5341      &  +x(60)*xx*yy*zz
5342         dsc_i   = 0.743d0+x(61)
5343         dp2_i   = 1.9d0+x(62)
5344         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5345      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5346         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5347      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5348         s1=(1+x(63))/(0.1d0 + dscp1)
5349         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5350         s2=(1+x(65))/(0.1d0 + dscp2)
5351         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5352         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5353      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5354 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5355 c     &   sumene4,
5356 c     &   dscp1,dscp2,sumene
5357 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5358         escloc = escloc + sumene
5359 c        write (2,*) "i",i," escloc",sumene,escloc
5360 #ifdef DEBUG
5361 C
5362 C This section to check the numerical derivatives of the energy of ith side
5363 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5364 C #define DEBUG in the code to turn it on.
5365 C
5366         write (2,*) "sumene               =",sumene
5367         aincr=1.0d-7
5368         xxsave=xx
5369         xx=xx+aincr
5370         write (2,*) xx,yy,zz
5371         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5372         de_dxx_num=(sumenep-sumene)/aincr
5373         xx=xxsave
5374         write (2,*) "xx+ sumene from enesc=",sumenep
5375         yysave=yy
5376         yy=yy+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dyy_num=(sumenep-sumene)/aincr
5380         yy=yysave
5381         write (2,*) "yy+ sumene from enesc=",sumenep
5382         zzsave=zz
5383         zz=zz+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dzz_num=(sumenep-sumene)/aincr
5387         zz=zzsave
5388         write (2,*) "zz+ sumene from enesc=",sumenep
5389         costsave=cost2tab(i+1)
5390         sintsave=sint2tab(i+1)
5391         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5392         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dt_num=(sumenep-sumene)/aincr
5395         write (2,*) " t+ sumene from enesc=",sumenep
5396         cost2tab(i+1)=costsave
5397         sint2tab(i+1)=sintsave
5398 C End of diagnostics section.
5399 #endif
5400 C
5401 C Compute the gradient of esc
5402 C
5403         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5404         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5405         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5406         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5407         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5408         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5409         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5410         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5411         pom1=(sumene3*sint2tab(i+1)+sumene1)
5412      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5413         pom2=(sumene4*cost2tab(i+1)+sumene2)
5414      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5415         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5416         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5417      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5418      &  +x(40)*yy*zz
5419         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5420         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5421      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5422      &  +x(60)*yy*zz
5423         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5424      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5425      &        +(pom1+pom2)*pom_dx
5426 #ifdef DEBUG
5427         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5428 #endif
5429 C
5430         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5431         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5432      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5433      &  +x(40)*xx*zz
5434         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5435         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5436      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5437      &  +x(59)*zz**2 +x(60)*xx*zz
5438         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5439      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5440      &        +(pom1-pom2)*pom_dy
5441 #ifdef DEBUG
5442         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5443 #endif
5444 C
5445         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5446      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5447      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5448      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5449      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5450      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5451      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5452      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5453 #ifdef DEBUG
5454         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5455 #endif
5456 C
5457         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5458      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5459      &  +pom1*pom_dt1+pom2*pom_dt2
5460 #ifdef DEBUG
5461         write(2,*), "de_dt = ", de_dt,de_dt_num
5462 #endif
5463 c
5464 C
5465        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5466        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5467        cosfac2xx=cosfac2*xx
5468        sinfac2yy=sinfac2*yy
5469        do k = 1,3
5470          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5471      &      vbld_inv(i+1)
5472          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5473      &      vbld_inv(i)
5474          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5475          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5476 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5477 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5478 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5479 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5480          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5481          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5482          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5483          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5484          dZZ_Ci1(k)=0.0d0
5485          dZZ_Ci(k)=0.0d0
5486          do j=1,3
5487            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5488            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5489          enddo
5490
5491          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5492          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5493          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5494 c
5495          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5496          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5497        enddo
5498
5499        do k=1,3
5500          dXX_Ctab(k,i)=dXX_Ci(k)
5501          dXX_C1tab(k,i)=dXX_Ci1(k)
5502          dYY_Ctab(k,i)=dYY_Ci(k)
5503          dYY_C1tab(k,i)=dYY_Ci1(k)
5504          dZZ_Ctab(k,i)=dZZ_Ci(k)
5505          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5506          dXX_XYZtab(k,i)=dXX_XYZ(k)
5507          dYY_XYZtab(k,i)=dYY_XYZ(k)
5508          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5509        enddo
5510
5511        do k = 1,3
5512 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5513 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5514 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5515 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5516 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5517 c     &    dt_dci(k)
5518 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5519 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5520          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5521      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5522          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5523      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5524          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5525      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5526        enddo
5527 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5528 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5529
5530 C to check gradient call subroutine check_grad
5531
5532     1 continue
5533       enddo
5534       return
5535       end
5536 c------------------------------------------------------------------------------
5537       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5538       implicit none
5539       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5540      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5541       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5542      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5543      &   + x(10)*yy*zz
5544       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5545      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5546      & + x(20)*yy*zz
5547       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5548      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5549      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5550      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5551      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5552      &  +x(40)*xx*yy*zz
5553       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5554      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5555      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5556      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5557      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5558      &  +x(60)*xx*yy*zz
5559       dsc_i   = 0.743d0+x(61)
5560       dp2_i   = 1.9d0+x(62)
5561       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5562      &          *(xx*cost2+yy*sint2))
5563       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5564      &          *(xx*cost2-yy*sint2))
5565       s1=(1+x(63))/(0.1d0 + dscp1)
5566       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5567       s2=(1+x(65))/(0.1d0 + dscp2)
5568       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5569       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5570      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5571       enesc=sumene
5572       return
5573       end
5574 #endif
5575 c------------------------------------------------------------------------------
5576       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5577 C
5578 C This procedure calculates two-body contact function g(rij) and its derivative:
5579 C
5580 C           eps0ij                                     !       x < -1
5581 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5582 C            0                                         !       x > 1
5583 C
5584 C where x=(rij-r0ij)/delta
5585 C
5586 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5587 C
5588       implicit none
5589       double precision rij,r0ij,eps0ij,fcont,fprimcont
5590       double precision x,x2,x4,delta
5591 c     delta=0.02D0*r0ij
5592 c      delta=0.2D0*r0ij
5593       x=(rij-r0ij)/delta
5594       if (x.lt.-1.0D0) then
5595         fcont=eps0ij
5596         fprimcont=0.0D0
5597       else if (x.le.1.0D0) then
5598         x2=x*x
5599         x4=x2*x2
5600         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5601         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5602       else
5603         fcont=0.0D0
5604         fprimcont=0.0D0
5605       endif
5606       return
5607       end
5608 c------------------------------------------------------------------------------
5609       subroutine splinthet(theti,delta,ss,ssder)
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'COMMON.VAR'
5613       include 'COMMON.GEO'
5614       thetup=pi-delta
5615       thetlow=delta
5616       if (theti.gt.pipol) then
5617         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5618       else
5619         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5620         ssder=-ssder
5621       endif
5622       return
5623       end
5624 c------------------------------------------------------------------------------
5625       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5626       implicit none
5627       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5628       double precision ksi,ksi2,ksi3,a1,a2,a3
5629       a1=fprim0*delta/(f1-f0)
5630       a2=3.0d0-2.0d0*a1
5631       a3=a1-2.0d0
5632       ksi=(x-x0)/delta
5633       ksi2=ksi*ksi
5634       ksi3=ksi2*ksi
5635       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5636       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5637       return
5638       end
5639 c------------------------------------------------------------------------------
5640       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5641       implicit none
5642       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5643       double precision ksi,ksi2,ksi3,a1,a2,a3
5644       ksi=(x-x0)/delta
5645       ksi2=ksi*ksi
5646       ksi3=ksi2*ksi
5647       a1=fprim0x*delta
5648       a2=3*(f1x-f0x)-2*fprim0x*delta
5649       a3=fprim0x*delta-2*(f1x-f0x)
5650       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5651       return
5652       end
5653 C-----------------------------------------------------------------------------
5654 #ifdef CRYST_TOR
5655 C-----------------------------------------------------------------------------
5656       subroutine etor(etors,edihcnstr)
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'COMMON.VAR'
5660       include 'COMMON.GEO'
5661       include 'COMMON.LOCAL'
5662       include 'COMMON.TORSION'
5663       include 'COMMON.INTERACT'
5664       include 'COMMON.DERIV'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.NAMES'
5667       include 'COMMON.IOUNITS'
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.TORCNSTR'
5670       include 'COMMON.CONTROL'
5671       logical lprn
5672 C Set lprn=.true. for debugging
5673       lprn=.false.
5674 c      lprn=.true.
5675       etors=0.0D0
5676       do i=iphi_start,iphi_end
5677       etors_ii=0.0D0
5678         itori=itortyp(itype(i-2))
5679         itori1=itortyp(itype(i-1))
5680         phii=phi(i)
5681         gloci=0.0D0
5682 C Proline-Proline pair is a special case...
5683         if (itori.eq.3 .and. itori1.eq.3) then
5684           if (phii.gt.-dwapi3) then
5685             cosphi=dcos(3*phii)
5686             fac=1.0D0/(1.0D0-cosphi)
5687             etorsi=v1(1,3,3)*fac
5688             etorsi=etorsi+etorsi
5689             etors=etors+etorsi-v1(1,3,3)
5690             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5691             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5692           endif
5693           do j=1,3
5694             v1ij=v1(j+1,itori,itori1)
5695             v2ij=v2(j+1,itori,itori1)
5696             cosphi=dcos(j*phii)
5697             sinphi=dsin(j*phii)
5698             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5699             if (energy_dec) etors_ii=etors_ii+
5700      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5701             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5702           enddo
5703         else
5704           do j=1,nterm_old
5705             v1ij=v1(j,itori,itori1)
5706             v2ij=v2(j,itori,itori1)
5707             cosphi=dcos(j*phii)
5708             sinphi=dsin(j*phii)
5709             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5710             if (energy_dec) etors_ii=etors_ii+
5711      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5712             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5713           enddo
5714         endif
5715         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5716      &        'etor',i,etors_ii
5717         if (lprn)
5718      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5719      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5720      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5721         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5722         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5723       enddo
5724 ! 6/20/98 - dihedral angle constraints
5725       edihcnstr=0.0d0
5726       do i=1,ndih_constr
5727         itori=idih_constr(i)
5728         phii=phi(itori)
5729         difi=phii-phi0(i)
5730         if (difi.gt.drange(i)) then
5731           difi=difi-drange(i)
5732           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5733           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5734         else if (difi.lt.-drange(i)) then
5735           difi=difi+drange(i)
5736           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5737           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5738         endif
5739 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5740 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5741       enddo
5742 !      write (iout,*) 'edihcnstr',edihcnstr
5743       return
5744       end
5745 c------------------------------------------------------------------------------
5746       subroutine etor_d(etors_d)
5747       etors_d=0.0d0
5748       return
5749       end
5750 c----------------------------------------------------------------------------
5751 #else
5752       subroutine etor(etors,edihcnstr)
5753       implicit real*8 (a-h,o-z)
5754       include 'DIMENSIONS'
5755       include 'COMMON.VAR'
5756       include 'COMMON.GEO'
5757       include 'COMMON.LOCAL'
5758       include 'COMMON.TORSION'
5759       include 'COMMON.INTERACT'
5760       include 'COMMON.DERIV'
5761       include 'COMMON.CHAIN'
5762       include 'COMMON.NAMES'
5763       include 'COMMON.IOUNITS'
5764       include 'COMMON.FFIELD'
5765       include 'COMMON.TORCNSTR'
5766       include 'COMMON.CONTROL'
5767       logical lprn
5768 C Set lprn=.true. for debugging
5769       lprn=.false.
5770 c     lprn=.true.
5771       etors=0.0D0
5772       do i=iphi_start,iphi_end
5773       etors_ii=0.0D0
5774         itori=itortyp(itype(i-2))
5775         itori1=itortyp(itype(i-1))
5776         if (iabs(itype(i)).eq.20) then
5777         iblock=2
5778         else
5779         iblock=1
5780         endif
5781         phii=phi(i)
5782         gloci=0.0D0
5783 C Regular cosine and sine terms
5784         do j=1,nterm(itori,itori1,iblock)
5785           v1ij=v1(j,itori,itori1,iblock)
5786           v2ij=v2(j,itori,itori1,iblock)
5787           cosphi=dcos(j*phii)
5788           sinphi=dsin(j*phii)
5789           etors=etors+v1ij*cosphi+v2ij*sinphi
5790           if (energy_dec) etors_ii=etors_ii+
5791      &                v1ij*cosphi+v2ij*sinphi
5792           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5793         enddo
5794 C Lorentz terms
5795 C                         v1
5796 C  E = SUM ----------------------------------- - v1
5797 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5798 C
5799         cosphi=dcos(0.5d0*phii)
5800         sinphi=dsin(0.5d0*phii)
5801         do j=1,nlor(itori,itori1,iblock)
5802           vl1ij=vlor1(j,itori,itori1)
5803           vl2ij=vlor2(j,itori,itori1)
5804           vl3ij=vlor3(j,itori,itori1)
5805           pom=vl2ij*cosphi+vl3ij*sinphi
5806           pom1=1.0d0/(pom*pom+1.0d0)
5807           etors=etors+vl1ij*pom1
5808           if (energy_dec) etors_ii=etors_ii+
5809      &                vl1ij*pom1
5810           pom=-pom*pom1*pom1
5811           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5812         enddo
5813 C Subtract the constant term
5814         etors=etors-v0(itori,itori1,iblock)
5815           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5816      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5817         if (lprn)
5818      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5819      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5820      &  (v1(j,itori,itori1,iblock),j=1,6),
5821      &  (v2(j,itori,itori1,iblock),j=1,6)
5822         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5823 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5824       enddo
5825 ! 6/20/98 - dihedral angle constraints
5826       edihcnstr=0.0d0
5827 c      do i=1,ndih_constr
5828       do i=idihconstr_start,idihconstr_end
5829         itori=idih_constr(i)
5830         phii=phi(itori)
5831         difi=pinorm(phii-phi0(i))
5832         if (difi.gt.drange(i)) then
5833           difi=difi-drange(i)
5834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5836         else if (difi.lt.-drange(i)) then
5837           difi=difi+drange(i)
5838           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5839           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5840         else
5841           difi=0.0
5842         endif
5843 c        write (iout,*) "gloci", gloc(i-3,icg)
5844 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5845 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5846 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5847       enddo
5848 cd       write (iout,*) 'edihcnstr',edihcnstr
5849       return
5850       end
5851 c----------------------------------------------------------------------------
5852       subroutine etor_d(etors_d)
5853 C 6/23/01 Compute double torsional energy
5854       implicit real*8 (a-h,o-z)
5855       include 'DIMENSIONS'
5856       include 'COMMON.VAR'
5857       include 'COMMON.GEO'
5858       include 'COMMON.LOCAL'
5859       include 'COMMON.TORSION'
5860       include 'COMMON.INTERACT'
5861       include 'COMMON.DERIV'
5862       include 'COMMON.CHAIN'
5863       include 'COMMON.NAMES'
5864       include 'COMMON.IOUNITS'
5865       include 'COMMON.FFIELD'
5866       include 'COMMON.TORCNSTR'
5867       logical lprn
5868 C Set lprn=.true. for debugging
5869       lprn=.false.
5870 c     lprn=.true.
5871       etors_d=0.0D0
5872       do i=iphid_start,iphid_end
5873         itori=itortyp(itype(i-2))
5874         itori1=itortyp(itype(i-1))
5875         itori2=itortyp(itype(i))
5876         iblock=1
5877         if (iabs(itype(i+1).eq.20)) iblock=2
5878         phii=phi(i)
5879         phii1=phi(i+1)
5880         gloci1=0.0D0
5881         gloci2=0.0D0
5882         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5883           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5884           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5885           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5886           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5887           cosphi1=dcos(j*phii)
5888           sinphi1=dsin(j*phii)
5889           cosphi2=dcos(j*phii1)
5890           sinphi2=dsin(j*phii1)
5891           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5892      &     v2cij*cosphi2+v2sij*sinphi2
5893           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5894           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5895         enddo
5896         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5897           do l=1,k-1
5898             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5899             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5900             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5901             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5902             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5903             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5904             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5905             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5906             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5907      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5908             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5909      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5910             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5911      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5912           enddo
5913         enddo
5914         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5915         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5916 c        write (iout,*) "gloci", gloc(i-3,icg)
5917       enddo
5918       return
5919       end
5920 #endif
5921 c------------------------------------------------------------------------------
5922       subroutine eback_sc_corr(esccor)
5923 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5924 c        conformational states; temporarily implemented as differences
5925 c        between UNRES torsional potentials (dependent on three types of
5926 c        residues) and the torsional potentials dependent on all 20 types
5927 c        of residues computed from AM1  energy surfaces of terminally-blocked
5928 c        amino-acid residues.
5929       implicit real*8 (a-h,o-z)
5930       include 'DIMENSIONS'
5931       include 'COMMON.VAR'
5932       include 'COMMON.GEO'
5933       include 'COMMON.LOCAL'
5934       include 'COMMON.TORSION'
5935       include 'COMMON.SCCOR'
5936       include 'COMMON.INTERACT'
5937       include 'COMMON.DERIV'
5938       include 'COMMON.CHAIN'
5939       include 'COMMON.NAMES'
5940       include 'COMMON.IOUNITS'
5941       include 'COMMON.FFIELD'
5942       include 'COMMON.CONTROL'
5943       logical lprn
5944 C Set lprn=.true. for debugging
5945       lprn=.false.
5946 c      lprn=.true.
5947 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5948       esccor=0.0D0
5949       do i=itau_start,itau_end
5950         esccor_ii=0.0D0
5951         isccori=isccortyp(itype(i-2))
5952         isccori1=isccortyp(itype(i-1))
5953         phii=phi(i)
5954 cccc  Added 9 May 2012
5955 cc Tauangle is torsional engle depending on the value of first digit
5956 c(see comment below)
5957 cc Omicron is flat angle depending on the value of first digit
5958 c(see comment below)
5959
5960
5961         do intertyp=1,3 !intertyp
5962 cc Added 09 May 2012 (Adasko)
5963 cc  Intertyp means interaction type of backbone mainchain correlation:
5964 c   1 = SC...Ca...Ca...Ca
5965 c   2 = Ca...Ca...Ca...SC
5966 c   3 = SC...Ca...Ca...SCi
5967         gloci=0.0D0
5968         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5969      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5970      &      (itype(i-1).eq.21)))
5971      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5972      &     .or.(itype(i-2).eq.21)))
5973      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5974      &      (itype(i-1).eq.21)))) cycle
5975         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5976         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5977      & cycle
5978         do j=1,nterm_sccor(isccori,isccori1)
5979           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5980           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5981           cosphi=dcos(j*tauangle(intertyp,i))
5982           sinphi=dsin(j*tauangle(intertyp,i))
5983           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5984           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5985         enddo
5986         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5987 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5988 c     &gloc_sc(intertyp,i-3,icg)
5989         if (lprn)
5990      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5991      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5992      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5993      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5994         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5995        enddo !intertyp
5996       enddo
5997 c        do i=1,nres
5998 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5999 c        enddo
6000       return
6001       end
6002 c----------------------------------------------------------------------------
6003       subroutine multibody(ecorr)
6004 C This subroutine calculates multi-body contributions to energy following
6005 C the idea of Skolnick et al. If side chains I and J make a contact and
6006 C at the same time side chains I+1 and J+1 make a contact, an extra
6007 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.IOUNITS'
6011       include 'COMMON.DERIV'
6012       include 'COMMON.INTERACT'
6013       include 'COMMON.CONTACTS'
6014       double precision gx(3),gx1(3)
6015       logical lprn
6016
6017 C Set lprn=.true. for debugging
6018       lprn=.false.
6019
6020       if (lprn) then
6021         write (iout,'(a)') 'Contact function values:'
6022         do i=nnt,nct-2
6023           write (iout,'(i2,20(1x,i2,f10.5))')
6024      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6025         enddo
6026       endif
6027       ecorr=0.0D0
6028       do i=nnt,nct
6029         do j=1,3
6030           gradcorr(j,i)=0.0D0
6031           gradxorr(j,i)=0.0D0
6032         enddo
6033       enddo
6034       do i=nnt,nct-2
6035
6036         DO ISHIFT = 3,4
6037
6038         i1=i+ishift
6039         num_conti=num_cont(i)
6040         num_conti1=num_cont(i1)
6041         do jj=1,num_conti
6042           j=jcont(jj,i)
6043           do kk=1,num_conti1
6044             j1=jcont(kk,i1)
6045             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6046 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6047 cd   &                   ' ishift=',ishift
6048 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6049 C The system gains extra energy.
6050               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6051             endif   ! j1==j+-ishift
6052           enddo     ! kk
6053         enddo       ! jj
6054
6055         ENDDO ! ISHIFT
6056
6057       enddo         ! i
6058       return
6059       end
6060 c------------------------------------------------------------------------------
6061       double precision function esccorr(i,j,k,l,jj,kk)
6062       implicit real*8 (a-h,o-z)
6063       include 'DIMENSIONS'
6064       include 'COMMON.IOUNITS'
6065       include 'COMMON.DERIV'
6066       include 'COMMON.INTERACT'
6067       include 'COMMON.CONTACTS'
6068       double precision gx(3),gx1(3)
6069       logical lprn
6070       lprn=.false.
6071       eij=facont(jj,i)
6072       ekl=facont(kk,k)
6073 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6074 C Calculate the multi-body contribution to energy.
6075 C Calculate multi-body contributions to the gradient.
6076 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6077 cd   & k,l,(gacont(m,kk,k),m=1,3)
6078       do m=1,3
6079         gx(m) =ekl*gacont(m,jj,i)
6080         gx1(m)=eij*gacont(m,kk,k)
6081         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6082         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6083         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6084         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6085       enddo
6086       do m=i,j-1
6087         do ll=1,3
6088           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6089         enddo
6090       enddo
6091       do m=k,l-1
6092         do ll=1,3
6093           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6094         enddo
6095       enddo
6096       esccorr=-eij*ekl
6097       return
6098       end
6099 c------------------------------------------------------------------------------
6100       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6101 C This subroutine calculates multi-body contributions to hydrogen-bonding
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.IOUNITS'
6105 #ifdef MPI
6106       include "mpif.h"
6107       parameter (max_cont=maxconts)
6108       parameter (max_dim=26)
6109       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6110       double precision zapas(max_dim,maxconts,max_fg_procs),
6111      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6112       common /przechowalnia/ zapas
6113       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6114      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6115 #endif
6116       include 'COMMON.SETUP'
6117       include 'COMMON.FFIELD'
6118       include 'COMMON.DERIV'
6119       include 'COMMON.INTERACT'
6120       include 'COMMON.CONTACTS'
6121       include 'COMMON.CONTROL'
6122       include 'COMMON.LOCAL'
6123       double precision gx(3),gx1(3),time00
6124       logical lprn,ldone
6125
6126 C Set lprn=.true. for debugging
6127       lprn=.false.
6128 #ifdef MPI
6129       n_corr=0
6130       n_corr1=0
6131       if (nfgtasks.le.1) goto 30
6132       if (lprn) then
6133         write (iout,'(a)') 'Contact function values before RECEIVE:'
6134         do i=nnt,nct-2
6135           write (iout,'(2i3,50(1x,i2,f5.2))')
6136      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6137      &    j=1,num_cont_hb(i))
6138         enddo
6139       endif
6140       call flush(iout)
6141       do i=1,ntask_cont_from
6142         ncont_recv(i)=0
6143       enddo
6144       do i=1,ntask_cont_to
6145         ncont_sent(i)=0
6146       enddo
6147 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6148 c     & ntask_cont_to
6149 C Make the list of contacts to send to send to other procesors
6150 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6151 c      call flush(iout)
6152       do i=iturn3_start,iturn3_end
6153 c        write (iout,*) "make contact list turn3",i," num_cont",
6154 c     &    num_cont_hb(i)
6155         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6156       enddo
6157       do i=iturn4_start,iturn4_end
6158 c        write (iout,*) "make contact list turn4",i," num_cont",
6159 c     &   num_cont_hb(i)
6160         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6161       enddo
6162       do ii=1,nat_sent
6163         i=iat_sent(ii)
6164 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6165 c     &    num_cont_hb(i)
6166         do j=1,num_cont_hb(i)
6167         do k=1,4
6168           jjc=jcont_hb(j,i)
6169           iproc=iint_sent_local(k,jjc,ii)
6170 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6171           if (iproc.gt.0) then
6172             ncont_sent(iproc)=ncont_sent(iproc)+1
6173             nn=ncont_sent(iproc)
6174             zapas(1,nn,iproc)=i
6175             zapas(2,nn,iproc)=jjc
6176             zapas(3,nn,iproc)=facont_hb(j,i)
6177             zapas(4,nn,iproc)=ees0p(j,i)
6178             zapas(5,nn,iproc)=ees0m(j,i)
6179             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6180             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6181             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6182             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6183             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6184             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6185             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6186             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6187             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6188             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6189             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6190             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6191             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6192             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6193             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6194             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6195             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6196             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6197             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6198             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6199             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6200           endif
6201         enddo
6202         enddo
6203       enddo
6204       if (lprn) then
6205       write (iout,*)
6206      &  "Numbers of contacts to be sent to other processors",
6207      &  (ncont_sent(i),i=1,ntask_cont_to)
6208       write (iout,*) "Contacts sent"
6209       do ii=1,ntask_cont_to
6210         nn=ncont_sent(ii)
6211         iproc=itask_cont_to(ii)
6212         write (iout,*) nn," contacts to processor",iproc,
6213      &   " of CONT_TO_COMM group"
6214         do i=1,nn
6215           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6216         enddo
6217       enddo
6218       call flush(iout)
6219       endif
6220       CorrelType=477
6221       CorrelID=fg_rank+1
6222       CorrelType1=478
6223       CorrelID1=nfgtasks+fg_rank+1
6224       ireq=0
6225 C Receive the numbers of needed contacts from other processors
6226       do ii=1,ntask_cont_from
6227         iproc=itask_cont_from(ii)
6228         ireq=ireq+1
6229         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6230      &    FG_COMM,req(ireq),IERR)
6231       enddo
6232 c      write (iout,*) "IRECV ended"
6233 c      call flush(iout)
6234 C Send the number of contacts needed by other processors
6235       do ii=1,ntask_cont_to
6236         iproc=itask_cont_to(ii)
6237         ireq=ireq+1
6238         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6239      &    FG_COMM,req(ireq),IERR)
6240       enddo
6241 c      write (iout,*) "ISEND ended"
6242 c      write (iout,*) "number of requests (nn)",ireq
6243       call flush(iout)
6244       if (ireq.gt.0)
6245      &  call MPI_Waitall(ireq,req,status_array,ierr)
6246 c      write (iout,*)
6247 c     &  "Numbers of contacts to be received from other processors",
6248 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6249 c      call flush(iout)
6250 C Receive contacts
6251       ireq=0
6252       do ii=1,ntask_cont_from
6253         iproc=itask_cont_from(ii)
6254         nn=ncont_recv(ii)
6255 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6256 c     &   " of CONT_TO_COMM group"
6257         call flush(iout)
6258         if (nn.gt.0) then
6259           ireq=ireq+1
6260           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6261      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6262 c          write (iout,*) "ireq,req",ireq,req(ireq)
6263         endif
6264       enddo
6265 C Send the contacts to processors that need them
6266       do ii=1,ntask_cont_to
6267         iproc=itask_cont_to(ii)
6268         nn=ncont_sent(ii)
6269 c        write (iout,*) nn," contacts to processor",iproc,
6270 c     &   " of CONT_TO_COMM group"
6271         if (nn.gt.0) then
6272           ireq=ireq+1
6273           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6274      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6275 c          write (iout,*) "ireq,req",ireq,req(ireq)
6276 c          do i=1,nn
6277 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6278 c          enddo
6279         endif
6280       enddo
6281 c      write (iout,*) "number of requests (contacts)",ireq
6282 c      write (iout,*) "req",(req(i),i=1,4)
6283 c      call flush(iout)
6284       if (ireq.gt.0)
6285      & call MPI_Waitall(ireq,req,status_array,ierr)
6286       do iii=1,ntask_cont_from
6287         iproc=itask_cont_from(iii)
6288         nn=ncont_recv(iii)
6289         if (lprn) then
6290         write (iout,*) "Received",nn," contacts from processor",iproc,
6291      &   " of CONT_FROM_COMM group"
6292         call flush(iout)
6293         do i=1,nn
6294           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6295         enddo
6296         call flush(iout)
6297         endif
6298         do i=1,nn
6299           ii=zapas_recv(1,i,iii)
6300 c Flag the received contacts to prevent double-counting
6301           jj=-zapas_recv(2,i,iii)
6302 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6303 c          call flush(iout)
6304           nnn=num_cont_hb(ii)+1
6305           num_cont_hb(ii)=nnn
6306           jcont_hb(nnn,ii)=jj
6307           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6308           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6309           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6310           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6311           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6312           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6313           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6314           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6315           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6316           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6317           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6318           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6319           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6320           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6321           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6322           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6323           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6324           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6325           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6326           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6327           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6328           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6329           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6330           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6331         enddo
6332       enddo
6333       call flush(iout)
6334       if (lprn) then
6335         write (iout,'(a)') 'Contact function values after receive:'
6336         do i=nnt,nct-2
6337           write (iout,'(2i3,50(1x,i3,f5.2))')
6338      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6339      &    j=1,num_cont_hb(i))
6340         enddo
6341         call flush(iout)
6342       endif
6343    30 continue
6344 #endif
6345       if (lprn) then
6346         write (iout,'(a)') 'Contact function values:'
6347         do i=nnt,nct-2
6348           write (iout,'(2i3,50(1x,i3,f5.2))')
6349      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6350      &    j=1,num_cont_hb(i))
6351         enddo
6352       endif
6353       ecorr=0.0D0
6354 C Remove the loop below after debugging !!!
6355       do i=nnt,nct
6356         do j=1,3
6357           gradcorr(j,i)=0.0D0
6358           gradxorr(j,i)=0.0D0
6359         enddo
6360       enddo
6361 C Calculate the local-electrostatic correlation terms
6362       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6363         i1=i+1
6364         num_conti=num_cont_hb(i)
6365         num_conti1=num_cont_hb(i+1)
6366         do jj=1,num_conti
6367           j=jcont_hb(jj,i)
6368           jp=iabs(j)
6369           do kk=1,num_conti1
6370             j1=jcont_hb(kk,i1)
6371             jp1=iabs(j1)
6372 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6373 c     &         ' jj=',jj,' kk=',kk
6374             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6375      &          .or. j.lt.0 .and. j1.gt.0) .and.
6376      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6377 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6378 C The system gains extra energy.
6379               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6380               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6381      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6382               n_corr=n_corr+1
6383             else if (j1.eq.j) then
6384 C Contacts I-J and I-(J+1) occur simultaneously.
6385 C The system loses extra energy.
6386 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6387             endif
6388           enddo ! kk
6389           do kk=1,num_conti
6390             j1=jcont_hb(kk,i)
6391 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6392 c    &         ' jj=',jj,' kk=',kk
6393             if (j1.eq.j+1) then
6394 C Contacts I-J and (I+1)-J occur simultaneously.
6395 C The system loses extra energy.
6396 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6397             endif ! j1==j+1
6398           enddo ! kk
6399         enddo ! jj
6400       enddo ! i
6401       return
6402       end
6403 c------------------------------------------------------------------------------
6404       subroutine add_hb_contact(ii,jj,itask)
6405       implicit real*8 (a-h,o-z)
6406       include "DIMENSIONS"
6407       include "COMMON.IOUNITS"
6408       integer max_cont
6409       integer max_dim
6410       parameter (max_cont=maxconts)
6411       parameter (max_dim=26)
6412       include "COMMON.CONTACTS"
6413       double precision zapas(max_dim,maxconts,max_fg_procs),
6414      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6415       common /przechowalnia/ zapas
6416       integer i,j,ii,jj,iproc,itask(4),nn
6417 c      write (iout,*) "itask",itask
6418       do i=1,2
6419         iproc=itask(i)
6420         if (iproc.gt.0) then
6421           do j=1,num_cont_hb(ii)
6422             jjc=jcont_hb(j,ii)
6423 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6424             if (jjc.eq.jj) then
6425               ncont_sent(iproc)=ncont_sent(iproc)+1
6426               nn=ncont_sent(iproc)
6427               zapas(1,nn,iproc)=ii
6428               zapas(2,nn,iproc)=jjc
6429               zapas(3,nn,iproc)=facont_hb(j,ii)
6430               zapas(4,nn,iproc)=ees0p(j,ii)
6431               zapas(5,nn,iproc)=ees0m(j,ii)
6432               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6433               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6434               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6435               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6436               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6437               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6438               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6439               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6440               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6441               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6442               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6443               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6444               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6445               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6446               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6447               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6448               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6449               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6450               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6451               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6452               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6453               exit
6454             endif
6455           enddo
6456         endif
6457       enddo
6458       return
6459       end
6460 c------------------------------------------------------------------------------
6461       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6462      &  n_corr1)
6463 C This subroutine calculates multi-body contributions to hydrogen-bonding
6464       implicit real*8 (a-h,o-z)
6465       include 'DIMENSIONS'
6466       include 'COMMON.IOUNITS'
6467 #ifdef MPI
6468       include "mpif.h"
6469       parameter (max_cont=maxconts)
6470       parameter (max_dim=70)
6471       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6472       double precision zapas(max_dim,maxconts,max_fg_procs),
6473      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6474       common /przechowalnia/ zapas
6475       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6476      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6477 #endif
6478       include 'COMMON.SETUP'
6479       include 'COMMON.FFIELD'
6480       include 'COMMON.DERIV'
6481       include 'COMMON.LOCAL'
6482       include 'COMMON.INTERACT'
6483       include 'COMMON.CONTACTS'
6484       include 'COMMON.CHAIN'
6485       include 'COMMON.CONTROL'
6486       double precision gx(3),gx1(3)
6487       integer num_cont_hb_old(maxres)
6488       logical lprn,ldone
6489       double precision eello4,eello5,eelo6,eello_turn6
6490       external eello4,eello5,eello6,eello_turn6
6491 C Set lprn=.true. for debugging
6492       lprn=.false.
6493       eturn6=0.0d0
6494 #ifdef MPI
6495       do i=1,nres
6496         num_cont_hb_old(i)=num_cont_hb(i)
6497       enddo
6498       n_corr=0
6499       n_corr1=0
6500       if (nfgtasks.le.1) goto 30
6501       if (lprn) then
6502         write (iout,'(a)') 'Contact function values before RECEIVE:'
6503         do i=nnt,nct-2
6504           write (iout,'(2i3,50(1x,i2,f5.2))')
6505      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6506      &    j=1,num_cont_hb(i))
6507         enddo
6508       endif
6509       call flush(iout)
6510       do i=1,ntask_cont_from
6511         ncont_recv(i)=0
6512       enddo
6513       do i=1,ntask_cont_to
6514         ncont_sent(i)=0
6515       enddo
6516 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6517 c     & ntask_cont_to
6518 C Make the list of contacts to send to send to other procesors
6519       do i=iturn3_start,iturn3_end
6520 c        write (iout,*) "make contact list turn3",i," num_cont",
6521 c     &    num_cont_hb(i)
6522         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6523       enddo
6524       do i=iturn4_start,iturn4_end
6525 c        write (iout,*) "make contact list turn4",i," num_cont",
6526 c     &   num_cont_hb(i)
6527         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6528       enddo
6529       do ii=1,nat_sent
6530         i=iat_sent(ii)
6531 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6532 c     &    num_cont_hb(i)
6533         do j=1,num_cont_hb(i)
6534         do k=1,4
6535           jjc=jcont_hb(j,i)
6536           iproc=iint_sent_local(k,jjc,ii)
6537 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6538           if (iproc.ne.0) then
6539             ncont_sent(iproc)=ncont_sent(iproc)+1
6540             nn=ncont_sent(iproc)
6541             zapas(1,nn,iproc)=i
6542             zapas(2,nn,iproc)=jjc
6543             zapas(3,nn,iproc)=d_cont(j,i)
6544             ind=3
6545             do kk=1,3
6546               ind=ind+1
6547               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6548             enddo
6549             do kk=1,2
6550               do ll=1,2
6551                 ind=ind+1
6552                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6553               enddo
6554             enddo
6555             do jj=1,5
6556               do kk=1,3
6557                 do ll=1,2
6558                   do mm=1,2
6559                     ind=ind+1
6560                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6561                   enddo
6562                 enddo
6563               enddo
6564             enddo
6565           endif
6566         enddo
6567         enddo
6568       enddo
6569       if (lprn) then
6570       write (iout,*)
6571      &  "Numbers of contacts to be sent to other processors",
6572      &  (ncont_sent(i),i=1,ntask_cont_to)
6573       write (iout,*) "Contacts sent"
6574       do ii=1,ntask_cont_to
6575         nn=ncont_sent(ii)
6576         iproc=itask_cont_to(ii)
6577         write (iout,*) nn," contacts to processor",iproc,
6578      &   " of CONT_TO_COMM group"
6579         do i=1,nn
6580           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6581         enddo
6582       enddo
6583       call flush(iout)
6584       endif
6585       CorrelType=477
6586       CorrelID=fg_rank+1
6587       CorrelType1=478
6588       CorrelID1=nfgtasks+fg_rank+1
6589       ireq=0
6590 C Receive the numbers of needed contacts from other processors
6591       do ii=1,ntask_cont_from
6592         iproc=itask_cont_from(ii)
6593         ireq=ireq+1
6594         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6595      &    FG_COMM,req(ireq),IERR)
6596       enddo
6597 c      write (iout,*) "IRECV ended"
6598 c      call flush(iout)
6599 C Send the number of contacts needed by other processors
6600       do ii=1,ntask_cont_to
6601         iproc=itask_cont_to(ii)
6602         ireq=ireq+1
6603         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6604      &    FG_COMM,req(ireq),IERR)
6605       enddo
6606 c      write (iout,*) "ISEND ended"
6607 c      write (iout,*) "number of requests (nn)",ireq
6608       call flush(iout)
6609       if (ireq.gt.0)
6610      &  call MPI_Waitall(ireq,req,status_array,ierr)
6611 c      write (iout,*)
6612 c     &  "Numbers of contacts to be received from other processors",
6613 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6614 c      call flush(iout)
6615 C Receive contacts
6616       ireq=0
6617       do ii=1,ntask_cont_from
6618         iproc=itask_cont_from(ii)
6619         nn=ncont_recv(ii)
6620 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6621 c     &   " of CONT_TO_COMM group"
6622         call flush(iout)
6623         if (nn.gt.0) then
6624           ireq=ireq+1
6625           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6626      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6627 c          write (iout,*) "ireq,req",ireq,req(ireq)
6628         endif
6629       enddo
6630 C Send the contacts to processors that need them
6631       do ii=1,ntask_cont_to
6632         iproc=itask_cont_to(ii)
6633         nn=ncont_sent(ii)
6634 c        write (iout,*) nn," contacts to processor",iproc,
6635 c     &   " of CONT_TO_COMM group"
6636         if (nn.gt.0) then
6637           ireq=ireq+1
6638           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6639      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6640 c          write (iout,*) "ireq,req",ireq,req(ireq)
6641 c          do i=1,nn
6642 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6643 c          enddo
6644         endif
6645       enddo
6646 c      write (iout,*) "number of requests (contacts)",ireq
6647 c      write (iout,*) "req",(req(i),i=1,4)
6648 c      call flush(iout)
6649       if (ireq.gt.0)
6650      & call MPI_Waitall(ireq,req,status_array,ierr)
6651       do iii=1,ntask_cont_from
6652         iproc=itask_cont_from(iii)
6653         nn=ncont_recv(iii)
6654         if (lprn) then
6655         write (iout,*) "Received",nn," contacts from processor",iproc,
6656      &   " of CONT_FROM_COMM group"
6657         call flush(iout)
6658         do i=1,nn
6659           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6660         enddo
6661         call flush(iout)
6662         endif
6663         do i=1,nn
6664           ii=zapas_recv(1,i,iii)
6665 c Flag the received contacts to prevent double-counting
6666           jj=-zapas_recv(2,i,iii)
6667 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6668 c          call flush(iout)
6669           nnn=num_cont_hb(ii)+1
6670           num_cont_hb(ii)=nnn
6671           jcont_hb(nnn,ii)=jj
6672           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6673           ind=3
6674           do kk=1,3
6675             ind=ind+1
6676             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6677           enddo
6678           do kk=1,2
6679             do ll=1,2
6680               ind=ind+1
6681               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6682             enddo
6683           enddo
6684           do jj=1,5
6685             do kk=1,3
6686               do ll=1,2
6687                 do mm=1,2
6688                   ind=ind+1
6689                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6690                 enddo
6691               enddo
6692             enddo
6693           enddo
6694         enddo
6695       enddo
6696       call flush(iout)
6697       if (lprn) then
6698         write (iout,'(a)') 'Contact function values after receive:'
6699         do i=nnt,nct-2
6700           write (iout,'(2i3,50(1x,i3,5f6.3))')
6701      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6702      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6703         enddo
6704         call flush(iout)
6705       endif
6706    30 continue
6707 #endif
6708       if (lprn) then
6709         write (iout,'(a)') 'Contact function values:'
6710         do i=nnt,nct-2
6711           write (iout,'(2i3,50(1x,i2,5f6.3))')
6712      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6713      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6714         enddo
6715       endif
6716       ecorr=0.0D0
6717       ecorr5=0.0d0
6718       ecorr6=0.0d0
6719 C Remove the loop below after debugging !!!
6720       do i=nnt,nct
6721         do j=1,3
6722           gradcorr(j,i)=0.0D0
6723           gradxorr(j,i)=0.0D0
6724         enddo
6725       enddo
6726 C Calculate the dipole-dipole interaction energies
6727       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6728       do i=iatel_s,iatel_e+1
6729         num_conti=num_cont_hb(i)
6730         do jj=1,num_conti
6731           j=jcont_hb(jj,i)
6732 #ifdef MOMENT
6733           call dipole(i,j,jj)
6734 #endif
6735         enddo
6736       enddo
6737       endif
6738 C Calculate the local-electrostatic correlation terms
6739 c                write (iout,*) "gradcorr5 in eello5 before loop"
6740 c                do iii=1,nres
6741 c                  write (iout,'(i5,3f10.5)')
6742 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6743 c                enddo
6744       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6745 c        write (iout,*) "corr loop i",i
6746         i1=i+1
6747         num_conti=num_cont_hb(i)
6748         num_conti1=num_cont_hb(i+1)
6749         do jj=1,num_conti
6750           j=jcont_hb(jj,i)
6751           jp=iabs(j)
6752           do kk=1,num_conti1
6753             j1=jcont_hb(kk,i1)
6754             jp1=iabs(j1)
6755 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6756 c     &         ' jj=',jj,' kk=',kk
6757 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6758             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6759      &          .or. j.lt.0 .and. j1.gt.0) .and.
6760      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6761 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6762 C The system gains extra energy.
6763               n_corr=n_corr+1
6764               sqd1=dsqrt(d_cont(jj,i))
6765               sqd2=dsqrt(d_cont(kk,i1))
6766               sred_geom = sqd1*sqd2
6767               IF (sred_geom.lt.cutoff_corr) THEN
6768                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6769      &            ekont,fprimcont)
6770 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6771 cd     &         ' jj=',jj,' kk=',kk
6772                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6773                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6774                 do l=1,3
6775                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6776                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6777                 enddo
6778                 n_corr1=n_corr1+1
6779 cd               write (iout,*) 'sred_geom=',sred_geom,
6780 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6781 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6782 cd               write (iout,*) "g_contij",g_contij
6783 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6784 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6785                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6786                 if (wcorr4.gt.0.0d0)
6787      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6788                   if (energy_dec.and.wcorr4.gt.0.0d0)
6789      1                 write (iout,'(a6,4i5,0pf7.3)')
6790      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6791 c                write (iout,*) "gradcorr5 before eello5"
6792 c                do iii=1,nres
6793 c                  write (iout,'(i5,3f10.5)')
6794 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6795 c                enddo
6796                 if (wcorr5.gt.0.0d0)
6797      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6798 c                write (iout,*) "gradcorr5 after eello5"
6799 c                do iii=1,nres
6800 c                  write (iout,'(i5,3f10.5)')
6801 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6802 c                enddo
6803                   if (energy_dec.and.wcorr5.gt.0.0d0)
6804      1                 write (iout,'(a6,4i5,0pf7.3)')
6805      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6806 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6807 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6808                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6809      &               .or. wturn6.eq.0.0d0))then
6810 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6811                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6812                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6813      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6814 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6815 cd     &            'ecorr6=',ecorr6
6816 cd                write (iout,'(4e15.5)') sred_geom,
6817 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6818 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6819 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6820                 else if (wturn6.gt.0.0d0
6821      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6822 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6823                   eturn6=eturn6+eello_turn6(i,jj,kk)
6824                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6825      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6826 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6827                 endif
6828               ENDIF
6829 1111          continue
6830             endif
6831           enddo ! kk
6832         enddo ! jj
6833       enddo ! i
6834       do i=1,nres
6835         num_cont_hb(i)=num_cont_hb_old(i)
6836       enddo
6837 c                write (iout,*) "gradcorr5 in eello5"
6838 c                do iii=1,nres
6839 c                  write (iout,'(i5,3f10.5)')
6840 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6841 c                enddo
6842       return
6843       end
6844 c------------------------------------------------------------------------------
6845       subroutine add_hb_contact_eello(ii,jj,itask)
6846       implicit real*8 (a-h,o-z)
6847       include "DIMENSIONS"
6848       include "COMMON.IOUNITS"
6849       integer max_cont
6850       integer max_dim
6851       parameter (max_cont=maxconts)
6852       parameter (max_dim=70)
6853       include "COMMON.CONTACTS"
6854       double precision zapas(max_dim,maxconts,max_fg_procs),
6855      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6856       common /przechowalnia/ zapas
6857       integer i,j,ii,jj,iproc,itask(4),nn
6858 c      write (iout,*) "itask",itask
6859       do i=1,2
6860         iproc=itask(i)
6861         if (iproc.gt.0) then
6862           do j=1,num_cont_hb(ii)
6863             jjc=jcont_hb(j,ii)
6864 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6865             if (jjc.eq.jj) then
6866               ncont_sent(iproc)=ncont_sent(iproc)+1
6867               nn=ncont_sent(iproc)
6868               zapas(1,nn,iproc)=ii
6869               zapas(2,nn,iproc)=jjc
6870               zapas(3,nn,iproc)=d_cont(j,ii)
6871               ind=3
6872               do kk=1,3
6873                 ind=ind+1
6874                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6875               enddo
6876               do kk=1,2
6877                 do ll=1,2
6878                   ind=ind+1
6879                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6880                 enddo
6881               enddo
6882               do jj=1,5
6883                 do kk=1,3
6884                   do ll=1,2
6885                     do mm=1,2
6886                       ind=ind+1
6887                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6888                     enddo
6889                   enddo
6890                 enddo
6891               enddo
6892               exit
6893             endif
6894           enddo
6895         endif
6896       enddo
6897       return
6898       end
6899 c------------------------------------------------------------------------------
6900       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6901       implicit real*8 (a-h,o-z)
6902       include 'DIMENSIONS'
6903       include 'COMMON.IOUNITS'
6904       include 'COMMON.DERIV'
6905       include 'COMMON.INTERACT'
6906       include 'COMMON.CONTACTS'
6907       double precision gx(3),gx1(3)
6908       logical lprn
6909       lprn=.false.
6910       eij=facont_hb(jj,i)
6911       ekl=facont_hb(kk,k)
6912       ees0pij=ees0p(jj,i)
6913       ees0pkl=ees0p(kk,k)
6914       ees0mij=ees0m(jj,i)
6915       ees0mkl=ees0m(kk,k)
6916       ekont=eij*ekl
6917       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6918 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6919 C Following 4 lines for diagnostics.
6920 cd    ees0pkl=0.0D0
6921 cd    ees0pij=1.0D0
6922 cd    ees0mkl=0.0D0
6923 cd    ees0mij=1.0D0
6924 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6925 c     & 'Contacts ',i,j,
6926 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6927 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6928 c     & 'gradcorr_long'
6929 C Calculate the multi-body contribution to energy.
6930 c      ecorr=ecorr+ekont*ees
6931 C Calculate multi-body contributions to the gradient.
6932       coeffpees0pij=coeffp*ees0pij
6933       coeffmees0mij=coeffm*ees0mij
6934       coeffpees0pkl=coeffp*ees0pkl
6935       coeffmees0mkl=coeffm*ees0mkl
6936       do ll=1,3
6937 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6938         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6939      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6940      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6941         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6942      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6943      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6944 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6945         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6946      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6947      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6948         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6949      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6950      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6951         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6952      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6953      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6954         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6955         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6956         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6957      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6958      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6959         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6960         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6961 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6962       enddo
6963 c      write (iout,*)
6964 cgrad      do m=i+1,j-1
6965 cgrad        do ll=1,3
6966 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6967 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6968 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6969 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6970 cgrad        enddo
6971 cgrad      enddo
6972 cgrad      do m=k+1,l-1
6973 cgrad        do ll=1,3
6974 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6975 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6976 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6977 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6978 cgrad        enddo
6979 cgrad      enddo
6980 c      write (iout,*) "ehbcorr",ekont*ees
6981       ehbcorr=ekont*ees
6982       return
6983       end
6984 #ifdef MOMENT
6985 C---------------------------------------------------------------------------
6986       subroutine dipole(i,j,jj)
6987       implicit real*8 (a-h,o-z)
6988       include 'DIMENSIONS'
6989       include 'COMMON.IOUNITS'
6990       include 'COMMON.CHAIN'
6991       include 'COMMON.FFIELD'
6992       include 'COMMON.DERIV'
6993       include 'COMMON.INTERACT'
6994       include 'COMMON.CONTACTS'
6995       include 'COMMON.TORSION'
6996       include 'COMMON.VAR'
6997       include 'COMMON.GEO'
6998       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6999      &  auxmat(2,2)
7000       iti1 = itortyp(itype(i+1))
7001       if (j.lt.nres-1) then
7002         itj1 = itortyp(itype(j+1))
7003       else
7004         itj1=ntortyp+1
7005       endif
7006       do iii=1,2
7007         dipi(iii,1)=Ub2(iii,i)
7008         dipderi(iii)=Ub2der(iii,i)
7009         dipi(iii,2)=b1(iii,iti1)
7010         dipj(iii,1)=Ub2(iii,j)
7011         dipderj(iii)=Ub2der(iii,j)
7012         dipj(iii,2)=b1(iii,itj1)
7013       enddo
7014       kkk=0
7015       do iii=1,2
7016         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7017         do jjj=1,2
7018           kkk=kkk+1
7019           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7020         enddo
7021       enddo
7022       do kkk=1,5
7023         do lll=1,3
7024           mmm=0
7025           do iii=1,2
7026             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7027      &        auxvec(1))
7028             do jjj=1,2
7029               mmm=mmm+1
7030               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7031             enddo
7032           enddo
7033         enddo
7034       enddo
7035       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7036       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7037       do iii=1,2
7038         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7039       enddo
7040       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7041       do iii=1,2
7042         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7043       enddo
7044       return
7045       end
7046 #endif
7047 C---------------------------------------------------------------------------
7048       subroutine calc_eello(i,j,k,l,jj,kk)
7049 C
7050 C This subroutine computes matrices and vectors needed to calculate
7051 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7052 C
7053       implicit real*8 (a-h,o-z)
7054       include 'DIMENSIONS'
7055       include 'COMMON.IOUNITS'
7056       include 'COMMON.CHAIN'
7057       include 'COMMON.DERIV'
7058       include 'COMMON.INTERACT'
7059       include 'COMMON.CONTACTS'
7060       include 'COMMON.TORSION'
7061       include 'COMMON.VAR'
7062       include 'COMMON.GEO'
7063       include 'COMMON.FFIELD'
7064       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7065      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7066       logical lprn
7067       common /kutas/ lprn
7068 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7069 cd     & ' jj=',jj,' kk=',kk
7070 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7071 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7072 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7073       do iii=1,2
7074         do jjj=1,2
7075           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7076           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7077         enddo
7078       enddo
7079       call transpose2(aa1(1,1),aa1t(1,1))
7080       call transpose2(aa2(1,1),aa2t(1,1))
7081       do kkk=1,5
7082         do lll=1,3
7083           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7084      &      aa1tder(1,1,lll,kkk))
7085           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7086      &      aa2tder(1,1,lll,kkk))
7087         enddo
7088       enddo
7089       if (l.eq.j+1) then
7090 C parallel orientation of the two CA-CA-CA frames.
7091         if (i.gt.1) then
7092           iti=itortyp(itype(i))
7093         else
7094           iti=ntortyp+1
7095         endif
7096         itk1=itortyp(itype(k+1))
7097         itj=itortyp(itype(j))
7098         if (l.lt.nres-1) then
7099           itl1=itortyp(itype(l+1))
7100         else
7101           itl1=ntortyp+1
7102         endif
7103 C A1 kernel(j+1) A2T
7104 cd        do iii=1,2
7105 cd          write (iout,'(3f10.5,5x,3f10.5)')
7106 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7107 cd        enddo
7108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7109      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7110      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7111 C Following matrices are needed only for 6-th order cumulants
7112         IF (wcorr6.gt.0.0d0) THEN
7113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7114      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7115      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7116         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7117      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7118      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7119      &   ADtEAderx(1,1,1,1,1,1))
7120         lprn=.false.
7121         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7122      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7123      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7124      &   ADtEA1derx(1,1,1,1,1,1))
7125         ENDIF
7126 C End 6-th order cumulants
7127 cd        lprn=.false.
7128 cd        if (lprn) then
7129 cd        write (2,*) 'In calc_eello6'
7130 cd        do iii=1,2
7131 cd          write (2,*) 'iii=',iii
7132 cd          do kkk=1,5
7133 cd            write (2,*) 'kkk=',kkk
7134 cd            do jjj=1,2
7135 cd              write (2,'(3(2f10.5),5x)')
7136 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7137 cd            enddo
7138 cd          enddo
7139 cd        enddo
7140 cd        endif
7141         call transpose2(EUgder(1,1,k),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7143         call transpose2(EUg(1,1,k),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7150      &          EAEAderx(1,1,lll,kkk,iii,1))
7151             enddo
7152           enddo
7153         enddo
7154 C A1T kernel(i+1) A2
7155         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7156      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7157      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7158 C Following matrices are needed only for 6-th order cumulants
7159         IF (wcorr6.gt.0.0d0) THEN
7160         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7161      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7162      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7163         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7164      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7165      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7166      &   ADtEAderx(1,1,1,1,1,2))
7167         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7168      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7169      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7170      &   ADtEA1derx(1,1,1,1,1,2))
7171         ENDIF
7172 C End 6-th order cumulants
7173         call transpose2(EUgder(1,1,l),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7175         call transpose2(EUg(1,1,l),auxmat(1,1))
7176         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7177         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7178         do iii=1,2
7179           do kkk=1,5
7180             do lll=1,3
7181               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7182      &          EAEAderx(1,1,lll,kkk,iii,2))
7183             enddo
7184           enddo
7185         enddo
7186 C AEAb1 and AEAb2
7187 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7188 C They are needed only when the fifth- or the sixth-order cumulants are
7189 C indluded.
7190         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7191         call transpose2(AEA(1,1,1),auxmat(1,1))
7192         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7193         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7194         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7195         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7196         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7197         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7198         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7199         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7200         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7201         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7202         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7203         call transpose2(AEA(1,1,2),auxmat(1,1))
7204         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7205         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7206         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7207         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7208         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7209         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7210         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7211         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7212         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7213         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7214         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7215 C Calculate the Cartesian derivatives of the vectors.
7216         do iii=1,2
7217           do kkk=1,5
7218             do lll=1,3
7219               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7220               call matvec2(auxmat(1,1),b1(1,iti),
7221      &          AEAb1derx(1,lll,kkk,iii,1,1))
7222               call matvec2(auxmat(1,1),Ub2(1,i),
7223      &          AEAb2derx(1,lll,kkk,iii,1,1))
7224               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7225      &          AEAb1derx(1,lll,kkk,iii,2,1))
7226               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7227      &          AEAb2derx(1,lll,kkk,iii,2,1))
7228               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7229               call matvec2(auxmat(1,1),b1(1,itj),
7230      &          AEAb1derx(1,lll,kkk,iii,1,2))
7231               call matvec2(auxmat(1,1),Ub2(1,j),
7232      &          AEAb2derx(1,lll,kkk,iii,1,2))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7234      &          AEAb1derx(1,lll,kkk,iii,2,2))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7236      &          AEAb2derx(1,lll,kkk,iii,2,2))
7237             enddo
7238           enddo
7239         enddo
7240         ENDIF
7241 C End vectors
7242       else
7243 C Antiparallel orientation of the two CA-CA-CA frames.
7244         if (i.gt.1) then
7245           iti=itortyp(itype(i))
7246         else
7247           iti=ntortyp+1
7248         endif
7249         itk1=itortyp(itype(k+1))
7250         itl=itortyp(itype(l))
7251         itj=itortyp(itype(j))
7252         if (j.lt.nres-1) then
7253           itj1=itortyp(itype(j+1))
7254         else
7255           itj1=ntortyp+1
7256         endif
7257 C A2 kernel(j-1)T A1T
7258         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7259      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7260      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7261 C Following matrices are needed only for 6-th order cumulants
7262         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7263      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7264         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7265      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7266      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7267         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7268      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7269      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7270      &   ADtEAderx(1,1,1,1,1,1))
7271         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7272      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7273      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7274      &   ADtEA1derx(1,1,1,1,1,1))
7275         ENDIF
7276 C End 6-th order cumulants
7277         call transpose2(EUgder(1,1,k),auxmat(1,1))
7278         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7279         call transpose2(EUg(1,1,k),auxmat(1,1))
7280         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7281         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7282         do iii=1,2
7283           do kkk=1,5
7284             do lll=1,3
7285               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7286      &          EAEAderx(1,1,lll,kkk,iii,1))
7287             enddo
7288           enddo
7289         enddo
7290 C A2T kernel(i+1)T A1
7291         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7292      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7293      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7294 C Following matrices are needed only for 6-th order cumulants
7295         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7296      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7297         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7298      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7299      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7300         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7301      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7302      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7303      &   ADtEAderx(1,1,1,1,1,2))
7304         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7305      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7306      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7307      &   ADtEA1derx(1,1,1,1,1,2))
7308         ENDIF
7309 C End 6-th order cumulants
7310         call transpose2(EUgder(1,1,j),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7312         call transpose2(EUg(1,1,j),auxmat(1,1))
7313         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7314         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7315         do iii=1,2
7316           do kkk=1,5
7317             do lll=1,3
7318               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7319      &          EAEAderx(1,1,lll,kkk,iii,2))
7320             enddo
7321           enddo
7322         enddo
7323 C AEAb1 and AEAb2
7324 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7325 C They are needed only when the fifth- or the sixth-order cumulants are
7326 C indluded.
7327         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7328      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7329         call transpose2(AEA(1,1,1),auxmat(1,1))
7330         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7331         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7332         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7333         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7334         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7335         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7336         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7337         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7339         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7340         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7341         call transpose2(AEA(1,1,2),auxmat(1,1))
7342         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7343         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7344         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7345         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7346         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7347         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7348         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7349         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7351         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7352         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7353 C Calculate the Cartesian derivatives of the vectors.
7354         do iii=1,2
7355           do kkk=1,5
7356             do lll=1,3
7357               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7358               call matvec2(auxmat(1,1),b1(1,iti),
7359      &          AEAb1derx(1,lll,kkk,iii,1,1))
7360               call matvec2(auxmat(1,1),Ub2(1,i),
7361      &          AEAb2derx(1,lll,kkk,iii,1,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7363      &          AEAb1derx(1,lll,kkk,iii,2,1))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7365      &          AEAb2derx(1,lll,kkk,iii,2,1))
7366               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7367               call matvec2(auxmat(1,1),b1(1,itl),
7368      &          AEAb1derx(1,lll,kkk,iii,1,2))
7369               call matvec2(auxmat(1,1),Ub2(1,l),
7370      &          AEAb2derx(1,lll,kkk,iii,1,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7372      &          AEAb1derx(1,lll,kkk,iii,2,2))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7374      &          AEAb2derx(1,lll,kkk,iii,2,2))
7375             enddo
7376           enddo
7377         enddo
7378         ENDIF
7379 C End vectors
7380       endif
7381       return
7382       end
7383 C---------------------------------------------------------------------------
7384       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7385      &  KK,KKderg,AKA,AKAderg,AKAderx)
7386       implicit none
7387       integer nderg
7388       logical transp
7389       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7390      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7391      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7392       integer iii,kkk,lll
7393       integer jjj,mmm
7394       logical lprn
7395       common /kutas/ lprn
7396       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7397       do iii=1,nderg
7398         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7399      &    AKAderg(1,1,iii))
7400       enddo
7401 cd      if (lprn) write (2,*) 'In kernel'
7402       do kkk=1,5
7403 cd        if (lprn) write (2,*) 'kkk=',kkk
7404         do lll=1,3
7405           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7406      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7407 cd          if (lprn) then
7408 cd            write (2,*) 'lll=',lll
7409 cd            write (2,*) 'iii=1'
7410 cd            do jjj=1,2
7411 cd              write (2,'(3(2f10.5),5x)')
7412 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7413 cd            enddo
7414 cd          endif
7415           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7416      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7417 cd          if (lprn) then
7418 cd            write (2,*) 'lll=',lll
7419 cd            write (2,*) 'iii=2'
7420 cd            do jjj=1,2
7421 cd              write (2,'(3(2f10.5),5x)')
7422 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7423 cd            enddo
7424 cd          endif
7425         enddo
7426       enddo
7427       return
7428       end
7429 C---------------------------------------------------------------------------
7430       double precision function eello4(i,j,k,l,jj,kk)
7431       implicit real*8 (a-h,o-z)
7432       include 'DIMENSIONS'
7433       include 'COMMON.IOUNITS'
7434       include 'COMMON.CHAIN'
7435       include 'COMMON.DERIV'
7436       include 'COMMON.INTERACT'
7437       include 'COMMON.CONTACTS'
7438       include 'COMMON.TORSION'
7439       include 'COMMON.VAR'
7440       include 'COMMON.GEO'
7441       double precision pizda(2,2),ggg1(3),ggg2(3)
7442 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7443 cd        eello4=0.0d0
7444 cd        return
7445 cd      endif
7446 cd      print *,'eello4:',i,j,k,l,jj,kk
7447 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7448 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7449 cold      eij=facont_hb(jj,i)
7450 cold      ekl=facont_hb(kk,k)
7451 cold      ekont=eij*ekl
7452       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7453 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7454       gcorr_loc(k-1)=gcorr_loc(k-1)
7455      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7456       if (l.eq.j+1) then
7457         gcorr_loc(l-1)=gcorr_loc(l-1)
7458      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7459       else
7460         gcorr_loc(j-1)=gcorr_loc(j-1)
7461      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7462       endif
7463       do iii=1,2
7464         do kkk=1,5
7465           do lll=1,3
7466             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7467      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7468 cd            derx(lll,kkk,iii)=0.0d0
7469           enddo
7470         enddo
7471       enddo
7472 cd      gcorr_loc(l-1)=0.0d0
7473 cd      gcorr_loc(j-1)=0.0d0
7474 cd      gcorr_loc(k-1)=0.0d0
7475 cd      eel4=1.0d0
7476 cd      write (iout,*)'Contacts have occurred for peptide groups',
7477 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7478 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7479       if (j.lt.nres-1) then
7480         j1=j+1
7481         j2=j-1
7482       else
7483         j1=j-1
7484         j2=j-2
7485       endif
7486       if (l.lt.nres-1) then
7487         l1=l+1
7488         l2=l-1
7489       else
7490         l1=l-1
7491         l2=l-2
7492       endif
7493       do ll=1,3
7494 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7495 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7496         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7497         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7498 cgrad        ghalf=0.5d0*ggg1(ll)
7499         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7500         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7501         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7502         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7503         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7504         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7505 cgrad        ghalf=0.5d0*ggg2(ll)
7506         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7507         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7508         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7509         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7510         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7511         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7512       enddo
7513 cgrad      do m=i+1,j-1
7514 cgrad        do ll=1,3
7515 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7516 cgrad        enddo
7517 cgrad      enddo
7518 cgrad      do m=k+1,l-1
7519 cgrad        do ll=1,3
7520 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7521 cgrad        enddo
7522 cgrad      enddo
7523 cgrad      do m=i+2,j2
7524 cgrad        do ll=1,3
7525 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7526 cgrad        enddo
7527 cgrad      enddo
7528 cgrad      do m=k+2,l2
7529 cgrad        do ll=1,3
7530 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7531 cgrad        enddo
7532 cgrad      enddo
7533 cd      do iii=1,nres-3
7534 cd        write (2,*) iii,gcorr_loc(iii)
7535 cd      enddo
7536       eello4=ekont*eel4
7537 cd      write (2,*) 'ekont',ekont
7538 cd      write (iout,*) 'eello4',ekont*eel4
7539       return
7540       end
7541 C---------------------------------------------------------------------------
7542       double precision function eello5(i,j,k,l,jj,kk)
7543       implicit real*8 (a-h,o-z)
7544       include 'DIMENSIONS'
7545       include 'COMMON.IOUNITS'
7546       include 'COMMON.CHAIN'
7547       include 'COMMON.DERIV'
7548       include 'COMMON.INTERACT'
7549       include 'COMMON.CONTACTS'
7550       include 'COMMON.TORSION'
7551       include 'COMMON.VAR'
7552       include 'COMMON.GEO'
7553       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7554       double precision ggg1(3),ggg2(3)
7555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7556 C                                                                              C
7557 C                            Parallel chains                                   C
7558 C                                                                              C
7559 C          o             o                   o             o                   C
7560 C         /l\           / \             \   / \           / \   /              C
7561 C        /   \         /   \             \ /   \         /   \ /               C
7562 C       j| o |l1       | o |              o| o |         | o |o                C
7563 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7564 C      \i/   \         /   \ /             /   \         /   \                 C
7565 C       o    k1             o                                                  C
7566 C         (I)          (II)                (III)          (IV)                 C
7567 C                                                                              C
7568 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7569 C                                                                              C
7570 C                            Antiparallel chains                               C
7571 C                                                                              C
7572 C          o             o                   o             o                   C
7573 C         /j\           / \             \   / \           / \   /              C
7574 C        /   \         /   \             \ /   \         /   \ /               C
7575 C      j1| o |l        | o |              o| o |         | o |o                C
7576 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7577 C      \i/   \         /   \ /             /   \         /   \                 C
7578 C       o     k1            o                                                  C
7579 C         (I)          (II)                (III)          (IV)                 C
7580 C                                                                              C
7581 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7582 C                                                                              C
7583 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7584 C                                                                              C
7585 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7586 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7587 cd        eello5=0.0d0
7588 cd        return
7589 cd      endif
7590 cd      write (iout,*)
7591 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7592 cd     &   ' and',k,l
7593       itk=itortyp(itype(k))
7594       itl=itortyp(itype(l))
7595       itj=itortyp(itype(j))
7596       eello5_1=0.0d0
7597       eello5_2=0.0d0
7598       eello5_3=0.0d0
7599       eello5_4=0.0d0
7600 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7601 cd     &   eel5_3_num,eel5_4_num)
7602       do iii=1,2
7603         do kkk=1,5
7604           do lll=1,3
7605             derx(lll,kkk,iii)=0.0d0
7606           enddo
7607         enddo
7608       enddo
7609 cd      eij=facont_hb(jj,i)
7610 cd      ekl=facont_hb(kk,k)
7611 cd      ekont=eij*ekl
7612 cd      write (iout,*)'Contacts have occurred for peptide groups',
7613 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7614 cd      goto 1111
7615 C Contribution from the graph I.
7616 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7617 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7618       call transpose2(EUg(1,1,k),auxmat(1,1))
7619       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7620       vv(1)=pizda(1,1)-pizda(2,2)
7621       vv(2)=pizda(1,2)+pizda(2,1)
7622       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7623      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7624 C Explicit gradient in virtual-dihedral angles.
7625       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7626      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7627      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7628       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7629       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7630       vv(1)=pizda(1,1)-pizda(2,2)
7631       vv(2)=pizda(1,2)+pizda(2,1)
7632       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7633      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7634      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7635       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7636       vv(1)=pizda(1,1)-pizda(2,2)
7637       vv(2)=pizda(1,2)+pizda(2,1)
7638       if (l.eq.j+1) then
7639         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7640      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7641      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7642       else
7643         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7644      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7645      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7646       endif
7647 C Cartesian gradient
7648       do iii=1,2
7649         do kkk=1,5
7650           do lll=1,3
7651             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7652      &        pizda(1,1))
7653             vv(1)=pizda(1,1)-pizda(2,2)
7654             vv(2)=pizda(1,2)+pizda(2,1)
7655             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7656      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7657      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7658           enddo
7659         enddo
7660       enddo
7661 c      goto 1112
7662 c1111  continue
7663 C Contribution from graph II
7664       call transpose2(EE(1,1,itk),auxmat(1,1))
7665       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)+pizda(2,2)
7667       vv(2)=pizda(2,1)-pizda(1,2)
7668       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7669      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7670 C Explicit gradient in virtual-dihedral angles.
7671       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7672      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7673       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7674       vv(1)=pizda(1,1)+pizda(2,2)
7675       vv(2)=pizda(2,1)-pizda(1,2)
7676       if (l.eq.j+1) then
7677         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7678      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7679      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7680       else
7681         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7682      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7683      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7684       endif
7685 C Cartesian gradient
7686       do iii=1,2
7687         do kkk=1,5
7688           do lll=1,3
7689             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7690      &        pizda(1,1))
7691             vv(1)=pizda(1,1)+pizda(2,2)
7692             vv(2)=pizda(2,1)-pizda(1,2)
7693             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7694      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7695      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7696           enddo
7697         enddo
7698       enddo
7699 cd      goto 1112
7700 cd1111  continue
7701       if (l.eq.j+1) then
7702 cd        goto 1110
7703 C Parallel orientation
7704 C Contribution from graph III
7705         call transpose2(EUg(1,1,l),auxmat(1,1))
7706         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7707         vv(1)=pizda(1,1)-pizda(2,2)
7708         vv(2)=pizda(1,2)+pizda(2,1)
7709         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7710      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7711 C Explicit gradient in virtual-dihedral angles.
7712         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7713      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7715         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7716         vv(1)=pizda(1,1)-pizda(2,2)
7717         vv(2)=pizda(1,2)+pizda(2,1)
7718         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7721         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7722         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7723         vv(1)=pizda(1,1)-pizda(2,2)
7724         vv(2)=pizda(1,2)+pizda(2,1)
7725         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7726      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7727      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7728 C Cartesian gradient
7729         do iii=1,2
7730           do kkk=1,5
7731             do lll=1,3
7732               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7733      &          pizda(1,1))
7734               vv(1)=pizda(1,1)-pizda(2,2)
7735               vv(2)=pizda(1,2)+pizda(2,1)
7736               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7737      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7738      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7739             enddo
7740           enddo
7741         enddo
7742 cd        goto 1112
7743 C Contribution from graph IV
7744 cd1110    continue
7745         call transpose2(EE(1,1,itl),auxmat(1,1))
7746         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7747         vv(1)=pizda(1,1)+pizda(2,2)
7748         vv(2)=pizda(2,1)-pizda(1,2)
7749         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7750      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7751 C Explicit gradient in virtual-dihedral angles.
7752         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7753      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7754         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7755         vv(1)=pizda(1,1)+pizda(2,2)
7756         vv(2)=pizda(2,1)-pizda(1,2)
7757         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7758      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7759      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7760 C Cartesian gradient
7761         do iii=1,2
7762           do kkk=1,5
7763             do lll=1,3
7764               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7765      &          pizda(1,1))
7766               vv(1)=pizda(1,1)+pizda(2,2)
7767               vv(2)=pizda(2,1)-pizda(1,2)
7768               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7769      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7770      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7771             enddo
7772           enddo
7773         enddo
7774       else
7775 C Antiparallel orientation
7776 C Contribution from graph III
7777 c        goto 1110
7778         call transpose2(EUg(1,1,j),auxmat(1,1))
7779         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7780         vv(1)=pizda(1,1)-pizda(2,2)
7781         vv(2)=pizda(1,2)+pizda(2,1)
7782         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7783      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7784 C Explicit gradient in virtual-dihedral angles.
7785         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7786      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7787      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7788         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7789         vv(1)=pizda(1,1)-pizda(2,2)
7790         vv(2)=pizda(1,2)+pizda(2,1)
7791         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7792      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7794         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7795         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7796         vv(1)=pizda(1,1)-pizda(2,2)
7797         vv(2)=pizda(1,2)+pizda(2,1)
7798         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7799      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7800      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7801 C Cartesian gradient
7802         do iii=1,2
7803           do kkk=1,5
7804             do lll=1,3
7805               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7806      &          pizda(1,1))
7807               vv(1)=pizda(1,1)-pizda(2,2)
7808               vv(2)=pizda(1,2)+pizda(2,1)
7809               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7810      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7811      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7812             enddo
7813           enddo
7814         enddo
7815 cd        goto 1112
7816 C Contribution from graph IV
7817 1110    continue
7818         call transpose2(EE(1,1,itj),auxmat(1,1))
7819         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7820         vv(1)=pizda(1,1)+pizda(2,2)
7821         vv(2)=pizda(2,1)-pizda(1,2)
7822         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7823      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7824 C Explicit gradient in virtual-dihedral angles.
7825         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7826      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7827         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7828         vv(1)=pizda(1,1)+pizda(2,2)
7829         vv(2)=pizda(2,1)-pizda(1,2)
7830         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7831      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7832      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7833 C Cartesian gradient
7834         do iii=1,2
7835           do kkk=1,5
7836             do lll=1,3
7837               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7838      &          pizda(1,1))
7839               vv(1)=pizda(1,1)+pizda(2,2)
7840               vv(2)=pizda(2,1)-pizda(1,2)
7841               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7842      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7843      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7844             enddo
7845           enddo
7846         enddo
7847       endif
7848 1112  continue
7849       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7850 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7851 cd        write (2,*) 'ijkl',i,j,k,l
7852 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7853 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7854 cd      endif
7855 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7856 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7857 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7858 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7859       if (j.lt.nres-1) then
7860         j1=j+1
7861         j2=j-1
7862       else
7863         j1=j-1
7864         j2=j-2
7865       endif
7866       if (l.lt.nres-1) then
7867         l1=l+1
7868         l2=l-1
7869       else
7870         l1=l-1
7871         l2=l-2
7872       endif
7873 cd      eij=1.0d0
7874 cd      ekl=1.0d0
7875 cd      ekont=1.0d0
7876 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7877 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7878 C        summed up outside the subrouine as for the other subroutines
7879 C        handling long-range interactions. The old code is commented out
7880 C        with "cgrad" to keep track of changes.
7881       do ll=1,3
7882 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7883 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7884         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7885         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7886 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7887 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7888 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7889 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7890 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7891 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7892 c     &   gradcorr5ij,
7893 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7894 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7895 cgrad        ghalf=0.5d0*ggg1(ll)
7896 cd        ghalf=0.0d0
7897         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7898         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7899         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7900         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7901         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7902         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7903 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7904 cgrad        ghalf=0.5d0*ggg2(ll)
7905 cd        ghalf=0.0d0
7906         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7907         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7908         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7909         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7910         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7911         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7912       enddo
7913 cd      goto 1112
7914 cgrad      do m=i+1,j-1
7915 cgrad        do ll=1,3
7916 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7917 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7918 cgrad        enddo
7919 cgrad      enddo
7920 cgrad      do m=k+1,l-1
7921 cgrad        do ll=1,3
7922 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7923 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7924 cgrad        enddo
7925 cgrad      enddo
7926 c1112  continue
7927 cgrad      do m=i+2,j2
7928 cgrad        do ll=1,3
7929 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7930 cgrad        enddo
7931 cgrad      enddo
7932 cgrad      do m=k+2,l2
7933 cgrad        do ll=1,3
7934 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7935 cgrad        enddo
7936 cgrad      enddo
7937 cd      do iii=1,nres-3
7938 cd        write (2,*) iii,g_corr5_loc(iii)
7939 cd      enddo
7940       eello5=ekont*eel5
7941 cd      write (2,*) 'ekont',ekont
7942 cd      write (iout,*) 'eello5',ekont*eel5
7943       return
7944       end
7945 c--------------------------------------------------------------------------
7946       double precision function eello6(i,j,k,l,jj,kk)
7947       implicit real*8 (a-h,o-z)
7948       include 'DIMENSIONS'
7949       include 'COMMON.IOUNITS'
7950       include 'COMMON.CHAIN'
7951       include 'COMMON.DERIV'
7952       include 'COMMON.INTERACT'
7953       include 'COMMON.CONTACTS'
7954       include 'COMMON.TORSION'
7955       include 'COMMON.VAR'
7956       include 'COMMON.GEO'
7957       include 'COMMON.FFIELD'
7958       double precision ggg1(3),ggg2(3)
7959 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7960 cd        eello6=0.0d0
7961 cd        return
7962 cd      endif
7963 cd      write (iout,*)
7964 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7965 cd     &   ' and',k,l
7966       eello6_1=0.0d0
7967       eello6_2=0.0d0
7968       eello6_3=0.0d0
7969       eello6_4=0.0d0
7970       eello6_5=0.0d0
7971       eello6_6=0.0d0
7972 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7973 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7974       do iii=1,2
7975         do kkk=1,5
7976           do lll=1,3
7977             derx(lll,kkk,iii)=0.0d0
7978           enddo
7979         enddo
7980       enddo
7981 cd      eij=facont_hb(jj,i)
7982 cd      ekl=facont_hb(kk,k)
7983 cd      ekont=eij*ekl
7984 cd      eij=1.0d0
7985 cd      ekl=1.0d0
7986 cd      ekont=1.0d0
7987       if (l.eq.j+1) then
7988         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7989         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7990         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7991         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7992         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7993         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7994       else
7995         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7996         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7997         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7998         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7999         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8000           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8001         else
8002           eello6_5=0.0d0
8003         endif
8004         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8005       endif
8006 C If turn contributions are considered, they will be handled separately.
8007       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8008 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8009 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8010 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8011 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8012 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8013 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8014 cd      goto 1112
8015       if (j.lt.nres-1) then
8016         j1=j+1
8017         j2=j-1
8018       else
8019         j1=j-1
8020         j2=j-2
8021       endif
8022       if (l.lt.nres-1) then
8023         l1=l+1
8024         l2=l-1
8025       else
8026         l1=l-1
8027         l2=l-2
8028       endif
8029       do ll=1,3
8030 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8031 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8032 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8033 cgrad        ghalf=0.5d0*ggg1(ll)
8034 cd        ghalf=0.0d0
8035         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8036         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8037         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8038         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8039         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8040         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8041         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8042         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8043 cgrad        ghalf=0.5d0*ggg2(ll)
8044 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8045 cd        ghalf=0.0d0
8046         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8047         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8048         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8049         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8050         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8051         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8052       enddo
8053 cd      goto 1112
8054 cgrad      do m=i+1,j-1
8055 cgrad        do ll=1,3
8056 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8057 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8058 cgrad        enddo
8059 cgrad      enddo
8060 cgrad      do m=k+1,l-1
8061 cgrad        do ll=1,3
8062 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8063 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8064 cgrad        enddo
8065 cgrad      enddo
8066 cgrad1112  continue
8067 cgrad      do m=i+2,j2
8068 cgrad        do ll=1,3
8069 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8070 cgrad        enddo
8071 cgrad      enddo
8072 cgrad      do m=k+2,l2
8073 cgrad        do ll=1,3
8074 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8075 cgrad        enddo
8076 cgrad      enddo
8077 cd      do iii=1,nres-3
8078 cd        write (2,*) iii,g_corr6_loc(iii)
8079 cd      enddo
8080       eello6=ekont*eel6
8081 cd      write (2,*) 'ekont',ekont
8082 cd      write (iout,*) 'eello6',ekont*eel6
8083       return
8084       end
8085 c--------------------------------------------------------------------------
8086       double precision function eello6_graph1(i,j,k,l,imat,swap)
8087       implicit real*8 (a-h,o-z)
8088       include 'DIMENSIONS'
8089       include 'COMMON.IOUNITS'
8090       include 'COMMON.CHAIN'
8091       include 'COMMON.DERIV'
8092       include 'COMMON.INTERACT'
8093       include 'COMMON.CONTACTS'
8094       include 'COMMON.TORSION'
8095       include 'COMMON.VAR'
8096       include 'COMMON.GEO'
8097       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8098       logical swap
8099       logical lprn
8100       common /kutas/ lprn
8101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8102 C
8103 C      Parallel       Antiparallel
8104 C
8105 C          o             o
8106 C         /l\           /j\
8107 C        /   \         /   \
8108 C       /| o |         | o |\
8109 C     \ j|/k\|  /   \  |/k\|l /
8110 C      \ /   \ /     \ /   \ /
8111 C       o     o       o     o
8112 C       i             i
8113 C
8114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8115       itk=itortyp(itype(k))
8116       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8117       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8118       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8119       call transpose2(EUgC(1,1,k),auxmat(1,1))
8120       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8121       vv1(1)=pizda1(1,1)-pizda1(2,2)
8122       vv1(2)=pizda1(1,2)+pizda1(2,1)
8123       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8124       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8125       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8126       s5=scalar2(vv(1),Dtobr2(1,i))
8127 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8128       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8129       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8130      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8131      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8132      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8133      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8134      & +scalar2(vv(1),Dtobr2der(1,i)))
8135       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8136       vv1(1)=pizda1(1,1)-pizda1(2,2)
8137       vv1(2)=pizda1(1,2)+pizda1(2,1)
8138       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8139       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8140       if (l.eq.j+1) then
8141         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8142      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8143      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8144      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8145      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8146       else
8147         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8148      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8149      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8150      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8151      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8152       endif
8153       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8154       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8155       vv1(1)=pizda1(1,1)-pizda1(2,2)
8156       vv1(2)=pizda1(1,2)+pizda1(2,1)
8157       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8158      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8159      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8160      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8161       do iii=1,2
8162         if (swap) then
8163           ind=3-iii
8164         else
8165           ind=iii
8166         endif
8167         do kkk=1,5
8168           do lll=1,3
8169             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8170             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8171             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8172             call transpose2(EUgC(1,1,k),auxmat(1,1))
8173             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8174      &        pizda1(1,1))
8175             vv1(1)=pizda1(1,1)-pizda1(2,2)
8176             vv1(2)=pizda1(1,2)+pizda1(2,1)
8177             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8178             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8179      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8180             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8181      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8182             s5=scalar2(vv(1),Dtobr2(1,i))
8183             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8184           enddo
8185         enddo
8186       enddo
8187       return
8188       end
8189 c----------------------------------------------------------------------------
8190       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8191       implicit real*8 (a-h,o-z)
8192       include 'DIMENSIONS'
8193       include 'COMMON.IOUNITS'
8194       include 'COMMON.CHAIN'
8195       include 'COMMON.DERIV'
8196       include 'COMMON.INTERACT'
8197       include 'COMMON.CONTACTS'
8198       include 'COMMON.TORSION'
8199       include 'COMMON.VAR'
8200       include 'COMMON.GEO'
8201       logical swap
8202       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8203      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8204       logical lprn
8205       common /kutas/ lprn
8206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8207 C                                                                              C
8208 C      Parallel       Antiparallel                                             C
8209 C                                                                              C
8210 C          o             o                                                     C
8211 C     \   /l\           /j\   /                                                C
8212 C      \ /   \         /   \ /                                                 C
8213 C       o| o |         | o |o                                                  C
8214 C     \ j|/k\|      \  |/k\|l                                                  C
8215 C      \ /   \       \ /   \                                                   C
8216 C       o             o                                                        C
8217 C       i             i                                                        C
8218 C                                                                              C
8219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8220 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8221 C AL 7/4/01 s1 would occur in the sixth-order moment,
8222 C           but not in a cluster cumulant
8223 #ifdef MOMENT
8224       s1=dip(1,jj,i)*dip(1,kk,k)
8225 #endif
8226       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8227       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8228       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8229       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8230       call transpose2(EUg(1,1,k),auxmat(1,1))
8231       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8232       vv(1)=pizda(1,1)-pizda(2,2)
8233       vv(2)=pizda(1,2)+pizda(2,1)
8234       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8235 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8236 #ifdef MOMENT
8237       eello6_graph2=-(s1+s2+s3+s4)
8238 #else
8239       eello6_graph2=-(s2+s3+s4)
8240 #endif
8241 c      eello6_graph2=-s3
8242 C Derivatives in gamma(i-1)
8243       if (i.gt.1) then
8244 #ifdef MOMENT
8245         s1=dipderg(1,jj,i)*dip(1,kk,k)
8246 #endif
8247         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8248         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8249         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8250         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8251 #ifdef MOMENT
8252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8253 #else
8254         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8255 #endif
8256 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8257       endif
8258 C Derivatives in gamma(k-1)
8259 #ifdef MOMENT
8260       s1=dip(1,jj,i)*dipderg(1,kk,k)
8261 #endif
8262       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8263       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8264       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8265       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8266       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8267       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8268       vv(1)=pizda(1,1)-pizda(2,2)
8269       vv(2)=pizda(1,2)+pizda(2,1)
8270       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8271 #ifdef MOMENT
8272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8273 #else
8274       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8275 #endif
8276 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8277 C Derivatives in gamma(j-1) or gamma(l-1)
8278       if (j.gt.1) then
8279 #ifdef MOMENT
8280         s1=dipderg(3,jj,i)*dip(1,kk,k)
8281 #endif
8282         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8283         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8284         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8285         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8286         vv(1)=pizda(1,1)-pizda(2,2)
8287         vv(2)=pizda(1,2)+pizda(2,1)
8288         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8289 #ifdef MOMENT
8290         if (swap) then
8291           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8292         else
8293           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8294         endif
8295 #endif
8296         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8297 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8298       endif
8299 C Derivatives in gamma(l-1) or gamma(j-1)
8300       if (l.gt.1) then
8301 #ifdef MOMENT
8302         s1=dip(1,jj,i)*dipderg(3,kk,k)
8303 #endif
8304         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8305         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8306         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8307         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8308         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8309         vv(1)=pizda(1,1)-pizda(2,2)
8310         vv(2)=pizda(1,2)+pizda(2,1)
8311         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8312 #ifdef MOMENT
8313         if (swap) then
8314           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8315         else
8316           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8317         endif
8318 #endif
8319         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8320 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8321       endif
8322 C Cartesian derivatives.
8323       if (lprn) then
8324         write (2,*) 'In eello6_graph2'
8325         do iii=1,2
8326           write (2,*) 'iii=',iii
8327           do kkk=1,5
8328             write (2,*) 'kkk=',kkk
8329             do jjj=1,2
8330               write (2,'(3(2f10.5),5x)')
8331      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8332             enddo
8333           enddo
8334         enddo
8335       endif
8336       do iii=1,2
8337         do kkk=1,5
8338           do lll=1,3
8339 #ifdef MOMENT
8340             if (iii.eq.1) then
8341               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8342             else
8343               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8344             endif
8345 #endif
8346             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8347      &        auxvec(1))
8348             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8349             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8350      &        auxvec(1))
8351             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8352             call transpose2(EUg(1,1,k),auxmat(1,1))
8353             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8354      &        pizda(1,1))
8355             vv(1)=pizda(1,1)-pizda(2,2)
8356             vv(2)=pizda(1,2)+pizda(2,1)
8357             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8358 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8359 #ifdef MOMENT
8360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8361 #else
8362             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8363 #endif
8364             if (swap) then
8365               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8366             else
8367               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8368             endif
8369           enddo
8370         enddo
8371       enddo
8372       return
8373       end
8374 c----------------------------------------------------------------------------
8375       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8376       implicit real*8 (a-h,o-z)
8377       include 'DIMENSIONS'
8378       include 'COMMON.IOUNITS'
8379       include 'COMMON.CHAIN'
8380       include 'COMMON.DERIV'
8381       include 'COMMON.INTERACT'
8382       include 'COMMON.CONTACTS'
8383       include 'COMMON.TORSION'
8384       include 'COMMON.VAR'
8385       include 'COMMON.GEO'
8386       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8387       logical swap
8388 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8389 C                                                                              C
8390 C      Parallel       Antiparallel                                             C
8391 C                                                                              C
8392 C          o             o                                                     C
8393 C         /l\   /   \   /j\                                                    C
8394 C        /   \ /     \ /   \                                                   C
8395 C       /| o |o       o| o |\                                                  C
8396 C       j|/k\|  /      |/k\|l /                                                C
8397 C        /   \ /       /   \ /                                                 C
8398 C       /     o       /     o                                                  C
8399 C       i             i                                                        C
8400 C                                                                              C
8401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8402 C
8403 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8404 C           energy moment and not to the cluster cumulant.
8405       iti=itortyp(itype(i))
8406       if (j.lt.nres-1) then
8407         itj1=itortyp(itype(j+1))
8408       else
8409         itj1=ntortyp+1
8410       endif
8411       itk=itortyp(itype(k))
8412       itk1=itortyp(itype(k+1))
8413       if (l.lt.nres-1) then
8414         itl1=itortyp(itype(l+1))
8415       else
8416         itl1=ntortyp+1
8417       endif
8418 #ifdef MOMENT
8419       s1=dip(4,jj,i)*dip(4,kk,k)
8420 #endif
8421       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8422       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8423       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8424       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8425       call transpose2(EE(1,1,itk),auxmat(1,1))
8426       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8427       vv(1)=pizda(1,1)+pizda(2,2)
8428       vv(2)=pizda(2,1)-pizda(1,2)
8429       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8430 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8431 cd     & "sum",-(s2+s3+s4)
8432 #ifdef MOMENT
8433       eello6_graph3=-(s1+s2+s3+s4)
8434 #else
8435       eello6_graph3=-(s2+s3+s4)
8436 #endif
8437 c      eello6_graph3=-s4
8438 C Derivatives in gamma(k-1)
8439       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8440       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8441       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8442       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8443 C Derivatives in gamma(l-1)
8444       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8445       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8446       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8447       vv(1)=pizda(1,1)+pizda(2,2)
8448       vv(2)=pizda(2,1)-pizda(1,2)
8449       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8450       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8451 C Cartesian derivatives.
8452       do iii=1,2
8453         do kkk=1,5
8454           do lll=1,3
8455 #ifdef MOMENT
8456             if (iii.eq.1) then
8457               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8458             else
8459               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8460             endif
8461 #endif
8462             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8463      &        auxvec(1))
8464             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8465             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8466      &        auxvec(1))
8467             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8468             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8469      &        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 #ifdef MOMENT
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8475 #else
8476             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8477 #endif
8478             if (swap) then
8479               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8480             else
8481               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8482             endif
8483 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8484           enddo
8485         enddo
8486       enddo
8487       return
8488       end
8489 c----------------------------------------------------------------------------
8490       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8491       implicit real*8 (a-h,o-z)
8492       include 'DIMENSIONS'
8493       include 'COMMON.IOUNITS'
8494       include 'COMMON.CHAIN'
8495       include 'COMMON.DERIV'
8496       include 'COMMON.INTERACT'
8497       include 'COMMON.CONTACTS'
8498       include 'COMMON.TORSION'
8499       include 'COMMON.VAR'
8500       include 'COMMON.GEO'
8501       include 'COMMON.FFIELD'
8502       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8503      & auxvec1(2),auxmat1(2,2)
8504       logical swap
8505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8506 C                                                                              C
8507 C      Parallel       Antiparallel                                             C
8508 C                                                                              C
8509 C          o             o                                                     C
8510 C         /l\   /   \   /j\                                                    C
8511 C        /   \ /     \ /   \                                                   C
8512 C       /| o |o       o| o |\                                                  C
8513 C     \ j|/k\|      \  |/k\|l                                                  C
8514 C      \ /   \       \ /   \                                                   C
8515 C       o     \       o     \                                                  C
8516 C       i             i                                                        C
8517 C                                                                              C
8518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8519 C
8520 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8521 C           energy moment and not to the cluster cumulant.
8522 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8523       iti=itortyp(itype(i))
8524       itj=itortyp(itype(j))
8525       if (j.lt.nres-1) then
8526         itj1=itortyp(itype(j+1))
8527       else
8528         itj1=ntortyp+1
8529       endif
8530       itk=itortyp(itype(k))
8531       if (k.lt.nres-1) then
8532         itk1=itortyp(itype(k+1))
8533       else
8534         itk1=ntortyp+1
8535       endif
8536       itl=itortyp(itype(l))
8537       if (l.lt.nres-1) then
8538         itl1=itortyp(itype(l+1))
8539       else
8540         itl1=ntortyp+1
8541       endif
8542 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8543 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8544 cd     & ' itl',itl,' itl1',itl1
8545 #ifdef MOMENT
8546       if (imat.eq.1) then
8547         s1=dip(3,jj,i)*dip(3,kk,k)
8548       else
8549         s1=dip(2,jj,j)*dip(2,kk,l)
8550       endif
8551 #endif
8552       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8553       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8554       if (j.eq.l+1) then
8555         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8556         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8557       else
8558         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8559         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8560       endif
8561       call transpose2(EUg(1,1,k),auxmat(1,1))
8562       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8563       vv(1)=pizda(1,1)-pizda(2,2)
8564       vv(2)=pizda(2,1)+pizda(1,2)
8565       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8566 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8567 #ifdef MOMENT
8568       eello6_graph4=-(s1+s2+s3+s4)
8569 #else
8570       eello6_graph4=-(s2+s3+s4)
8571 #endif
8572 C Derivatives in gamma(i-1)
8573       if (i.gt.1) then
8574 #ifdef MOMENT
8575         if (imat.eq.1) then
8576           s1=dipderg(2,jj,i)*dip(3,kk,k)
8577         else
8578           s1=dipderg(4,jj,j)*dip(2,kk,l)
8579         endif
8580 #endif
8581         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8582         if (j.eq.l+1) then
8583           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8584           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8585         else
8586           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8587           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8588         endif
8589         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8590         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8591 cd          write (2,*) 'turn6 derivatives'
8592 #ifdef MOMENT
8593           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8594 #else
8595           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8596 #endif
8597         else
8598 #ifdef MOMENT
8599           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8600 #else
8601           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8602 #endif
8603         endif
8604       endif
8605 C Derivatives in gamma(k-1)
8606 #ifdef MOMENT
8607       if (imat.eq.1) then
8608         s1=dip(3,jj,i)*dipderg(2,kk,k)
8609       else
8610         s1=dip(2,jj,j)*dipderg(4,kk,l)
8611       endif
8612 #endif
8613       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8614       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8615       if (j.eq.l+1) then
8616         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8617         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8618       else
8619         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8620         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8621       endif
8622       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8623       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8624       vv(1)=pizda(1,1)-pizda(2,2)
8625       vv(2)=pizda(2,1)+pizda(1,2)
8626       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8627       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8628 #ifdef MOMENT
8629         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8630 #else
8631         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8632 #endif
8633       else
8634 #ifdef MOMENT
8635         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8638 #endif
8639       endif
8640 C Derivatives in gamma(j-1) or gamma(l-1)
8641       if (l.eq.j+1 .and. l.gt.1) then
8642         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8643         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8644         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8645         vv(1)=pizda(1,1)-pizda(2,2)
8646         vv(2)=pizda(2,1)+pizda(1,2)
8647         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8648         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8649       else if (j.gt.1) then
8650         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8651         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8652         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8653         vv(1)=pizda(1,1)-pizda(2,2)
8654         vv(2)=pizda(2,1)+pizda(1,2)
8655         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8656         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8657           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8658         else
8659           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8660         endif
8661       endif
8662 C Cartesian derivatives.
8663       do iii=1,2
8664         do kkk=1,5
8665           do lll=1,3
8666 #ifdef MOMENT
8667             if (iii.eq.1) then
8668               if (imat.eq.1) then
8669                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8670               else
8671                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8672               endif
8673             else
8674               if (imat.eq.1) then
8675                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8676               else
8677                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8678               endif
8679             endif
8680 #endif
8681             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8682      &        auxvec(1))
8683             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8684             if (j.eq.l+1) then
8685               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8686      &          b1(1,itj1),auxvec(1))
8687               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8688             else
8689               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8690      &          b1(1,itl1),auxvec(1))
8691               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8692             endif
8693             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8694      &        pizda(1,1))
8695             vv(1)=pizda(1,1)-pizda(2,2)
8696             vv(2)=pizda(2,1)+pizda(1,2)
8697             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8698             if (swap) then
8699               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8700 #ifdef MOMENT
8701                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8702      &             -(s1+s2+s4)
8703 #else
8704                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8705      &             -(s2+s4)
8706 #endif
8707                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8708               else
8709 #ifdef MOMENT
8710                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8711 #else
8712                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8713 #endif
8714                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8715               endif
8716             else
8717 #ifdef MOMENT
8718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8719 #else
8720               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8721 #endif
8722               if (l.eq.j+1) then
8723                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8724               else
8725                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8726               endif
8727             endif
8728           enddo
8729         enddo
8730       enddo
8731       return
8732       end
8733 c----------------------------------------------------------------------------
8734       double precision function eello_turn6(i,jj,kk)
8735       implicit real*8 (a-h,o-z)
8736       include 'DIMENSIONS'
8737       include 'COMMON.IOUNITS'
8738       include 'COMMON.CHAIN'
8739       include 'COMMON.DERIV'
8740       include 'COMMON.INTERACT'
8741       include 'COMMON.CONTACTS'
8742       include 'COMMON.TORSION'
8743       include 'COMMON.VAR'
8744       include 'COMMON.GEO'
8745       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8746      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8747      &  ggg1(3),ggg2(3)
8748       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8749      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8750 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8751 C           the respective energy moment and not to the cluster cumulant.
8752       s1=0.0d0
8753       s8=0.0d0
8754       s13=0.0d0
8755 c
8756       eello_turn6=0.0d0
8757       j=i+4
8758       k=i+1
8759       l=i+3
8760       iti=itortyp(itype(i))
8761       itk=itortyp(itype(k))
8762       itk1=itortyp(itype(k+1))
8763       itl=itortyp(itype(l))
8764       itj=itortyp(itype(j))
8765 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8766 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8767 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8768 cd        eello6=0.0d0
8769 cd        return
8770 cd      endif
8771 cd      write (iout,*)
8772 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8773 cd     &   ' and',k,l
8774 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8775       do iii=1,2
8776         do kkk=1,5
8777           do lll=1,3
8778             derx_turn(lll,kkk,iii)=0.0d0
8779           enddo
8780         enddo
8781       enddo
8782 cd      eij=1.0d0
8783 cd      ekl=1.0d0
8784 cd      ekont=1.0d0
8785       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8786 cd      eello6_5=0.0d0
8787 cd      write (2,*) 'eello6_5',eello6_5
8788 #ifdef MOMENT
8789       call transpose2(AEA(1,1,1),auxmat(1,1))
8790       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8791       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8792       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8793 #endif
8794       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8795       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8796       s2 = scalar2(b1(1,itk),vtemp1(1))
8797 #ifdef MOMENT
8798       call transpose2(AEA(1,1,2),atemp(1,1))
8799       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8800       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8801       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8802 #endif
8803       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8804       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8805       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8806 #ifdef MOMENT
8807       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8808       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8809       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8810       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8811       ss13 = scalar2(b1(1,itk),vtemp4(1))
8812       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8813 #endif
8814 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8815 c      s1=0.0d0
8816 c      s2=0.0d0
8817 c      s8=0.0d0
8818 c      s12=0.0d0
8819 c      s13=0.0d0
8820       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8821 C Derivatives in gamma(i+2)
8822       s1d =0.0d0
8823       s8d =0.0d0
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,1),auxmatd(1,1))
8826       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8827       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8828       call transpose2(AEAderg(1,1,2),atempd(1,1))
8829       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8830       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8831 #endif
8832       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8833       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8834       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8835 c      s1d=0.0d0
8836 c      s2d=0.0d0
8837 c      s8d=0.0d0
8838 c      s12d=0.0d0
8839 c      s13d=0.0d0
8840       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8841 C Derivatives in gamma(i+3)
8842 #ifdef MOMENT
8843       call transpose2(AEA(1,1,1),auxmatd(1,1))
8844       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8845       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8847 #endif
8848       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8849       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8850       s2d = scalar2(b1(1,itk),vtemp1d(1))
8851 #ifdef MOMENT
8852       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8853       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8854 #endif
8855       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8856 #ifdef MOMENT
8857       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8858       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8859       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8860 #endif
8861 c      s1d=0.0d0
8862 c      s2d=0.0d0
8863 c      s8d=0.0d0
8864 c      s12d=0.0d0
8865 c      s13d=0.0d0
8866 #ifdef MOMENT
8867       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8868      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8869 #else
8870       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8871      &               -0.5d0*ekont*(s2d+s12d)
8872 #endif
8873 C Derivatives in gamma(i+4)
8874       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8875       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8876       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8877 #ifdef MOMENT
8878       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8879       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8880       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8881 #endif
8882 c      s1d=0.0d0
8883 c      s2d=0.0d0
8884 c      s8d=0.0d0
8885 C      s12d=0.0d0
8886 c      s13d=0.0d0
8887 #ifdef MOMENT
8888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8889 #else
8890       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8891 #endif
8892 C Derivatives in gamma(i+5)
8893 #ifdef MOMENT
8894       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8897 #endif
8898       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8899       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8900       s2d = scalar2(b1(1,itk),vtemp1d(1))
8901 #ifdef MOMENT
8902       call transpose2(AEA(1,1,2),atempd(1,1))
8903       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8904       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8905 #endif
8906       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8907       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8908 #ifdef MOMENT
8909       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8910       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8911       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8912 #endif
8913 c      s1d=0.0d0
8914 c      s2d=0.0d0
8915 c      s8d=0.0d0
8916 c      s12d=0.0d0
8917 c      s13d=0.0d0
8918 #ifdef MOMENT
8919       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8920      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8921 #else
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8923      &               -0.5d0*ekont*(s2d+s12d)
8924 #endif
8925 C Cartesian derivatives
8926       do iii=1,2
8927         do kkk=1,5
8928           do lll=1,3
8929 #ifdef MOMENT
8930             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8931             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #endif
8934             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8935             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8936      &          vtemp1d(1))
8937             s2d = scalar2(b1(1,itk),vtemp1d(1))
8938 #ifdef MOMENT
8939             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8940             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8941             s8d = -(atempd(1,1)+atempd(2,2))*
8942      &           scalar2(cc(1,1,itl),vtemp2(1))
8943 #endif
8944             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8945      &           auxmatd(1,1))
8946             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8947             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8948 c      s1d=0.0d0
8949 c      s2d=0.0d0
8950 c      s8d=0.0d0
8951 c      s12d=0.0d0
8952 c      s13d=0.0d0
8953 #ifdef MOMENT
8954             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8955      &        - 0.5d0*(s1d+s2d)
8956 #else
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8958      &        - 0.5d0*s2d
8959 #endif
8960 #ifdef MOMENT
8961             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8962      &        - 0.5d0*(s8d+s12d)
8963 #else
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8965      &        - 0.5d0*s12d
8966 #endif
8967           enddo
8968         enddo
8969       enddo
8970 #ifdef MOMENT
8971       do kkk=1,5
8972         do lll=1,3
8973           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8974      &      achuj_tempd(1,1))
8975           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8976           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8977           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8978           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8979           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8980      &      vtemp4d(1))
8981           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8982           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8983           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8984         enddo
8985       enddo
8986 #endif
8987 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8988 cd     &  16*eel_turn6_num
8989 cd      goto 1112
8990       if (j.lt.nres-1) then
8991         j1=j+1
8992         j2=j-1
8993       else
8994         j1=j-1
8995         j2=j-2
8996       endif
8997       if (l.lt.nres-1) then
8998         l1=l+1
8999         l2=l-1
9000       else
9001         l1=l-1
9002         l2=l-2
9003       endif
9004       do ll=1,3
9005 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9006 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9007 cgrad        ghalf=0.5d0*ggg1(ll)
9008 cd        ghalf=0.0d0
9009         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9010         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9011         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9012      &    +ekont*derx_turn(ll,2,1)
9013         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9014         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9015      &    +ekont*derx_turn(ll,4,1)
9016         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9017         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9018         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9019 cgrad        ghalf=0.5d0*ggg2(ll)
9020 cd        ghalf=0.0d0
9021         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9022      &    +ekont*derx_turn(ll,2,2)
9023         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9024         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9025      &    +ekont*derx_turn(ll,4,2)
9026         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9027         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9028         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9029       enddo
9030 cd      goto 1112
9031 cgrad      do m=i+1,j-1
9032 cgrad        do ll=1,3
9033 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9034 cgrad        enddo
9035 cgrad      enddo
9036 cgrad      do m=k+1,l-1
9037 cgrad        do ll=1,3
9038 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9039 cgrad        enddo
9040 cgrad      enddo
9041 cgrad1112  continue
9042 cgrad      do m=i+2,j2
9043 cgrad        do ll=1,3
9044 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9045 cgrad        enddo
9046 cgrad      enddo
9047 cgrad      do m=k+2,l2
9048 cgrad        do ll=1,3
9049 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9050 cgrad        enddo
9051 cgrad      enddo
9052 cd      do iii=1,nres-3
9053 cd        write (2,*) iii,g_corr6_loc(iii)
9054 cd      enddo
9055       eello_turn6=ekont*eel_turn6
9056 cd      write (2,*) 'ekont',ekont
9057 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9058       return
9059       end
9060
9061 C-----------------------------------------------------------------------------
9062       double precision function scalar(u,v)
9063 !DIR$ INLINEALWAYS scalar
9064 #ifndef OSF
9065 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9066 #endif
9067       implicit none
9068       double precision u(3),v(3)
9069 cd      double precision sc
9070 cd      integer i
9071 cd      sc=0.0d0
9072 cd      do i=1,3
9073 cd        sc=sc+u(i)*v(i)
9074 cd      enddo
9075 cd      scalar=sc
9076
9077       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9078       return
9079       end
9080 crc-------------------------------------------------
9081       SUBROUTINE MATVEC2(A1,V1,V2)
9082 !DIR$ INLINEALWAYS MATVEC2
9083 #ifndef OSF
9084 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9085 #endif
9086       implicit real*8 (a-h,o-z)
9087       include 'DIMENSIONS'
9088       DIMENSION A1(2,2),V1(2),V2(2)
9089 c      DO 1 I=1,2
9090 c        VI=0.0
9091 c        DO 3 K=1,2
9092 c    3     VI=VI+A1(I,K)*V1(K)
9093 c        Vaux(I)=VI
9094 c    1 CONTINUE
9095
9096       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9097       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9098
9099       v2(1)=vaux1
9100       v2(2)=vaux2
9101       END
9102 C---------------------------------------
9103       SUBROUTINE MATMAT2(A1,A2,A3)
9104 #ifndef OSF
9105 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9106 #endif
9107       implicit real*8 (a-h,o-z)
9108       include 'DIMENSIONS'
9109       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9110 c      DIMENSION AI3(2,2)
9111 c        DO  J=1,2
9112 c          A3IJ=0.0
9113 c          DO K=1,2
9114 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9115 c          enddo
9116 c          A3(I,J)=A3IJ
9117 c       enddo
9118 c      enddo
9119
9120       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9121       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9122       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9123       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9124
9125       A3(1,1)=AI3_11
9126       A3(2,1)=AI3_21
9127       A3(1,2)=AI3_12
9128       A3(2,2)=AI3_22
9129       END
9130
9131 c-------------------------------------------------------------------------
9132       double precision function scalar2(u,v)
9133 !DIR$ INLINEALWAYS scalar2
9134       implicit none
9135       double precision u(2),v(2)
9136       double precision sc
9137       integer i
9138       scalar2=u(1)*v(1)+u(2)*v(2)
9139       return
9140       end
9141
9142 C-----------------------------------------------------------------------------
9143
9144       subroutine transpose2(a,at)
9145 !DIR$ INLINEALWAYS transpose2
9146 #ifndef OSF
9147 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9148 #endif
9149       implicit none
9150       double precision a(2,2),at(2,2)
9151       at(1,1)=a(1,1)
9152       at(1,2)=a(2,1)
9153       at(2,1)=a(1,2)
9154       at(2,2)=a(2,2)
9155       return
9156       end
9157 c--------------------------------------------------------------------------
9158       subroutine transpose(n,a,at)
9159       implicit none
9160       integer n,i,j
9161       double precision a(n,n),at(n,n)
9162       do i=1,n
9163         do j=1,n
9164           at(j,i)=a(i,j)
9165         enddo
9166       enddo
9167       return
9168       end
9169 C---------------------------------------------------------------------------
9170       subroutine prodmat3(a1,a2,kk,transp,prod)
9171 !DIR$ INLINEALWAYS prodmat3
9172 #ifndef OSF
9173 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9174 #endif
9175       implicit none
9176       integer i,j
9177       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9178       logical transp
9179 crc      double precision auxmat(2,2),prod_(2,2)
9180
9181       if (transp) then
9182 crc        call transpose2(kk(1,1),auxmat(1,1))
9183 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9184 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9185
9186            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9187      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9188            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9189      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9190            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9191      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9192            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9193      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9194
9195       else
9196 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9197 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9198
9199            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9200      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9201            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9202      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9203            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9204      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9205            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9206      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9207
9208       endif
9209 c      call transpose2(a2(1,1),a2t(1,1))
9210
9211 crc      print *,transp
9212 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9213 crc      print *,((prod(i,j),i=1,2),j=1,2)
9214
9215       return
9216       end
9217